[RFCv2] install: Create a GC root during install-grub.

[Jookia <166291@gmail.com>]

While previously creating a GC root for GRUB's resources was the caller's
responsibility, it's much less repetitive to put it in install-grub now that
it's wrapped by error handling. This also means we can replace the install-grub*
function with a small definition inside perform-action named 'install-boot'.

* gnu/build/install.scm (install-grub): Make a GC root for grub.cfg on success.
  (register-grub.cfg-root): Remove function, install-grub does this now.
* gnu/system/vm.scm (qemu-image): Don't explicitly make a GC root.
* guix/scripts/system.scm (install-grub*): Move useful parts to perform-action.
  (perform-action): Use inline definition install-boot to install GRUB.
---
 gnu/build/install.scm   | 22 +++++++++-------------
 gnu/system/vm.scm       | 15 +++++++--------
 guix/scripts/system.scm | 47 +++++++++++++----------------------------------
 3 files changed, 29 insertions(+), 55 deletions(-)

diff --git a/gnu/build/install.scm b/gnu/build/install.scm
index e4f087f..b28dea8 100644
--- a/gnu/build/install.scm
+++ b/gnu/build/install.scm
@@ -22,7 +22,6 @@
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 match)
   #:export (install-grub
-            register-grub.cfg-root
             populate-root-file-system
             reset-timestamps
             register-closure
@@ -39,13 +38,10 @@
 
 (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
-so that the fonts, background images, etc. referred to by GRUB.CFG are not
-GC'd."
+MOUNT-POINT."
   (let* ((target (string-append mount-point "/boot/grub/grub.cfg"))
-         (pivot  (string-append target ".new")))
+         (pivot  (string-append target ".new"))
+         (gcroot "/var/guix/gcroots"))
     (mkdir-p (dirname target))
 
     ;; Copy GRUB.CFG instead of just symlinking it, because symlinks won't
@@ -57,13 +53,13 @@ GC'd."
                             "--boot-directory"
                             (string-append mount-point "/boot")
                             device))
-      (error "failed to install GRUB"))))
+      (error "failed to install GRUB"))
 
-(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 grub.cfg (string-append directory "/grub.cfg"))))
+    ;; Register GRUB.CFG as a GC root so the fonts, background images, etc.
+    ;; referred to by GRUB.CFG are not GC'd.
+    (evaluate-populate-directive `(directory ,gcroot) mount-point)
+    (evaluate-populate-directive
+      `(,(string-append gcroot "/grub.cfg") -> ,grub.cfg) mount-point)))
 
 (define (evaluate-populate-directive directive target)
   "Evaluate DIRECTIVE, an sexp describing a file or directory to create under
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 35c573d..e8a577c 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -228,14 +228,13 @@ the image."
                       (guix build utils))
 
          (define* (do-install-grub #:key device target)
-           (and #$(prepare-install-grub
-                    #:mount-point 'target
-                    #:grub.cfg grub.cfg
-                    #:config
-                      (grub-configuration
-                        (inherit (operating-system-bootloader os-configuration))
-                        (device drive)))
-                (register-grub.cfg-root target #$grub.cfg)))
+           #$(prepare-install-grub
+               #:mount-point 'target
+               #:grub.cfg grub.cfg
+               #:config
+                 (grub-configuration
+                   (inherit (operating-system-bootloader os-configuration))
+                   (device drive))))
 
          (let ((inputs
                 '#$(append (list qemu parted grub e2fsprogs)
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 4374a10..f3a10a5 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -125,32 +125,6 @@ TARGET, and register them."
               (map (cut copy-item <> target #:log-port log-port)
                    to-copy))))
 
-(define* (install-grub* #:key grub.cfg config target)
-  "This is a variant of 'install-grub' with error handling, lifted in
-%STORE-MONAD"
-  (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 (eval (prepare-install-grub
-                       #:grub.cfg grub.cfg
-                       #:config config
-                       #:mount-point target)
-               (current-module))
-        (delete-file temp-gc-root)
-        (leave (_ "failed to install GRUB on device '~a'~%")
-          (grub-configuration-device config)))
-
-      ;; Register GRUB.CFG as a GC root so that its dependencies (background
-      ;; image, font, etc.) are not reclaimed.
-      (rename temp-gc-root gc-root))))
-
 (define* (install os-drv target grub.cfg
                   #:key (log-port (current-output-port)))
   "Copy the closure of GRUB.CFG, which includes the output of OS-DRV, to
@@ -487,6 +461,7 @@ building anything."
                                                  (if (eq? 'init action)
                                                      '()
                                                      (previous-grub-entries)))))
+       (grub-config -> (operating-system-bootloader os))
 
        ;; For 'init' and 'reconfigure', always build GRUB.CFG, even if
        ;; --no-grub is passed, because GRUB.CFG because we then use it as a GC
@@ -502,6 +477,16 @@ building anything."
                       (maybe-build drvs #:dry-run? dry-run?
                                    #:use-substitutes? use-substitutes?))))
 
+    (define (install-boot mount-point)
+      (mbegin %store-monad
+        (munless (eval (prepare-install-grub
+                         #:grub.cfg (derivation->output-path grub.cfg)
+                         #:config grub-config
+                         #:mount-point mount-point)
+                       (current-module))
+          (leave (_ "failed to install GRUB on device '~a'~%")
+            (grub-configuration-device grub-config)))))
+
     (if (or dry-run? derivations-only?)
         (return #f)
         (begin
@@ -520,10 +505,7 @@ building anything."
              (mbegin %store-monad
                (switch-to-system os)
                (mwhen grub?
-                 (install-grub*
-                   #:grub.cfg (derivation->output-path grub.cfg)
-                   #:config (operating-system-bootloader os)
-                   #:target "/"))))
+                 (install-boot "/"))))
             ((init)
              (newline)
              (format #t (_ "initializing operating system under '~a'...~%")
@@ -532,10 +514,7 @@ building anything."
                (install sys (canonicalize-path target)
                         (derivation->output-path grub.cfg))
                (mwhen grub?
-                 (install-grub*
-                   #:grub.cfg (derivation->output-path grub.cfg)
-                   #:config (operating-system-bootloader os)
-                   #:target target))))
+                 (install-boot mount-point))))
             (else
              ;; All we had to do was to build SYS.
              (return (derivation->output-path sys))))))))
-- 
2.7.0