aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--gnu/build/install.scm9
-rw-r--r--gnu/build/vm.scm16
-rw-r--r--guix/scripts/system.scm12
3 files changed, 29 insertions, 8 deletions
diff --git a/gnu/build/install.scm b/gnu/build/install.scm
index a472259a4a..111b79ee59 100644
--- a/gnu/build/install.scm
+++ b/gnu/build/install.scm
@@ -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"
diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm
index 03db1cd5f9..1762582343 100644
--- a/gnu/build/vm.scm
+++ b/gnu/build/vm.scm
@@ -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?
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 35f858cf29..f2a25dd65a 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -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))