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

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 39d1f82b520df44c80fa4acf6614709bb05a0f4c
Author: Ludovic Courtès <address@hidden>
Date:   Thu Dec 4 23:52:28 2014 +0100

    system: Make /boot/grub/grub.cfg an indirect GC root.
    
    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.
---
 gnu/build/install.scm   |    9 +++++----
 gnu/build/vm.scm        |   16 ++++++++++++++++
 guix/scripts/system.scm |   12 ++++++++----
 3 files changed, 29 insertions(+), 8 deletions(-)

diff --git a/gnu/build/install.scm b/gnu/build/install.scm
index a472259..111b79e 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 03db1cd..1762582 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 35f858c..f2a25dd 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))