guix/guix
3
5
Fork 0
mirror of git://git.savannah.gnu.org/guix.git synced 2023-12-14 03:33:07 +01:00
Code Issues Releases Wiki Activity

system: Make /boot/grub/grub.cfg an indirect GC root.

Browse source 
Fixes <http://bugs.gnu.org/19160>.

* guix/scripts/system.scm (install-grub*): Make /boot/grub/grub.cfg an
  indirect GC root.
* gnu/build/install.scm (install-grub): Make TARGET a symlink.
* gnu/build/vm.scm (register-grub.cfg-root): New procedure.
  (initialize-hard-disk): Use it.
This commit is contained in:
Ludovic Courtès 2014-12-04 23:52:28 +01:00
parent 764ee9e808
commit 39d1f82b52
3 changed files with 29 additions and 8 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

9
gnu/build/install.scm
View file

@ -36,14 +36,15 @@
(define* (install-grub grub.cfg device mount-point)
"Install GRUB with GRUB.CFG on DEVICE, which is assumed to be mounted on
MOUNT-POINT."
MOUNT-POINT. Note that the caller must make sure that GRUB.CFG is registered
as a GC root."
(let* ((target (string-append mount-point "/boot/grub/grub.cfg"))
(pivot (string-append target ".new")))
(mkdir-p (dirname target))
;; Copy GRUB.CFG instead of just symlinking it since it's not a GC root.
;; Do that atomically.
(copy-file grub.cfg pivot)
;; Symlink GRUB.CFG, under the assumption that it has been registered as a
;; GC root somewhere. Do that atomically.
(symlink grub.cfg pivot)
(rename-file pivot target)
(unless (zero? (system* "grub-install" "--no-floppy"

16
gnu/build/vm.scm
View file

@ -178,6 +178,18 @@ volume name."
(display "populating...\n")
(populate-root-file-system system-directory target-directory))
(define (register-grub.cfg-root target)
"On file system TARGET, make '/boot/grub/grub.cfg' an indirect GC root."
(define hash
;; XXX: Believe it or not, this is that nix-base32-encoded SHA1 of the
;; string "/boot/grub/grub.cfg". We need it here, but gcrypt isn't
;; available (a random hash would do as well, though.)
"kv0yq1d48kavqfhjfzvc4lcyazx2mqhv")
(let ((directory (string-append target "/var/guix/gcroots/auto")))
(mkdir-p directory)
(symlink "/boot/grub/grub.cfg" (string-append directory "/" hash))))
(define* (initialize-hard-disk device
#:key
system-directory
@ -222,6 +234,10 @@ SYSTEM-DIRECTORY is the name of the directory of the 'system' derivation."
(install-grub grub.cfg device target-directory)
;; Register $target/boot/grub/grub.cfg as an indirect root, so that GRUB.CFG
;; is not reclaimed.
(register-grub.cfg-root target-directory)
;; 'guix-register' resets timestamps and everything, so no need to do it
;; once more in that case.
(unless register-closures?

12
guix/scripts/system.scm
View file

@ -134,10 +134,14 @@ TARGET, and register them."
(define (install-grub* grub.cfg device target)
"This is a variant of 'install-grub' with error handling, lifted in
%STORE-MONAD"
(with-monad %store-monad
(unless (false-if-exception (install-grub grub.cfg device target))
(leave (_ "failed to install GRUB on device '~a'~%") device))
(return #t)))
(let ((add-root (store-lift add-indirect-root)))
(mbegin %store-monad
(munless (false-if-exception (install-grub grub.cfg device target))
(leave (_ "failed to install GRUB on device '~a'~%") device))
;; Register GRUB.CFG as a GC root so that its dependencies (background
;; image, font, etc.) are not reclaimed.
(add-root "/boot/grub/grub.cfg"))))
(define* (install os-drv target
#:key (log-port (current-output-port))