From 7feefb3b82186be382725ac2d6b7e9f8953e4a83 Mon Sep 17 00:00:00 2001
From: Mathieu Othacehe <othacehe@gnu.org>
Date: Sat, 23 May 2020 19:09:14 +0200
Subject: bootloader: Add 'disk-image-installer'.

* 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/system/image.scm | 32 ++++++++++++++++++++++----------
 1 file changed, 22 insertions(+), 10 deletions(-)

(limited to 'gnu/system')

diff --git a/gnu/system/image.scm b/gnu/system/image.scm
index a1214dd20a..92b3f4424e 100644
--- a/gnu/system/image.scm
+++ b/gnu/system/image.scm
@@ -147,6 +147,18 @@
                        (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 root-partition? (image-partitions image))))
+
 
 ;;
 ;; Disk image.
@@ -276,9 +288,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 +391,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)))
-- 
cgit v1.2.3