bug#26339: [PATCH 04/18] bootloader: Add install procedures and use them.

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

From: David Craven <david@craven.ch>

* gnu/system/bootloader.scm (dd, install-grub, install-syslinux): New
  procedures.
* gnu/build/install.scm (install-boot-config): New procedure.
  (install-grub): Move to (gnu system bootloader).
* gnu/build/vm.scm (register-bootcfg-root): Rename register-grub.cfg-root and
  adjust accordingly.
  (initialize-hard-disk): Takes a bootloader, bootcfg, bootcfg-location and
  install-bootloader procedure. Adjust accordingly.
* gnu/system/vm.scm (qemu-image): Adjust to initialize-hard-disk.
  (system-disk-image, system-qemu-image, system-qemu-image/shared-store):
  Adjust to qemu-image.
---
 gnu/build/install.scm     | 36 ++++++++--------------------------
 gnu/build/vm.scm          | 17 ++++++++++------
 gnu/system/bootloader.scm | 49 ++++++++++++++++++++++++++++++++++++++++++++++-
 gnu/system/vm.scm         | 37 +++++++++++++++++++++++------------
 4 files changed, 92 insertions(+), 47 deletions(-)

diff --git a/gnu/build/install.scm b/gnu/build/install.scm
index 5cb6055a0..9e30c0d23 100644
--- a/gnu/build/install.scm
+++ b/gnu/build/install.scm
@@ -22,8 +22,7 @@
   #:use-module (guix build store-copy)
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 match)
-  #:export (install-grub
-            install-grub-config
+  #:export (install-boot-config
             evaluate-populate-directive
             populate-root-file-system
             reset-timestamps
@@ -39,36 +38,17 @@
 ;;;
 ;;; Code:
 
-(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."
-  (install-grub-config grub.cfg mount-point)
-
-  ;; Tell 'grub-install' that there might be a LUKS-encrypted /boot or root
-  ;; partition.
-  (setenv "GRUB_ENABLE_CRYPTODISK" "y")
-
-  (unless (zero? (system* "grub-install" "--no-floppy"
-                          "--boot-directory"
-                          (string-append mount-point "/boot")
-                          device))
-    (error "failed to install GRUB")))
-
-(define (install-grub-config grub.cfg mount-point)
-  "Atomically copy GRUB.CFG into boot/grub/grub.cfg on the 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."
-  (let* ((target (string-append mount-point "/boot/grub/grub.cfg"))
+(define (install-boot-config bootcfg bootcfg-location mount-point)
+  "Atomically copy BOOTCFG into BOOTCFG-LOCATION on the MOUNT-POINT.  Note
+that the caller must make sure that BOOTCFG is registered as a GC root so
+that the fonts, background images, etc. referred to by BOOTCFG are not GC'd."
+  (let* ((target (string-append mount-point bootcfg-location))
          (pivot  (string-append target ".new")))
     (mkdir-p (dirname target))
 
-    ;; Copy GRUB.CFG instead of just symlinking it, because symlinks won't
+    ;; Copy BOOTCFG instead of just symlinking it, because symlinks won't
     ;; work when /boot is on a separate partition.  Do that atomically.
-    (copy-file grub.cfg pivot)
+    (copy-file bootcfg pivot)
     (rename-file pivot target)))
 
 (define (evaluate-populate-directive directive target)
diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm
index 60ee18ebe..c536f4f44 100644
--- a/gnu/build/vm.scm
+++ b/gnu/build/vm.scm
@@ -283,15 +283,18 @@ 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)
+(define (register-bootcfg-root target bootcfg)
   "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"))))
+    (symlink bootcfg (string-append directory "/bootcfg"))))
 
 (define* (initialize-hard-disk device
                                #:key
-                               grub.cfg
+                               bootloader
+                               bootcfg
+                               bootcfg-location
+                               install-bootloader
                                (partitions '()))
   "Initialize DEVICE as a disk containing all the <partition> objects listed
 in PARTITIONS, and using GRUB.CFG as its bootloader configuration file.
@@ -309,10 +312,12 @@ 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)
+    (install-boot-config bootcfg bootcfg-location target)
+    (when install-bootloader
+      (install-bootloader bootloader device target))
 
-    ;; Register GRUB.CFG as a GC root.
-    (register-grub.cfg-root target grub.cfg)
+    ;; Register BOOTCFG as a GC root.
+    (register-bootcfg-root target bootcfg)
 
     (umount target)))
 
diff --git a/gnu/system/bootloader.scm b/gnu/system/bootloader.scm
index 6da19f6d3..ea570ee00 100644
--- a/gnu/system/bootloader.scm
+++ b/gnu/system/bootloader.scm
@@ -38,7 +38,11 @@
             extlinux-configuration
             grub-configuration
             grub-efi-configuration
-            syslinux-configuration))
+            syslinux-configuration
+
+            dd
+            install-grub
+            install-syslinux))
 
 ;;; Commentary:
 ;;;
@@ -155,4 +159,47 @@ TIMEOUT ~a~%"
    (bootloader (@ (gnu packages bootloaders) syslinux))
    (install-procedure install-syslinux)))
 
+\f
+
+;;;
+;;; Bootloader install procedures.
+;;;
+
+(define dd
+  #~(lambda (bs count if of)
+      (zero? (system* "dd"
+                      (string-append "bs=" (number->string bs))
+                      (string-append "count=" (number->string count))
+                      (string-append "if=" if)
+                      (string-append "of=" of)))))
+
+(define install-grub
+  #~(lambda (bootloader device mount-point)
+      ;; Install GRUB on DEVICE which is mounted at MOUNT-POINT.
+      (let ((grub (string-append bootloader "/sbin/grub-install"))
+            (install-dir (string-append mount-point "/boot")))
+        ;; Tell 'grub-install' that there might be a LUKS-encrypted /boot or
+        ;; root partition.
+        (setenv "GRUB_ENABLE_CRYPTODISK" "y")
+
+        (unless (zero? (system* grub "--no-floppy"
+                                "--boot-directory" install-dir
+                                device))
+          (error "failed to install GRUB")))))
+
+(define install-syslinux
+  #~(lambda (bootloader device mount-point)
+      (let ((extlinux (string-append bootloader "/sbin/extlinux"))
+            (install-dir (string-append mount-point "/boot/extlinux"))
+            (syslinux-dir (string-append bootloader "/share/syslinux")))
+        (mkdir-p install-dir)
+        (for-each (lambda (file)
+                    (copy-file file
+                               (string-append install-dir "/" (basename file))))
+                  (find-files syslinux-dir "\\.c32$"))
+
+        (unless (and (zero? (system* extlinux "--install" install-dir))
+                     (#$dd 440 1 (string-append syslinux-dir "/mbr.bin") device))
+          (error "failed to install SYSLINUX")))))
+
 ;;; bootloader.scm ends here
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 5c6e7f684..6f852d7ea 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -45,10 +45,10 @@
                 #:select (%guile-static-stripped))
   #:use-module (gnu packages admin)
 
+  #:use-module (gnu system bootloader)
   #:use-module (gnu system shadow)
   #:use-module (gnu system pam)
   #:use-module (gnu system linux-initrd)
-  #:use-module (gnu system grub)
   #:use-module (gnu system file-systems)
   #:use-module (gnu system)
   #:use-module (gnu services)
@@ -175,8 +175,9 @@ made available under the /xchg CIFS share."
                      (disk-image-format "qcow2")
                      (file-system-type "ext4")
                      file-system-label
-                     os-derivation
-                     grub-configuration
+                     os.drv
+                     bootcfg.drv
+                     bootloader-configuration
                      (register-closures? #t)
                      (inputs '())
                      copy-inputs?)
@@ -200,7 +201,7 @@ the image."
                       (guix build utils))
 
          (let ((inputs
-                '#$(append (list qemu parted grub e2fsprogs)
+                '#$(append (list qemu parted e2fsprogs)
                            (map canonical-package
                                 (list sed grep coreutils findutils gawk))
                            (if register-closures? (list guix) '())))
@@ -222,7 +223,7 @@ the image."
                                #:closures graphs
                                #:copy-closures? #$copy-inputs?
                                #:register-closures? #$register-closures?
-                               #:system-directory #$os-derivation))
+                               #:system-directory #$os.drv))
                   (partitions (list (partition
                                      (size #$(- disk-image-size
                                                 (* 10 (expt 2 20))))
@@ -232,7 +233,16 @@ the image."
                                      (initializer initialize)))))
              (initialize-hard-disk "/dev/vda"
                                    #:partitions partitions
-                                   #:grub.cfg #$grub-configuration)
+                                   #:bootloader
+                                   #$(bootloader-configuration-bootloader
+                                      bootloader-configuration)
+                                   #:bootcfg #$bootcfg.drv
+                                   #:bootcfg-location
+                                   #$(bootloader-configuration-file-location
+                                      bootloader-configuration)
+                                   #:install-bootloader
+                                   #$(bootloader-configuration-install-procedure
+                                      bootloader-configuration))
              (reboot)))))
    #:system system
    #:make-disk-image? #t
@@ -286,8 +296,9 @@ to USB sticks meant to be read-only."
     (mlet* %store-monad ((os-drv   (operating-system-derivation os))
                          (grub.cfg (operating-system-grub.cfg os)))
       (qemu-image #:name name
-                  #:os-derivation os-drv
-                  #:grub-configuration grub.cfg
+                  #:os.drv os-drv
+                  #:bootcfg.drv grub.cfg
+                  #:bootloader-configuration (operating-system-bootloader os)
                   #:disk-image-size disk-image-size
                   #:disk-image-format "raw"
                   #:file-system-type file-system-type
@@ -329,8 +340,9 @@ of the GNU system as described by OS."
     (mlet* %store-monad
         ((os-drv      (operating-system-derivation os))
          (grub.cfg    (operating-system-grub.cfg os)))
-      (qemu-image  #:os-derivation os-drv
-                   #:grub-configuration grub.cfg
+      (qemu-image  #:os.drv os-drv
+                   #:bootcfg.drv grub.cfg
+                   #:bootloader-configuration (operating-system-bootloader os)
                    #:disk-image-size disk-image-size
                    #:file-system-type file-system-type
                    #:inputs `(("system" ,os-drv)
@@ -428,8 +440,9 @@ bootloader refers to: OS kernel, initrd, bootloader data, etc."
     ;; GRUB.CFG and all its dependencies, including the output of OS-DRV.
     ;; This is more than needed (we only need the kernel, initrd, GRUB for its
     ;; font, and the background image), but it's hard to filter that.
-    (qemu-image #:os-derivation os-drv
-                #:grub-configuration grub.cfg
+    (qemu-image #:os.drv os-drv
+                #:bootcfg.drv grub.cfg
+                #:bootloader-configuration (operating-system-bootloader os)
                 #:disk-image-size disk-image-size
                 #:inputs (if full-boot?
                              `(("grub.cfg" ,grub.cfg))
-- 
2.12.2