[bug#41560] [PATCH 1/8] bootloader: Add 'disk-image-installer'.

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

* gnu/bootloader.scm (<bootloader>)[disk-image-installer]: New field,
(bootloader-disk-image-installer): export it.
* gnu/bootloader/grub.scm (install-grub-disk-image): New procedure ...
(grub-bootloader): ... used as "disk-image-installer" here.
(grub-efi-bootloader): set "disk-image-installer" to #f.
* gnu/system/image.scm (root-partition?, find-root-partition): Move to
"Helpers" section.
(root-partition-index): New procedure.
(system-disk-image): Honor disk-image-installer, and
use it to install the bootloader directly on the disk-image, if supported.
---
 gnu/bootloader.scm      |  5 ++++-
 gnu/bootloader/grub.scm | 45 ++++++++++++++++++++++++++++++++++++++++-
 gnu/system/image.scm    | 33 +++++++++++++++++++++---------
 3 files changed, 71 insertions(+), 12 deletions(-)

diff --git a/gnu/bootloader.scm b/gnu/bootloader.scm
index 01bdd4acaa..668caa7fc3 100644
--- a/gnu/bootloader.scm
+++ b/gnu/bootloader.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2017 David Craven <david@craven.ch>
-;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2017, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;; Copyright © 2017 Leo Famulari <leo@famulari.name>
 ;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
 ;;;
@@ -42,6 +42,7 @@
             bootloader-name
             bootloader-package
             bootloader-installer
+            bootloader-disk-image-installer
             bootloader-configuration-file
             bootloader-configuration-file-generator
 
@@ -125,6 +126,8 @@ record."
   (name                            bootloader-name)
   (package                         bootloader-package)
   (installer                       bootloader-installer)
+  (disk-image-installer            bootloader-disk-image-installer
+                                   (default #f))
   (configuration-file              bootloader-configuration-file)
   (configuration-file-generator    bootloader-configuration-file-generator))
 
diff --git a/gnu/bootloader/grub.scm b/gnu/bootloader/grub.scm
index bb40c551a7..74dc00480f 100644
--- a/gnu/bootloader/grub.scm
+++ b/gnu/bootloader/grub.scm
@@ -2,7 +2,7 @@
 ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
 ;;; Copyright © 2017 Leo Famulari <leo@famulari.name>
-;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2017, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;; Copyright © 2019, 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
 ;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
@@ -436,6 +436,47 @@ fi~%"))))
                       "--boot-directory" install-dir
                       device))))
 
+(define install-grub-disk-image
+  #~(lambda (bootloader root-index image)
+      ;; Install GRUB on the given IMAGE. The root partition index is
+      ;; ROOT-INDEX.
+      (let ((grub-mkimage
+             (string-append bootloader "/bin/grub-mkimage"))
+            (modules '("biosdisk" "part_msdos" "fat" "ext2"))
+            (grub-bios-setup
+             (string-append bootloader "/sbin/grub-bios-setup"))
+            (root-device (format #f "hd0,msdos~a" root-index))
+            (boot-img (string-append bootloader "/lib/grub/i386-pc/boot.img"))
+            (device-map "device.map"))
+
+        ;; Create a minimal, standalone Grub image that will be written
+        ;; directly in the MBR-GAP (space between the end of the MBR and the
+        ;; first partition).
+        (apply invoke grub-mkimage
+               "-O" "i386-pc"
+               "-o" "core.img"
+               "-p" (format #f "(~a)/boot/grub" root-device)
+               modules)
+
+        ;; Create a device mapping file.
+        (call-with-output-file device-map
+          (lambda (port)
+            (format port "(hd0) ~a~%" image)))
+
+        ;; Copy the default boot.img, that will be written on the MBR sector
+        ;; by GRUB-BIOS-SETUP.
+        (copy-file boot-img "boot.img")
+
+        ;; Install both the "boot.img" and the "core.img" files on the given
+        ;; IMAGE. On boot, the MBR sector will execute the minimal Grub
+        ;; written in the MBR-GAP. Grub configuration and missing modules will
+        ;; be read from ROOT-DEVICE.
+        (invoke grub-bios-setup
+                "-m" device-map
+                "-r" root-device
+                "-d" "."
+                image))))
+
 (define install-grub-efi
   #~(lambda (bootloader efi-dir mount-point)
       ;; Install GRUB onto the EFI partition mounted at EFI-DIR, for the
@@ -465,6 +506,7 @@ fi~%"))))
    (name 'grub)
    (package grub)
    (installer install-grub)
+   (disk-image-installer install-grub-disk-image)
    (configuration-file "/boot/grub/grub.cfg")
    (configuration-file-generator grub-configuration-file)))
 
@@ -480,6 +522,7 @@ fi~%"))))
   (bootloader
    (inherit grub-bootloader)
    (installer install-grub-efi)
+   (disk-image-installer #f)
    (name 'grub-efi)
    (package grub-efi)))
 
diff --git a/gnu/system/image.scm b/gnu/system/image.scm
index a1214dd20a..ffc746fcf5 100644
--- a/gnu/system/image.scm
+++ b/gnu/system/image.scm
@@ -147,6 +147,19 @@
                        (guix build utils))
           gexp* ...))))
 
+(define (root-partition? partition)
+  "Return true if PARTITION is the root partition, false otherwise."
+  (member 'boot (partition-flags partition)))
+
+(define (find-root-partition image)
+  "Return the root partition of the given IMAGE."
+  (srfi-1:find root-partition? (image-partitions image)))
+
+(define (root-partition-index image)
+  "Return the index of the root partition of the given IMAGE."
+  (1+ (srfi-1:list-index identity
+                         (map root-partition? (image-partitions image)))))
+
 \f
 ;;
 ;; Disk image.
@@ -276,9 +289,17 @@ image ~a {
   (let* ((substitutable? (image-substitutable? image))
          (builder
           (with-imported-modules*
-           (let ((inputs '#+(list genimage coreutils findutils)))
+           (let ((inputs '#+(list genimage coreutils findutils))
+                 (bootloader-installer
+                  #+(bootloader-disk-image-installer bootloader)))
              (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
-             (genimage #$(image->genimage-cfg image) #$output))))
+             (genimage #$(image->genimage-cfg image) #$output)
+             ;; Install the bootloader directly on the disk-image.
+             (when bootloader-installer
+               (bootloader-installer
+                #+(bootloader-package bootloader)
+                #$(root-partition-index image)
+                (string-append #$output "/" #$genimage-name))))))
          (image-dir (computed-file "image-dir" builder)))
     (computed-file name
                    #~(symlink
@@ -371,14 +392,6 @@ used in the image. "
 ;; Image creation.
 ;;
 
-(define (root-partition? partition)
-  "Return true if PARTITION is the root partition, false otherwise."
-  (member 'boot (partition-flags partition)))
-
-(define (find-root-partition image)
-  "Return the root partition of the given IMAGE."
-  (srfi-1:find root-partition? (image-partitions image)))
-
 (define (image->root-file-system image)
   "Return the IMAGE root partition file-system type."
   (let ((format (image-format image)))
-- 
2.26.2