bug#26339: [PATCH v2 09/12] scripts: system: Adapt "reconfigure" to new bootloader API.

[Mathieu Othacehe <m.othacehe@gmail.com>]

* guix/scripts/system.scm (install-grub*): Rename to install-bootloader. Use
  keys to pass arguments. Pass a new argument, "install-procedure" which is
  a script in store dealing with bootloader-specific install actions.
  Also call "install-boot-config" to install the bootloader config file.
(install-bootloader-derivation): New procedure. It returns a derivation that
builds a file containing "install-procedure" gexp.
(perform-action): Build install-proc derivation and call install-bootloader
with the resulting file. Stop adding GRUB to PATH as bootloaders are called in
install-proc with direct store paths.
---
 guix/scripts/system.scm | 112 +++++++++++++++++++++++++++++-------------------
 1 file changed, 67 insertions(+), 45 deletions(-)

diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index b1104eb9b..1776dc00f 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -147,27 +147,34 @@ TARGET, and register them."
               (map (cut copy-item <> target #:log-port log-port)
                    to-copy))))
 
-(define (install-grub* grub.cfg device target)
-  "This is a variant of 'install-grub' with error handling, lifted in
-%STORE-MONAD"
-  (let* ((gc-root      (string-append target %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))
+(define* (install-bootloader install-procedure
+                             #:key
+                             bootcfg bootcfg-location
+                             device target)
+  "Call INSTALL-PROCEDURE with error handling, in %STORE-MONAD."
+  (with-monad %store-monad
+    (let* ((gc-root      (string-append target %gc-roots-directory
+                                        "/bootcfg"))
+           (temp-gc-root (string-append gc-root ".new"))
+           (install (and install-procedure
+                         (derivation->output-path install-procedure)))
+           (bootcfg (derivation->output-path bootcfg)))
+      ;; Prepare the symlink to bootloader config file to make sure that it's
+      ;; a GC root when 'install-procedure' completes (being a bit paranoid.)
+      (switch-symlinks temp-gc-root bootcfg)
+
+      (unless (false-if-exception
+               (begin
+                 (install-boot-config bootcfg bootcfg-location target)
+                 (when install
+                   (save-load-path-excursion (primitive-load install)))))
         (delete-file temp-gc-root)
-        (leave (_ "failed to install GRUB on device '~a'~%") device))
+        (leave (_ "failed to install bootloader on device ~a '~a'~%") install device))
 
-      ;; Register GRUB.CFG as a GC root so that its dependencies (background
-      ;; image, font, etc.) are not reclaimed.
-      (rename temp-gc-root gc-root))))
+      ;; Register bootloader config file as a GC root so that its dependencies
+      ;; (background image, font, etc.) are not reclaimed.
+      (rename-file temp-gc-root gc-root)
+      (return #t))))
 
 (define* (install os-drv target
                   #:key (log-port (current-output-port))
@@ -597,17 +604,28 @@ PATTERN, a string.  When PATTERN is #f, display all the system generations."
     (warning (_ "Consider running 'guix pull' before 'reconfigure'.~%"))
     (warning (_ "Failing to do that may downgrade your system!~%"))))
 
+(define (install-bootloader-derivation install-procedure
+                                       bootloader device target)
+  (with-monad %store-monad
+    (gexp->file "install-bootloader"
+                (with-imported-modules '((guix build utils))
+                  #~(begin
+                      (use-modules (guix build utils))
+                      (#$install-procedure #$bootloader
+                                           #$device
+                                           #$target))))))
+
 (define* (perform-action action os
                          #:key bootloader? dry-run? derivations-only?
                          use-substitutes? device target
                          image-size full-boot?
                          (mappings '())
                          (gc-root #f))
-  "Perform ACTION for OS.  GRUB? specifies whether to install GRUB; DEVICE is
-the target devices for GRUB; TARGET is the target root directory; IMAGE-SIZE
-is the size of the image to be built, for the 'vm-image' and 'disk-image'
-actions.  FULL-BOOT? is used for the 'vm' action; it determines whether to
-boot directly to the kernel or to the bootloader.
+  "Perform ACTION for OS.  BOOTLOADER? specifies whether to install
+bootloader; DEVICE is the target devices for bootloader; TARGET is the target
+root directory; IMAGE-SIZE is the size of the image to be built, for the
+'vm-image' and 'disk-image' actions.  FULL-BOOT? is used for the 'vm' action;
+it determines whether to boot directly to the kernel or to the bootloader.
 
 When DERIVATIONS-ONLY? is true, print the derivation file name(s) without
 building anything.
@@ -630,20 +648,28 @@ output when building a system derivation, such as a disk image."
                      (if bootloader
                          (package->derivation bootloader)
                          (return #f))))
-       (grub.cfg  (if (eq? 'container action)
-                      (return #f)
-                      (operating-system-bootcfg os
-                                                (if (eq? 'init action)
-                                                    '()
-                                                    (profile-grub-entries)))))
-
-       ;; 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
-       ;; root.  See <http://bugs.gnu.org/21068>.
+       (bootcfg  (if (eq? 'container action)
+                     (return #f)
+                     (operating-system-bootcfg
+                      os
+                      (if (eq? 'init action)
+                          '()
+                          (profile-bootloader-entries)))))
+       (bootcfg-location -> (bootloader-configuration-file-name
+                             (operating-system-bootloader os)))
+       (install-proc
+        (let ((procedure (bootloader-configuration-installer
+                          (operating-system-bootloader os)))
+              (target    (or target "/")))
+          (install-bootloader-derivation procedure bootloader device target)))
+
+       ;; For 'init' and 'reconfigure', always build BOOTCFG, even if
+       ;; --no-bootloader is passed, because we then use it as a GC root.
+       ;; See <http://bugs.gnu.org/21068>.
        (drvs   -> (if (memq action '(init reconfigure))
                       (if (and bootloader? bootloader)
-                          (list sys grub.cfg bootloader)
-                          (list sys grub.cfg))
+                          (list sys bootcfg bootloader install-proc)
+                          (list sys bootcfg))
                       (list sys)))
        (%         (if derivations-only?
                       (return (for-each (compose println derivation-file-name)
@@ -657,20 +683,16 @@ output when building a system derivation, such as a disk image."
           (for-each (compose println derivation->output-path)
                     drvs)
 
-          ;; Make sure GRUB is accessible.
-          (when (and bootloader? bootloader)
-            (let ((prefix (derivation->output-path bootloader)))
-              (setenv "PATH"
-                      (string-append  prefix "/bin:" prefix "/sbin:"
-                                      (getenv "PATH")))))
-
           (case action
             ((reconfigure)
              (mbegin %store-monad
                (switch-to-system os)
                (mwhen bootloader?
-                 (install-grub* (derivation->output-path grub.cfg)
-                                device "/"))))
+                 (install-bootloader install-proc
+                                     #:bootcfg bootcfg
+                                     #:bootcfg-location bootcfg-location
+                                     #:device device
+                                     #:target "/"))))
             ((init)
              (newline)
              (format #t (_ "initializing operating system under '~a'...~%")
-- 
2.12.2