diff options
| -rw-r--r-- | gnu/build/install.scm | 13 | ||||
| -rw-r--r-- | gnu/build/vm.scm | 19 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 13 |
3 files changed, 25 insertions, 20 deletions
diff --git a/gnu/build/install.scm b/gnu/build/install.scm index 111b79ee59..aa901f6971 100644 --- a/gnu/build/install.scm +++ b/gnu/build/install.scm @@ -36,15 +36,18 @@ (define* (install-grub grub.cfg device mount-point) "Install GRUB with GRUB.CFG on DEVICE, which is assumed to be mounted on -MOUNT-POINT. Note that the caller must make sure that GRUB.CFG is registered -as a GC root." +MOUNT-POINT. + +Note that the caller must make sure that GRUB.CFG is registered as a GC root +so that the fonts, background images, etc. referred to by GRUB.CFG are not +GC'd." (let* ((target (string-append mount-point "/boot/grub/grub.cfg")) (pivot (string-append target ".new"))) (mkdir-p (dirname target)) - ;; Symlink GRUB.CFG, under the assumption that it has been registered as a - ;; GC root somewhere. Do that atomically. - (symlink grub.cfg pivot) + ;; Copy GRUB.CFG instead of just symlinking it, because symlinks won't + ;; work when /boot is on a separate partition. Do that atomically. + (copy-file grub.cfg pivot) (rename-file pivot target) (unless (zero? (system* "grub-install" "--no-floppy" diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm index 1762582343..2c53cf5dd9 100644 --- a/gnu/build/vm.scm +++ b/gnu/build/vm.scm @@ -178,17 +178,11 @@ 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"))) +(define (register-grub.cfg-root target grub.cfg) + "On file system TARGET, register GRUB.CFG as a GC root." + (let ((directory (string-append target "/var/guix/gcroots"))) (mkdir-p directory) - (symlink "/boot/grub/grub.cfg" (string-append directory "/" hash)))) + (symlink grub.cfg (string-append directory "/grub.cfg")))) (define* (initialize-hard-disk device #:key @@ -234,9 +228,8 @@ 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) + ;; Register GRUB.CFG as a GC root. + (register-grub.cfg-root target-directory grub.cfg) ;; 'guix-register' resets timestamps and everything, so no need to do it ;; once more in that case. diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 6a2586086e..27404772b7 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -134,14 +134,23 @@ 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" - (let ((add-root (store-lift add-indirect-root))) + (let* ((gc-root (string-append %gc-roots-directory "/grub.cfg")) + (temp-gc-root (string-append gc-root ".new")) + (delete-file (lift1 delete-file %store-monad)) + (make-symlink (lift2 switch-symlinks %store-monad)) + (rename (lift2 rename-file %store-monad))) (mbegin %store-monad + ;; Prepare the symlink to GRUB.CFG to make sure that it's a GC root when + ;; 'install-grub' completes (being a bit paranoid.) + (make-symlink temp-gc-root grub.cfg) + (munless (false-if-exception (install-grub grub.cfg device target)) + (delete-file temp-gc-root) (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")))) + (rename temp-gc-root gc-root)))) (define* (install os-drv target #:key (log-port (current-output-port)) |