[RFC 2/4] grub: Add and use prepare-install-grub function.

[Jookia]

Rather than passing around GRUB flags when building a VM or configuring a
system, a new function is added named 'prepare-install-grub'. It takes a
grub.cfg, a <grub-configuration> object and a mount point then returns an
unevaluated function call to install-grub which is incorporated in to a VM
builder script or evaluated when building a system on the host machine.

* gnu/system/grub.scm (prepare-install-grub): Add new function.
  This function is intended to be used to generate build-side code as well as be
  evaluated on the host, and handle errors through false-if-exception.
* gnu/system/vm.scm (qemu-image): Use prepare-install-grub to call install-grub.
  (qemu-image): Pass a new function 'do-install-grub' to initialize-hard-disk.
* guix/scripts/system.scm (install-grub*): Use keys for receiving parameters.
  (install-grub*): Call prepare-install-grub instead.
  (install): No longer take a grub? parameter or call install-grub.
  (perform-action): No longer take a device parameter, and use install-grub*
  to install and set GC roots for both init and reconfigure actions.
* gnu/build/install.scm (register-grub.cfg-root): Move from gnu/build/vm.scm.
* gnu/build/vm.scm (register-grub.cfg-root): Move to gnu/build/install.scm.
  (initialize-hard-disk): Add install-boot parameter, remove grub.cfg parameter.
  (initialize-hard-disk): Use install-boot function to install grub.
  (initialize-hard-disk): Don't register the GC root as install-grub* does.
---
 gnu/build/install.scm   |  7 ++++++
 gnu/build/vm.scm        | 18 ++++++--------
 gnu/system/grub.scm     | 15 +++++++++++-
 gnu/system/vm.scm       | 15 ++++++++++--
 guix/scripts/system.scm | 63 ++++++++++++++++++++++++++-----------------------
 5 files changed, 74 insertions(+), 44 deletions(-)

diff --git a/gnu/build/install.scm b/gnu/build/install.scm
index 9785b6d..e4f087f 100644
--- a/gnu/build/install.scm
+++ b/gnu/build/install.scm
@@ -22,6 +22,7 @@
   #: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
@@ -58,6 +59,12 @@ GC'd."
                             device))
       (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"))))
+
 (define (evaluate-populate-directive directive target)
   "Evaluate DIRECTIVE, an sexp describing a file or directory to create under
 directory TARGET."
diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm
index 48e701a..faee32a 100644
--- a/gnu/build/vm.scm
+++ b/gnu/build/vm.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <address@hidden>
 ;;; Copyright © 2016 Christopher Allan Webber <address@hidden>
 ;;; Copyright © 2016 Leo Famulari <address@hidden>
+;;; Copyright © 2016 Jookia <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -287,18 +288,12 @@ SYSTEM-DIRECTORY is the name of the directory of the 
'system' derivation."
     (unless register-closures?
       (reset-timestamps target))))
 
-(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"))))
-
 (define* (initialize-hard-disk device
                                #:key
-                               grub.cfg
+                               install-boot
                                (partitions '()))
   "Initialize DEVICE as a disk containing all the <partition> objects listed
-in PARTITIONS, and using GRUB.CFG as its bootloader configuration file.
+in PARTITIONS, then run INSTALL-BOOT with the DEVICE and TARGET keys set.
 
 Each partition is initialized by calling its 'initializer' procedure,
 passing it a directory name where it is mounted."
@@ -313,10 +308,11 @@ passing it a directory name where it is mounted."
     (display "mounting root partition...\n")
     (mkdir-p target)
     (mount (partition-device root) target (partition-file-system root))
-    (install-grub grub.cfg device target)
 
-    ;; Register GRUB.CFG as a GC root.
-    (register-grub.cfg-root target grub.cfg)
+    (unless (install-boot
+              #:device device
+              #:target target)
+      (error "unable to install bootloader"))
 
     (umount target)))
 
diff --git a/gnu/system/grub.scm b/gnu/system/grub.scm
index 45b46ca..c9d4359 100644
--- a/gnu/system/grub.scm
+++ b/gnu/system/grub.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <address@hidden>
+;;; Copyright © 2016 Jookia <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -26,6 +27,7 @@
   #:use-module (guix download)
   #:use-module (gnu artwork)
   #:use-module (gnu system file-systems)
+  #:use-module (gnu build install)
   #:autoload   (gnu packages grub) (grub)
   #:autoload   (gnu packages inkscape) (inkscape)
   #:autoload   (gnu packages imagemagick) (imagemagick)
@@ -54,7 +56,8 @@
             menu-entry
             menu-entry?
 
-            grub-configuration-file))
+            grub-configuration-file
+            prepare-install-grub))
 
 ;;; Commentary:
 ;;;
@@ -287,4 +290,14 @@ submenu \"GNU system, old configurations...\" {~%")
 
     (gexp->derivation "grub.cfg" builder)))
 
+(define* (prepare-install-grub #:key grub.cfg config mount-point)
+  "Prepares a call to install-grub with arguments set using the GRUB.CFG, the
+<grub-configuration> CONFIG object and the MOUNT-POINT the system root is on."
+  `(begin
+    (use-modules ((gnu build install)))
+    (false-if-exception
+      (install-grub ,grub.cfg
+                    ,(grub-configuration-device config)
+                    ,mount-point))))
+
 ;;; grub.scm ends here
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index f4bf045..35c573d 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -214,6 +214,7 @@ register INPUTS in the store database of the image so that 
Guix can be used in
 the image."
   (mlet* %store-monad ((os-drv   (operating-system-derivation 
os-configuration))
                        (grub.cfg (operating-system-grub.cfg os-configuration))
+                       (drive -> "/dev/vda")
                        (inputs -> (append
                                     (if (member 'grub.cfg base-inputs)
                                       `(("grub.cfg" ,grub.cfg)) '())
@@ -226,6 +227,16 @@ the image."
          (use-modules (gnu build vm)
                       (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)))
+
          (let ((inputs
                 '#$(append (list qemu parted grub e2fsprogs)
                            (map canonical-package
@@ -257,9 +268,9 @@ the image."
                                      (file-system #$file-system-type)
                                      (bootable? #t)
                                      (initializer initialize)))))
-             (initialize-hard-disk "/dev/vda"
+             (initialize-hard-disk #$drive
                                    #:partitions partitions
-                                   #:grub.cfg #$grub.cfg)
+                                   #:install-boot do-install-grub)
              (reboot))))
      #:system system
      #:make-disk-image? #t
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 7279be0..4374a10 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <address@hidden>
 ;;; Copyright © 2016 Alex Kost <address@hidden>
+;;; Copyright © 2016 Jookia <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -124,7 +125,7 @@ TARGET, and register them."
               (map (cut copy-item <> target #:log-port log-port)
                    to-copy))))
 
-(define (install-grub* grub.cfg device target)
+(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"))
@@ -137,22 +138,24 @@ TARGET, and register them."
       ;; 'install-grub' completes (being a bit paranoid.)
       (make-symlink temp-gc-root grub.cfg)
 
-      (munless (false-if-exception (install-grub grub.cfg device target))
+      (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'~%") device))
+        (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
-                  #:key (log-port (current-output-port))
-                  grub? grub.cfg device)
+(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
 directory TARGET.  TARGET must be an absolute directory name since that's what
-'guix-register' expects.
-
-When GRUB? is true, install GRUB on DEVICE, using GRUB.CFG."
+'guix-register' expects."
   (define (maybe-copy to-copy)
     (with-monad %store-monad
       (if (string=? target "/")
@@ -187,10 +190,7 @@ the ownership of '~a' may be incorrect!~%")
 
       ;; Create a bunch of additional files.
       (format log-port "populating '~a'...~%" target)
-      (populate os-dir target)
-
-      (mwhen grub?
-        (install-grub* grub.cfg device target)))))
+      (populate os-dir target))))
 
 
 ;;;
@@ -461,14 +461,14 @@ PATTERN, a string.  When PATTERN is #f, display all the 
system generations."
 
 (define* (perform-action action os
                          #:key grub? dry-run? derivations-only?
-                         use-substitutes? device target
+                         use-substitutes? target
                          image-size full-boot?
                          (mappings '()))
-  "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.  GRUB? specifies whether to install 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.
 
 When DERIVATIONS-ONLY? is true, print the derivation file name(s) without
 building anything."
@@ -520,16 +520,22 @@ building anything."
              (mbegin %store-monad
                (switch-to-system os)
                (mwhen grub?
-                 (install-grub* (derivation->output-path grub.cfg)
-                                device "/"))))
+                 (install-grub*
+                   #:grub.cfg (derivation->output-path grub.cfg)
+                   #:config (operating-system-bootloader os)
+                   #:target "/"))))
             ((init)
              (newline)
              (format #t (_ "initializing operating system under '~a'...~%")
                      target)
-             (install sys (canonicalize-path target)
-                      #:grub? grub?
-                      #:grub.cfg (derivation->output-path grub.cfg)
-                      #:device device))
+             (mbegin %store-monad
+               (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))))
             (else
              ;; All we had to do was to build SYS.
              (return (derivation->output-path sys))))))))
@@ -693,10 +699,7 @@ resulting from command-line parsing."
          (grub?    (assoc-ref opts 'install-grub?))
          (target   (match args
                      ((first second) second)
-                     (_ #f)))
-         (device   (and grub?
-                        (grub-configuration-device
-                         (operating-system-bootloader os)))))
+                     (_ #f))))
 
     (with-store store
       (set-build-options-from-command-line store opts)
@@ -723,7 +726,7 @@ resulting from command-line parsing."
                                                       (_ #f))
                                                     opts)
                              #:grub? grub?
-                             #:target target #:device device))))
+                             #:target target))))
         #:system system))))
 
 (define (process-command command args opts)
-- 
2.7.0