* 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(-)
Toggle diff (167 lines)
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)))))
+
;;
;; 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
