[bug#41560] [PATCH 0/8] image: Add MBR based boot support.

[bug#41560] [PATCH 0/8] image: Add MBR based boot support.

[Mathieu Othacehe]

Hello,

Until now, only Grub EFI bootloader was supported in (gnu system
image). Installing Grub EFI is as simple as copying a binary (created with
grub-mkstandalone) in a dedicated partition.

Now, for MBR based booting, one needs to run grub-install that does require
root permissions. To overcome this issue, I used a hack inspired from OpenWrt
and Buildroot.

As grub-install is in fact a wrapper around grub-mkimage and grub-bios-setup,
it is possible, with some plumbing and using those two tools, to install Grub
on a raw disk-image, without root permissions.

Thanks,

Mathieu

Mathieu Othacehe (8):
  bootloader: Add 'disk-image-installer'.
  bootloader: grub: Do not run grub-install when creating a disk-image.
  bootloader: grub: Use inheritance to define grub-minimal-bootloader.
  image: Add bootloader installation support.
  system: image: Correct genimage configuration file indentation.
  image: Use grub-efi to install the EFI bootloader.
  system: image: Fix image-with-os.
  image: Do not use VM to create disk-images.

 gnu/bootloader.scm      |   5 +-
 gnu/bootloader/grub.scm |  80 ++++++++++++++++++++++------
 gnu/build/image.scm     |   9 +++-
 gnu/ci.scm              |  20 +++----
 gnu/system/image.scm    | 113 ++++++++++++++++++----------------------
 gnu/tests/install.scm   |   8 +--
 guix/scripts/system.scm |  16 +++---
 guix/utils.scm          |   5 ++
 8 files changed, 155 insertions(+), 101 deletions(-)

-- 
2.26.2

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

[Mathieu Othacehe]

* 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

[bug#41560] [PATCH 2/8] bootloader: grub: Do not run grub-install when creating a disk-image.

[Mathieu Othacehe]

* gnu/bootloader/grub.scm (install-grub): When creating a disk-image,
grub-install will fail because it lacks root permissions. In that case, do not
run grub-install and only copy Grub modules to the /boot directory.
---
 gnu/bootloader/grub.scm | 26 ++++++++++++++++----------
 1 file changed, 16 insertions(+), 10 deletions(-)

diff --git a/gnu/bootloader/grub.scm b/gnu/bootloader/grub.scm
index 74dc00480f..29bec92196 100644
--- a/gnu/bootloader/grub.scm
+++ b/gnu/bootloader/grub.scm
@@ -423,18 +423,24 @@ fi~%"))))
 
 (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")
-
-        ;; Hide potentially confusing messages from the user, such as
-        ;; "Installing for i386-pc platform."
-        (invoke/quiet grub "--no-floppy" "--target=i386-pc"
-                      "--boot-directory" install-dir
-                      device))))
+        ;; Install GRUB on DEVICE which is mounted at MOUNT-POINT. If device
+        ;; is #f we are creating a disk-image.
+        (if device
+            (begin
+              ;; Tell 'grub-install' that there might be a LUKS-encrypted
+              ;; /boot or root partition.
+              (setenv "GRUB_ENABLE_CRYPTODISK" "y")
+
+              ;; Hide potentially confusing messages from the user, such as
+              ;; "Installing for i386-pc platform."
+              (invoke/quiet grub "--no-floppy" "--target=i386-pc"
+                            "--boot-directory" install-dir
+                            device))
+            ;; When creating a disk-image, only install Grub modules.
+            (copy-recursively (string-append bootloader "/lib/")
+                              install-dir)))))
 
 (define install-grub-disk-image
   #~(lambda (bootloader root-index image)
-- 
2.26.2

[bug#41560] [PATCH 3/8] bootloader: grub: Use inheritance to define grub-minimal-bootloader.

[Mathieu Othacehe]

* gnu/bootloader/grub.scm (grub-minimal-bootloader): Inherit from
grub-bootloader to avoid field redefinition.
---
 gnu/bootloader/grub.scm | 9 +++------
 1 file changed, 3 insertions(+), 6 deletions(-)

diff --git a/gnu/bootloader/grub.scm b/gnu/bootloader/grub.scm
index 29bec92196..388f29d3a8 100644
--- a/gnu/bootloader/grub.scm
+++ b/gnu/bootloader/grub.scm
@@ -516,13 +516,10 @@ fi~%"))))
    (configuration-file "/boot/grub/grub.cfg")
    (configuration-file-generator grub-configuration-file)))
 
-(define grub-minimal-bootloader
+(define* grub-minimal-bootloader
   (bootloader
-   (name 'grub)
-   (package grub-minimal)
-   (installer install-grub)
-   (configuration-file "/boot/grub/grub.cfg")
-   (configuration-file-generator grub-configuration-file)))
+   (inherit grub-bootloader)
+   (package grub-minimal)))
 
 (define* grub-efi-bootloader
   (bootloader
-- 
2.26.2

[bug#41560] [PATCH 4/8] image: Add bootloader installation support.

[Mathieu Othacehe]

* gnu/build/image.scm (initialize-root-partition): Add bootloader-package and
bootloader-installer arguments. Run the bootloader-installer if defined.
* gnu/system/image.scm (system-disk-image): Adapt the partition initializer
call accordingly.
---
 gnu/build/image.scm  | 5 +++++
 gnu/system/image.scm | 4 +++-
 2 files changed, 8 insertions(+), 1 deletion(-)

diff --git a/gnu/build/image.scm b/gnu/build/image.scm
index b37ea9332a..49faeab466 100644
--- a/gnu/build/image.scm
+++ b/gnu/build/image.scm
@@ -155,6 +155,8 @@ deduplicates files common to CLOSURE and the rest of PREFIX."
                                     #:key
                                     bootcfg
                                     bootcfg-location
+                                    bootloader-package
+                                    bootloader-installer
                                     (deduplicate? #t)
                                     references-graphs
                                     (register-closures? #t)
@@ -178,6 +180,9 @@ of the directory of the 'system' derivation."
                                   #:deduplicate? deduplicate?))
               references-graphs))
 
+  (when bootloader-installer
+    (display "installing bootloader...\n")
+    (bootloader-installer bootloader-package #f root))
   (when bootcfg
     (install-boot-config bootcfg bootcfg-location root)))
 
diff --git a/gnu/system/image.scm b/gnu/system/image.scm
index ffc746fcf5..6608991fdc 100644
--- a/gnu/system/image.scm
+++ b/gnu/system/image.scm
@@ -236,7 +236,9 @@ used in the image."
                               #:deduplicate? #f
                               #:system-directory #$os
                               #:bootloader-package
-                              #$(bootloader-package bootloader)
+                              #+(bootloader-package bootloader)
+                              #:bootloader-installer
+                              #+(bootloader-installer bootloader)
                               #:bootcfg #$bootcfg
                               #:bootcfg-location
                               #$(bootloader-configuration-file bootloader)))))
-- 
2.26.2

[bug#41560] [PATCH 5/8] system: image: Correct genimage configuration file indentation.

[Mathieu Othacehe]

* gnu/system/image.scm (system-disk-image): Fix genimage configuration file
indentation.
---
 gnu/system/image.scm | 8 ++++----
 1 file changed, 4 insertions(+), 4 deletions(-)

diff --git a/gnu/system/image.scm b/gnu/system/image.scm
index 6608991fdc..7ac998d861 100644
--- a/gnu/system/image.scm
+++ b/gnu/system/image.scm
@@ -262,10 +262,10 @@ used in the image."
             (image (partition-image partition))
             (offset (partition-offset partition)))
         #~(format #f "~/partition ~a {
-                                      ~/~/partition-type = ~a
-                                      ~/~/image = \"~a\"
-                                      ~/~/offset = \"~a\"
-                                      ~/}"
+~/~/partition-type = ~a
+~/~/image = \"~a\"
+~/~/offset = \"~a\"
+~/}"
                   #$label
                   #$dos-type
                   #$image
-- 
2.26.2

[bug#41560] [PATCH 6/8] image: Use grub-efi to install the EFI bootloader.

[Mathieu Othacehe]

* guix/utils.scm (target-intel?): New exported procedure.
* gnu/build/image.scm (initialize-efi-partition): Rename bootloader-package
argument to grub-efi.
* gnu/system/image.scm (system-disk-image): Adapt accordingly to pass
grub-efi package. Make sure that grub-efi is not built if we are not targeting
an Intel system.
---
 gnu/build/image.scm  | 4 ++--
 gnu/system/image.scm | 4 ++++
 guix/utils.scm       | 5 +++++
 3 files changed, 11 insertions(+), 2 deletions(-)

diff --git a/gnu/build/image.scm b/gnu/build/image.scm
index 49faeab466..a8594e202b 100644
--- a/gnu/build/image.scm
+++ b/gnu/build/image.scm
@@ -146,10 +146,10 @@ deduplicates files common to CLOSURE and the rest of PREFIX."
 
 (define* (initialize-efi-partition root
                                    #:key
-                                   bootloader-package
+                                   grub-efi
                                    #:allow-other-keys)
   "Install in ROOT directory, an EFI loader using BOOTLOADER-PACKAGE."
-  (install-efi-loader bootloader-package root))
+  (install-efi-loader grub-efi root))
 
 (define* (initialize-root-partition root
                                     #:key
diff --git a/gnu/system/image.scm b/gnu/system/image.scm
index 7ac998d861..a706f872a8 100644
--- a/gnu/system/image.scm
+++ b/gnu/system/image.scm
@@ -235,6 +235,10 @@ used in the image."
                               #:references-graphs '#$graph
                               #:deduplicate? #f
                               #:system-directory #$os
+                              #:grub-efi #$(let-system (system target)
+                                             (and (target-intel?
+                                                   (or target system))
+                                                  grub-efi))
                               #:bootloader-package
                               #+(bootloader-package bootloader)
                               #:bootloader-installer
diff --git a/guix/utils.scm b/guix/utils.scm
index d7b197fa44..fb3b233286 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -74,6 +74,7 @@
             %current-target-system
             package-name->name+version
             target-mingw?
+            target-intel?
             target-arm32?
             target-aarch64?
             target-arm?
@@ -490,6 +491,10 @@ a character other than '@'."
   (and target
        (string-suffix? "-mingw32" target)))
 
+(define* (target-intel? #:optional (target (or (%current-target-system)
+                                               (%current-system))))
+  (any (cut string-prefix? <> target) '("x86_64" "i686")))
+
 (define* (target-arm32? #:optional (target (or (%current-target-system)
                                                (%current-system))))
   (string-prefix? "arm" target))
-- 
2.26.2

[bug#41560] [PATCH 7/8] system: image: Fix image-with-os.

[Mathieu Othacehe]

* gnu/system/image.scm (image-with-os): Do not reorder partitions, as we want
them to be created according to definition order.
---
 gnu/system/image.scm | 24 ++++++++++++------------
 1 file changed, 12 insertions(+), 12 deletions(-)

diff --git a/gnu/system/image.scm b/gnu/system/image.scm
index a706f872a8..97124a4699 100644
--- a/gnu/system/image.scm
+++ b/gnu/system/image.scm
@@ -424,18 +424,18 @@ to OS.  Also set the UUID and the size of the root partition."
        (string=? (file-system-mount-point fs) "/"))
      (operating-system-file-systems os)))
 
-  (let*-values (((partitions) (image-partitions base-image))
-                ((root-partition other-partitions)
-                 (srfi-1:partition root-partition? partitions)))
-    (image
-     (inherit base-image)
-     (operating-system os)
-     (partitions
-      (cons (partition
-             (inherit (car root-partition))
-             (uuid (file-system-device root-file-system))
-             (size (root-size base-image)))
-            other-partitions)))))
+  (image
+   (inherit base-image)
+   (operating-system os)
+   (partitions
+    (map (lambda (p)
+           (if (root-partition? p)
+               (partition
+                (inherit p)
+                (uuid (file-system-device root-file-system))
+                (size (root-size base-image)))
+               p))
+         (image-partitions base-image)))))
 
 (define (operating-system-for-image image)
   "Return an operating-system based on the one specified in IMAGE, but
-- 
2.26.2

[bug#41560] [PATCH 8/8] image: Do not use VM to create disk-images.

[Mathieu Othacehe]

Now that installing Grub on raw disk-images is supported, we do not need to
rely on (gnu system vm) module.

* gnu/system/image.scm (make-system-image): Rename to ...
(system-image): ... this, and remove the compatibility wrapper.
(find-image): Turn to a monadic procedure. This will become useful when
introducing Hurd support, to be able to detect the target system.
* gnu/ci.scm (qemu-jobs): Use lower-object now that system-image returns a
file-like object.
* gnu/tests/install.scm (run-install): Ditto.
* guix/scripts/system.scm (system-derivation-for-action): Add a 'base-image'
argument,
(perform-action): adapt accordingly.
---
 gnu/ci.scm              | 20 +++++++++++---------
 gnu/system/image.scm    | 40 ++++++----------------------------------
 gnu/tests/install.scm   |  8 ++++----
 guix/scripts/system.scm | 16 +++++++++-------
 4 files changed, 30 insertions(+), 54 deletions(-)

diff --git a/gnu/ci.scm b/gnu/ci.scm
index b61181be51..fa67168e22 100644
--- a/gnu/ci.scm
+++ b/gnu/ci.scm
@@ -219,19 +219,21 @@ system.")
                    (run-with-store store
                      (mbegin %store-monad
                        (set-guile-for-build (default-guile))
-                       (system-image
-                        (image
-                         (inherit efi-disk-image)
-                         (size (* 1500 MiB))
-                         (operating-system installation-os))))))
+                       (lower-object
+                        (system-image
+                         (image
+                          (inherit efi-disk-image)
+                          (size (* 1500 MiB))
+                          (operating-system installation-os)))))))
             (->job 'iso9660-image
                    (run-with-store store
                      (mbegin %store-monad
                        (set-guile-for-build (default-guile))
-                       (system-image
-                        (image
-                         (inherit iso9660-image)
-                         (operating-system installation-os)))))))
+                       (lower-object
+                        (system-image
+                         (image
+                          (inherit iso9660-image)
+                          (operating-system installation-os))))))))
       '()))
 
 (define channel-build-system
diff --git a/gnu/system/image.scm b/gnu/system/image.scm
index 97124a4699..8bb8412f16 100644
--- a/gnu/system/image.scm
+++ b/gnu/system/image.scm
@@ -488,7 +488,7 @@ it can be used for bootloading."
                             (type root-file-system-type))
                           file-systems-to-keep)))))
 
-(define* (make-system-image image)
+(define* (system-image image)
   "Return the derivation of IMAGE.  It can be a raw disk-image or an ISO9660
 image, depending on IMAGE format."
   (define substitutable? (image-substitutable? image))
@@ -521,38 +521,10 @@ image, depending on IMAGE format."
   "Find and return an image that could match the given FILE-SYSTEM-TYPE.  This
 is useful to adapt to interfaces written before the addition of the <image>
 record."
-  ;; XXX: Add support for system and target here, or in the caller.
-  (match file-system-type
-    ("iso9660" iso9660-image)
-    (_ efi-disk-image)))
-
-(define (system-image image)
-  "Wrap 'make-system-image' call, so that it is used only if the given IMAGE
-is supported.  Otherwise, fallback to image creation in a VM.  This is
-temporary and should be removed once 'make-system-image' is able to deal with
-all types of images."
-  (define substitutable? (image-substitutable? image))
-  (define volatile-root? (image-volatile-root? image))
-
-  (let* ((image-os (image-operating-system image))
-         (image-root-filesystem-type (image->root-file-system image))
-         (bootloader (bootloader-configuration-bootloader
-                      (operating-system-bootloader image-os)))
-         (bootloader-name (bootloader-name bootloader))
-         (size (image-size image))
-         (format (image-format image)))
-    (mbegin %store-monad
-      (if (and (or (eq? bootloader-name 'grub)
-                   (eq? bootloader-name 'extlinux))
-               (eq? format 'disk-image))
-          ;; Fallback to image creation in a VM when it is not yet supported
-          ;; by this module.
-          (system-disk-image-in-vm image-os
-                                   #:disk-image-size size
-                                   #:file-system-type image-root-filesystem-type
-                                   #:volatile? volatile-root?
-                                   #:substitutable? substitutable?)
-          (lower-object
-           (make-system-image image))))))
+  (mbegin %store-monad
+    (return
+     (match file-system-type
+       ("iso9660" iso9660-image)
+       (_ efi-disk-image)))))
 
 ;;; image.scm ends here
diff --git a/gnu/tests/install.scm b/gnu/tests/install.scm
index cea26c8ef3..6bd8c7d3d2 100644
--- a/gnu/tests/install.scm
+++ b/gnu/tests/install.scm
@@ -228,18 +228,18 @@ packages defined in installation-os."
   (mlet* %store-monad ((_      (set-grafting #f))
                        (system (current-system))
                        (target (operating-system-derivation target-os))
+                       (base-image (find-image
+                                    installation-disk-image-file-system-type))
 
                        ;; Since the installation system has no network access,
                        ;; we cheat a little bit by adding TARGET to its GC
                        ;; roots.  This way, we know 'guix system init' will
                        ;; succeed.  Also add guile-final, which is pulled in
                        ;; through provenance.drv and may not always be present.
-                       (image
+                       (image ->
                         (system-image
                          (image
-                          (inherit
-                           (find-image
-                            installation-disk-image-file-system-type))
+                          (inherit base-image)
                           (size install-size)
                           (operating-system
                             (operating-system-with-gc-roots
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 3efd113ac8..3d7aa77cb7 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -670,7 +670,7 @@ checking this by themselves in their 'check' procedure."
 ;;; Action.
 ;;;
 
-(define* (system-derivation-for-action os action
+(define* (system-derivation-for-action os base-image action
                                        #:key image-size file-system-type
                                        full-boot? container-shared-network?
                                        mappings)
@@ -694,11 +694,12 @@ checking this by themselves in their 'check' procedure."
                                                 (* 70 (expt 2 20)))
                                             #:mappings mappings))
     ((disk-image)
-     (system-image
-      (image
-       (inherit (find-image file-system-type))
-       (size image-size)
-       (operating-system os))))
+     (lower-object
+      (system-image
+       (image
+        (inherit base-image)
+        (size image-size)
+        (operating-system os)))))
     ((docker-image)
      (system-docker-image os #:shared-network? container-shared-network?))))
 
@@ -800,7 +801,8 @@ static checks."
       (check-initrd-modules os)))
 
   (mlet* %store-monad
-      ((sys       (system-derivation-for-action os action
+      ((image     (find-image file-system-type))
+       (sys       (system-derivation-for-action os image action
                                                 #:file-system-type file-system-type
                                                 #:image-size image-size
                                                 #:full-boot? full-boot?
-- 
2.26.2

[bug#41560] [PATCH 0/8] image: Add MBR based boot support.

[Jan Nieuwenhuizen]

Mathieu Othacehe writes:

Hello Mathieu,

> Until now, only Grub EFI bootloader was supported in (gnu system
> image). Installing Grub EFI is as simple as copying a binary (created with
> grub-mkstandalone) in a dedicated partition.
>
> Now, for MBR based booting, one needs to run grub-install that does require
> root permissions. To overcome this issue, I used a hack inspired from OpenWrt
> and Buildroot.
>
> As grub-install is in fact a wrapper around grub-mkimage and grub-bios-setup,
> it is possible, with some plumbing and using those two tools, to install Grub
> on a raw disk-image, without root permissions.

Thanks for your amazing piece of work on disk-image; for me this means
adding GNU/Hurd support much sooner than I could hope for!

What can I say, not only LGTM, but also WFM (on a soon-to-be-reset
wip-hurd-vm).

Greetings,
Janneke

-- 
Jan Nieuwenhuizen <janneke@gnu.org> | GNU LilyPond http://lilypond.org
Freelance IT http://JoyofSource.com | Avatar® http://AvatarAcademy.com

[bug#41560] [PATCH 0/8] image: Add MBR based boot support.

[Ludovic Courtès]

Hi,

Mathieu Othacehe <m.othacehe@gmail.com> skribis:

> Until now, only Grub EFI bootloader was supported in (gnu system
> image). Installing Grub EFI is as simple as copying a binary (created with
> grub-mkstandalone) in a dedicated partition.
>
> Now, for MBR based booting, one needs to run grub-install that does require
> root permissions. To overcome this issue, I used a hack inspired from OpenWrt
> and Buildroot.
>
> As grub-install is in fact a wrapper around grub-mkimage and grub-bios-setup,
> it is possible, with some plumbing and using those two tools, to install Grub
> on a raw disk-image, without root permissions.

Amazing!  This is really cool, thank you!

Looking in more detail at the rest now…

Ludo’.

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

[Ludovic Courtès]

Mathieu Othacehe <m.othacehe@gmail.com> skribis:

> * 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.

[...]

> +  (disk-image-installer            bootloader-disk-image-installer
> +                                   (default #f))

My only concern here is that we’re making an interface that’s only
implemented by one bootloader, and I fear bitrot of the other
bootloaders longer term.  I guess we’ll see, this concern shouldn’t
block progress.

> +(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)

Very smart.  s/Grub/GRUB/ everywhere please. :-)

> +(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)))))

Isn’t it just (list-index root-partition (image-partitions image))?

Otherwise LGTM!

[bug#41560] [PATCH 2/8] bootloader: grub: Do not run grub-install when creating a disk-image.

[Ludovic Courtès]

Mathieu Othacehe <m.othacehe@gmail.com> skribis:

> * gnu/bootloader/grub.scm (install-grub): When creating a disk-image,
> grub-install will fail because it lacks root permissions. In that case, do not
> run grub-install and only copy Grub modules to the /boot directory.

[...]

> +        ;; Install GRUB on DEVICE which is mounted at MOUNT-POINT. If device
                                                                         ^
DEVICE

> +        ;; is #f we are creating a disk-image.

Maybe:

  … is #f, then populate the disk image rooted at MOUNT-POINT.

[bug#41560] [PATCH 6/8] image: Use grub-efi to install the EFI bootloader.

[Ludovic Courtès]

Mathieu Othacehe <m.othacehe@gmail.com> skribis:

> * guix/utils.scm (target-intel?): New exported procedure.
> * gnu/build/image.scm (initialize-efi-partition): Rename bootloader-package
> argument to grub-efi.
> * gnu/system/image.scm (system-disk-image): Adapt accordingly to pass
> grub-efi package. Make sure that grub-efi is not built if we are not targeting
> an Intel system.

[...]

> +++ b/gnu/build/image.scm
> @@ -146,10 +146,10 @@ deduplicates files common to CLOSURE and the rest of PREFIX."
>  
>  (define* (initialize-efi-partition root
>                                     #:key
> -                                   bootloader-package
> +                                   grub-efi
>                                     #:allow-other-keys)
>    "Install in ROOT directory, an EFI loader using BOOTLOADER-PACKAGE."
> -  (install-efi-loader bootloader-package root))
> +  (install-efi-loader grub-efi root))

Does it have to be GRUB?

> +++ b/gnu/system/image.scm
> @@ -235,6 +235,10 @@ used in the image."
>                                #:references-graphs '#$graph
>                                #:deduplicate? #f
>                                #:system-directory #$os
> +                              #:grub-efi #$(let-system (system target)
> +                                             (and (target-intel?
> +                                                   (or target system))
> +                                                  grub-efi))

Some AArch64 systems such as the SoftIron OverDrive 1000 use EFI too.
So I don’t think the above is correct.

> +(define* (target-intel? #:optional (target (or (%current-target-system)
> +                                               (%current-system))))
> +  (any (cut string-prefix? <> target) '("x86_64" "i686")))

Shouldn’t it include i[345]6 as well?

Also, I think no 32-bit Intel systems use EFI.

Actually, why do we need to guess, can’t we just use the bootloader
specified in the <operating-system> record?  (Naïve question, I haven’t
checked…)

[bug#41560] [PATCH 8/8] image: Do not use VM to create disk-images.

[Ludovic Courtès]

Mathieu Othacehe <m.othacehe@gmail.com> skribis:

> Now that installing Grub on raw disk-images is supported, we do not need to
> rely on (gnu system vm) module.
>
> * gnu/system/image.scm (make-system-image): Rename to ...
> (system-image): ... this, and remove the compatibility wrapper.
> (find-image): Turn to a monadic procedure. This will become useful when
> introducing Hurd support, to be able to detect the target system.
> * gnu/ci.scm (qemu-jobs): Use lower-object now that system-image returns a
> file-like object.
> * gnu/tests/install.scm (run-install): Ditto.
> * guix/scripts/system.scm (system-derivation-for-action): Add a 'base-image'
> argument,
> (perform-action): adapt accordingly.

Yay!  \o/

Thank you,
Ludo’.

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

[Mathieu Othacehe]

Hey Ludo!

Thanks for the review :)

>> +  (disk-image-installer            bootloader-disk-image-installer
>> +                                   (default #f))
>
> My only concern here is that we’re making an interface that’s only
> implemented by one bootloader, and I fear bitrot of the other
> bootloaders longer term.  I guess we’ll see, this concern shouldn’t
> block progress.

I plan to implement it for extlinux and u-boot soon, so we should be
fine.

> Very smart.  s/Grub/GRUB/ everywhere please. :-)

Yes, thank you :)

>
>> +(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)))))
>
> Isn’t it just (list-index root-partition (image-partitions image))?

Of course!

Mathieu

[bug#41560] [PATCH 6/8] image: Use grub-efi to install the EFI bootloader.

[Mathieu Othacehe]

>>    "Install in ROOT directory, an EFI loader using BOOTLOADER-PACKAGE."
>> -  (install-efi-loader bootloader-package root))
>> +  (install-efi-loader grub-efi root))
>
> Does it have to be GRUB?

No any EFI compatible bootloader would do the trick. However, for now
"install-efi-loader" calls "grub-mkstandalone", so maybe we can keep it
that way for now?

>
>> +++ b/gnu/system/image.scm
>> @@ -235,6 +235,10 @@ used in the image."
>>                                #:references-graphs '#$graph
>>                                #:deduplicate? #f
>>                                #:system-directory #$os
>> +                              #:grub-efi #$(let-system (system target)
>> +                                             (and (target-intel?
>> +                                                   (or target system))
>> +                                                  grub-efi))
>
> Some AArch64 systems such as the SoftIron OverDrive 1000 use EFI too.
> So I don’t think the above is correct.

Yes you're correct. Actually, I think that I was overthinking this
thing. Using "#+grub-efi" should work.

>
>> +(define* (target-intel? #:optional (target (or (%current-target-system)
>> +                                               (%current-system))))
>> +  (any (cut string-prefix? <> target) '("x86_64" "i686")))
>
> Shouldn’t it include i[345]6 as well?

So I removed this bit.

>
> Also, I think no 32-bit Intel systems use EFI.
>
> Actually, why do we need to guess, can’t we just use the bootloader
> specified in the <operating-system> record?  (Naïve question, I haven’t
> checked…)

If we take the example of "installation-os", we use "grub-bootloader",
but we expect this image to be EFI ready. That's why "grub-efi" usage is
forced here.

As this is already the case without this serie, I think we can
proceed.

Thanks,

Mathieu

bug#41560: [PATCH 8/8] image: Do not use VM to create disk-images.

[Mathieu Othacehe]

Just pushed the serie, taking your remarks into account.

Thanks again for reviewing!

Mathieu

> Mathieu Othacehe <m.othacehe@gmail.com> skribis:
>
>> Now that installing Grub on raw disk-images is supported, we do not need to
>> rely on (gnu system vm) module.
>>
>> * gnu/system/image.scm (make-system-image): Rename to ...
>> (system-image): ... this, and remove the compatibility wrapper.
>> (find-image): Turn to a monadic procedure. This will become useful when
>> introducing Hurd support, to be able to detect the target system.
>> * gnu/ci.scm (qemu-jobs): Use lower-object now that system-image returns a
>> file-like object.
>> * gnu/tests/install.scm (run-install): Ditto.
>> * guix/scripts/system.scm (system-derivation-for-action): Add a 'base-image'
>> argument,
>> (perform-action): adapt accordingly.
>
> Yay!  \o/
>
> Thank you,
> Ludo’.

[bug#41560] [PATCH 8/8] image: Do not use VM to create disk-images.

[Jan Nieuwenhuizen]

Mathieu Othacehe writes:

> Just pushed the serie, taking your remarks into account.
>
> Thanks again for reviewing!

\o/

-- 
Jan Nieuwenhuizen <janneke@gnu.org> | GNU LilyPond http://lilypond.org
Freelance IT http://JoyofSource.com | Avatar® http://AvatarAcademy.com