[bug#73202] [PATCH v2 12/15] gnu: bootloader: Install any bootloader to ESP.

[Herman Rimm via Guix-patches via <guix-patches@gnu.org>]

From: Lilah Tascheter <lilah@lunabee.space>

* gnu/bootloader.scm (efi-arch, install-efi): New procedures.
(%efi-supported-systems, lazy-efibootmgr): New variables.
(bootloader-configuration)[efi-removable?, 32bit?]: New fields.
(match-bootloader-configuration, match-menu-entry): New macros.
* gnu/build/bootloader.scm (install-efi-loader): Delete procedure.
(install-efi): Rewrite to support installation of any efi bootloader.
* gnu/build/image.scm (initialize-efi32-partition): Deprecate.
(initialize-efi-partitition): Only create EFI directory.
* gnu/image.scm (partition)[target]: New field in order to support
dynamic provision of image partitions as bootloader targets.
* gnu/system/image.scm (root-partition, esp-partition): Use target
field.
* gnu/system/image.scm (esp32-partition, efi32-disk-partition,
efi32-raw-image-type): Deprecate.
* doc/guix.texi (Creating System Images)[image Reference]<partition
Reference>: Add target field.
[Instantiate an Image]: Update examples and update formatting.
<efi32-disk-image, efi32-raw-image-type>: Delete.
<pinebook-pro-image-type, rock64-image-type>: Reword slightly.

Change-Id: I3654d160f7306bb45a78b82ea6b249ff4281f739
---
 doc/guix.texi            |  34 ++++++------
 gnu/bootloader.scm       |  56 ++++++++++++++++++-
 gnu/build/bootloader.scm | 115 ++++++++++++++++++++-------------------
 gnu/build/image.scm      |  23 ++------
 gnu/image.scm            |   4 ++
 gnu/system/image.scm     |  22 +++-----
 6 files changed, 150 insertions(+), 104 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index f7fb4b4cc3..eb24ab9798 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -130,6 +130,7 @@
 Copyright @copyright{} 2024 Dariqq@*
 Copyright @copyright{} 2024 Denis 'GNUtoo' Carikli@*
 Copyright @copyright{} 2024 Fabio Natali@*
+Copyright @copyright{} 2024 Lilah Tascheter@*
 
 Permission is granted to copy, distribute and/or modify this document
 under the terms of the GNU Free Documentation License, Version 1.3 or
@@ -47950,6 +47951,12 @@ partition Reference
 this flag set, usually the root one. The @code{'esp} flag identifies a
 UEFI System Partition.
 
+@item @code{target} (default: @var{#f})
+If provided, this partition provides itself as a bootloader target
+(@pxref{Bootloader Configuration}).  Most commonly, this is used to provide the
+@code{'root} and @code{'esp} targets, with the root partition and EFI System
+Partition, respectively, though this can provide any target necessary.
+
 @item @code{initializer} (default: @code{#false})
 The partition initializer procedure as a gexp.  This procedure is called
 to populate a partition.  If no initializer is passed, the
@@ -47998,6 +48005,7 @@ Instantiate an Image
     (label "GNU-ESP")
     (file-system "vfat")
     (flags '(esp))
+    (target 'esp)
     (initializer (gexp initialize-efi-partition)))
    (partition
     (size (* 50 MiB))
@@ -48014,15 +48022,17 @@ Instantiate an Image
     (label root-label)
     (file-system "ext4")
     (flags '(boot))
+    (target 'root)
     (initializer (gexp initialize-root-partition))))))
 @end lisp
 
-Note that the first and third partitions use generic initializers
-procedures, initialize-efi-partition and initialize-root-partition
-respectively.  The initialize-efi-partition installs a GRUB EFI loader
-that is loading the GRUB bootloader located in the root partition.  The
-initialize-root-partition instantiates a complete system as defined by
-the @code{%simple-os} operating-system.
+Note that the first and third partitions use generic initializer
+procedures, @code{initialize-efi-partition} and
+@code{initialize-root-partition} respectively.
+@code{initialize-efi-partition} simply creates the directory structure
+for an EFI bootloader to install itself to.
+@code{initialize-root-partition} instantiates a complete system as
+defined by the @code{%simple-os} operating-system.
 
 You can now run:
 
@@ -48079,10 +48089,6 @@ Instantiate an Image
 @code{i686} machines, supporting BIOS or UEFI booting.
 @end defvar
 
-@defvar efi32-disk-image
-Same as @code{efi-disk-image} but with a 32 bits EFI partition.
-@end defvar
-
 @defvar iso9660-image
 An ISO-9660 image composed of a single bootable partition.  This image
 can also be used on most @code{x86_64} and @code{i686} machines.
@@ -48173,10 +48179,6 @@ image-type Reference
 Build an image based on the @code{efi-disk-image} image.
 @end defvar
 
-@defvar efi32-raw-image-type
-Build an image based on the @code{efi32-disk-image} image.
-@end defvar
-
 @defvar qcow2-image-type
 Build an image based on the @code{mbr-disk-image} image but with the
 @code{compressed-qcow2} image format.
@@ -48204,14 +48206,14 @@ image-type Reference
 @defvar pinebook-pro-image-type
 Build an image that is targeting the Pinebook Pro machine.  The MBR
 image contains a single partition starting at a @code{9MiB} offset.  The
-@code{u-boot-pinebook-pro-rk3399-bootloader} bootloader will be
+@code{u-boot-pinebook-pro-rk3399-bootloader} bootloader can be
 installed in this gap.
 @end defvar
 
 @defvar rock64-image-type
 Build an image that is targeting the Rock64 machine.  The MBR image
 contains a single partition starting at a @code{16MiB} offset.  The
-@code{u-boot-rock64-rk3328-bootloader} bootloader will be installed in
+@code{u-boot-rock64-rk3328-bootloader} bootloader can be installed in
 this gap.
 @end defvar
 
diff --git a/gnu/bootloader.scm b/gnu/bootloader.scm
index f1352122a9..6b08e61492 100644
--- a/gnu/bootloader.scm
+++ b/gnu/bootloader.scm
@@ -100,6 +100,8 @@ (define-module (gnu bootloader)
             bootloader-configuration-targets
             bootloader-configuration-menu-entries
             bootloader-configuration-default-entry
+            bootloader-configuration-efi-removable?
+            bootloader-configuration-32bit?
             bootloader-configuration-timeout
             bootloader-configuration-keyboard-layout
             bootloader-configuration-theme
@@ -113,6 +115,9 @@ (define-module (gnu bootloader)
             bootloader-configuration->gexp
             bootloader-configurations->gexp
 
+            %efi-supported-systems
+            efi-arch
+            install-efi
             efi-bootloader-chain))
 
 \f
@@ -502,6 +507,10 @@ (define-record-type* <bootloader-configuration>
                          (default '()))   ;list of <menu-entry>
   (default-entry         bootloader-configuration-default-entry
                          (default 0))     ;integer
+  (efi-removable?        bootloader-configuration-efi-removable?
+                         (default #f))    ;bool
+  (32bit?                bootloader-configuration-32bit?
+                         (default #f))    ;bool
   (timeout               bootloader-configuration-timeout
                          (default 5))     ;seconds as integer
   (keyboard-layout       bootloader-configuration-keyboard-layout
@@ -635,9 +644,54 @@ (define (bootloader-configurations->gexp bootloader-configs . rest)
 
 \f
 ;;;
-;;; Bootloaders.
+;;; Bootloader installation to ESP.
 ;;;
 
+;; systems currently supported by efi-arch. should be used for packages relying
+;; on it.
+(define %efi-supported-systems
+  '("i686-linux" "x86_64-linux" "armhf-linux" "aarch64-linux" "riscv64-linux"))
+
+(define* (efi-arch #:key (target (or (%current-target-system) (%current-system)))
+                         (32? #f))
+  "Returns the UEFI architecture name for the current target, in lowercase."
+  (cond ((target-x86-32? target)  "ia32")
+        ((target-x86-64? target)  (if 32? "ia32" "x64"))
+        ((target-arm32? target)   "arm")
+        ((target-aarch64? target) (if 32? "arm" "aa64"))
+        ((target-riscv64? target) (if 32? "riscv32" "riscv64"))
+        (else (raise (formatted-message (G_ "no UEFI standard arch for ~a!")
+                                        target)))))
+
+(define (lazy-efibootmgr)
+  "Lazy-loaded efibootmgr package, in order to prevent circular refs."
+  (module-ref (resolve-interface '(gnu packages linux)) 'efibootmgr))
+
+(define (install-efi bootloader-config plan)
+  "Returns a gexp installing PLAN to the ESP, as denoted by the 'vendir target.
+PLAN is a gexp of a list of '(BUILDER DEST-BASENAME . LABEL) triples, that
+should be in boot order.  If the user selects a removable bootloader, only the
+first entry in PLAN is used."
+  (match-record bootloader-config <bootloader-configuration>
+    (targets efi-removable? 32bit?)
+    (if efi-removable?
+      ;; Hard code the output location to a well-known path recognized by
+      ;; compliant firmware.  See "3.5.1.1 Removable Media Boot Behaviour":
+      ;; http://www.uefi.org/sites/default/files/resources/UEFI%20Spec%202_6.pdf
+      (with-targets targets
+        (('esp => (path :path))
+         #~(let ((boot #$(string-append path "/EFI/BOOT"))
+                 (arch #$(string-upcase (efi-arch #:32? 32bit?)))
+                 (builder (car (car #$plan))))
+             (mkdir-p boot)
+             ;; Only realize the first planspec.
+             (builder (string-append boot "/BOOT" arch ".EFI")))))
+      ;; Install normally if not configured as removable.
+      (with-targets targets
+        (('vendir => (vendir :path) (loader :devpath) (disk :device))
+         #~(install-efi #+(file-append (lazy-efibootmgr) "/sbin/efibootmgr")
+                        #$vendir #$loader #$disk #$plan))))))
+
 (define (efi-bootloader-profile packages files hooks)
   "Creates a profile from the lists of PACKAGES and FILES from the store.
 This profile is meant to be used by the bootloader-installer.
diff --git a/gnu/build/bootloader.scm b/gnu/build/bootloader.scm
index 3934e03aee..064466bd33 100644
--- a/gnu/build/bootloader.scm
+++ b/gnu/build/bootloader.scm
@@ -23,8 +23,6 @@
 (define-module (gnu build bootloader)
   #:autoload   (guix build syscalls) (free-disk-space)
   #:use-module (guix build utils)
-  #:use-module (guix utils)
-  #:use-module (ice-9 binary-ports)
   #:use-module (guix diagnostics)
   #:use-module (guix i18n)
   #:use-module (ice-9 format)
@@ -40,7 +38,7 @@ (define-module (gnu build bootloader)
   #:export (atomic-copy
             in-temporary-directory
             write-file-on-device
-            install-efi-loader))
+            install-efi))
 
 \f
 ;;;
@@ -102,57 +100,62 @@ (define (efi-bootnums efibootmgr)
                            (bootnum (match:substring match 1)))
                       (cons (cons path bootnum) acc))))))
 
-(define* (install-efi grub grub-config esp #:key targets)
-  "Write a self-contained GRUB EFI loader to the mounted ESP using
-GRUB-CONFIG.
-
-If TARGETS is set, use its car as the GRUB image format and its cdr as
-the output filename.  Otherwise, use defaults for the host platform."
-  (let* ((system %host-type)
-         ;; Hard code the output location to a well-known path recognized by
-         ;; compliant firmware. See "3.5.1.1 Removable Media Boot Behaviour":
-         ;; http://www.uefi.org/sites/default/files/resources/UEFI%20Spec%202_6.pdf
-         (grub-mkstandalone (string-append grub "/bin/grub-mkstandalone"))
-         (efi-directory (string-append esp "/EFI/BOOT"))
-         ;; Map grub target names to boot file names.
-         (efi-targets (or targets
-                          (cond ((string-prefix? "x86_64" system)
-                                 '("x86_64-efi" . "BOOTX64.EFI"))
-                                ((string-prefix? "i686" system)
-                                 '("i386-efi" . "BOOTIA32.EFI"))
-                                ((string-prefix? "armhf" system)
-                                 '("arm-efi" . "BOOTARM.EFI"))
-                                ((string-prefix? "aarch64" system)
-                                 '("arm64-efi" . "BOOTAA64.EFI"))))))
-    ;; grub-mkstandalone requires a TMPDIR to prepare the firmware image.
-    (setenv "TMPDIR" esp)
-
-    (mkdir-p efi-directory)
-    (invoke grub-mkstandalone "-O" (car efi-targets)
-            "-o" (string-append efi-directory "/"
-                                (cdr efi-targets))
-            ;; Graft the configuration file onto the image.
-            (string-append "boot/grub/grub.cfg=" grub-config))))
-
-(define* (install-efi-loader grub-efi esp #:key targets)
-  "Install in ESP directory the given GRUB-EFI bootloader.  Configure it to
-load the Grub bootloader located in the 'Guix_image' root partition.
-
-If TARGETS is set, use its car as the GRUB image format and its cdr as
-the output filename.  Otherwise, use defaults for the host platform."
-  (let ((grub-config "grub.cfg"))
-    (call-with-output-file grub-config
-      (lambda (port)
-        ;; Create a tiny configuration file telling the embedded grub where to
-        ;; load the real thing.  XXX This is quite fragile, and can prevent
-        ;; the image from booting when there's more than one volume with this
-        ;; label present.  Reproducible almost-UUIDs could reduce the risk
-        ;; (not eliminate it).
-        (format port
-                "insmod part_msdos~@
-               insmod part_gpt~@
-               search --set=root --label Guix_image~@
-               configfile /boot/grub/grub.cfg~%")))
-    (install-efi grub-efi grub-config esp #:targets targets)
-    (delete-file grub-config)))
+(define (install-efi efibootmgr vendir loader* disk plan)
+  "See also install-efi in (gnu bootloader)."
+  (let* ((loader (string-map (match-lambda (#\/ #\\) (x x)) loader*))
+         (bootnums (filter (compose (cut string-prefix? loader <>) car)
+                     (efi-bootnums efibootmgr)))
+         (plan-files (map cadr plan)))
+    (define (size file) (if (file-exists? file) (stat:size (stat file)) 0))
+    (define (vendirof file) (string-append vendir "/" file))
+    (define (loaderof file) (string-append loader "\\" file))
+    (define (delete-boot num file)
+      (invoke efibootmgr "--quiet" "--bootnum" num "--delete-bootnum")
+      (when (file-exists? file) (delete-file file)))
 
+    (mkdir-p vendir)
+    ;; Delete old entries first, to clear up space.
+    (for-each (lambda (spec) ; '(path . bootnum)
+                (let* ((s (substring (car spec) (string-length loader)))
+                       (file (substring s (if (string-prefix? "\\" s) 1 0))))
+                  (unless (member file plan-files)
+                    (delete-boot (cdr spec) (vendirof file)))))
+      bootnums)
+    ;; New and updated entries.
+    (in-temporary-directory
+      (for-each
+        (lambda (spec)
+          (let* ((builder (car spec)) (name (cadr spec))
+                 (dest (vendirof name)) (loadest (loaderof name))
+                 (rest (reverse (cdr (member name plan-files)))))
+            ;; Build to a temporary file so we can check its size.
+            (builder name)
+            ;; Disk space is usually limited on ESPs.
+            ;; Try to clear space as we install new bootloaders.
+            (if (while (> (- (size name) (size dest)) (free-disk-space vendir))
+                  (let ((del (find (compose file-exists? vendirof) rest)))
+                    (if del (delete-file (vendirof del)) (break #t))))
+                (begin
+                  (and=> (assoc-ref bootnums loadest) (cut delete-boot <> dest))
+                  (warning (G_ "ESP too small for bootloader ~a!~%") name))
+                ;; The ESP is too small for atomic copy.
+                (begin
+                  (copy-file name dest)
+                  (unless (assoc loadest bootnums)
+                    (invoke
+                      efibootmgr "--quiet" "--create-only" "--label"
+                      (cddr spec) "--disk" disk "--loader" loadest))))
+            (delete-file name)))
+        plan))
+    ;; Verify that at least the first entry was installed.
+    (unless (file-exists? (vendirof (cadr (car plan))))
+      ;; Extremely fatal error so we use leave instead of raise.
+      (leave (G_ "not enough space in ESP to install bootloader!
+ SYSTEM WILL NOT BOOT UNLESS THIS IS FIXED!~%")))
+    ;; Some UEFI systems will refuse to acknowledge the existence of boot
+    ;; entries unless they're in bootorder, so just shove everything in there.
+    (invoke
+      efibootmgr "--quiet" "--bootorder"
+      ;; Recall efi-bootnums to get a fresh list with new installs.
+      (let ((num (cute assoc-ref (efi-bootnums efibootmgr) <>))) ; cute is eager
+        (string-join (filter-map (compose num loaderof) plan-files) ",")))))
diff --git a/gnu/build/image.scm b/gnu/build/image.scm
index 6ca0a428e0..1b2d4da814 100644
--- a/gnu/build/image.scm
+++ b/gnu/build/image.scm
@@ -8,6 +8,7 @@
 ;;; Copyright © 2022 Pavel Shlyak <p.shlyak@pantherx.org>
 ;;; Copyright © 2022 Denis 'GNUtoo' Carikli <GNUtoo@cyberdimension.org>
 ;;; Copyright © 2023 Efraim Flashner <efraim@flashner.co.il>
+;;; Copyright © 2024 Lilah Tascheter <lilah@lunabee.space>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -28,6 +29,7 @@ (define-module (gnu build image)
   #:use-module (guix build store-copy)
   #:use-module (guix build syscalls)
   #:use-module (guix build utils)
+  #:use-module (guix deprecation)
   #:use-module (guix store database)
   #:use-module (guix utils)
   #:use-module (gnu build bootloader)
@@ -181,23 +183,10 @@ (define* (register-closure prefix closure
                        #:prefix prefix
                        #:registration-time %epoch)))))
 
-(define* (initialize-efi-partition root
-                                   #:key
-                                   grub-efi
-                                   #:allow-other-keys)
-  "Install in ROOT directory, an EFI loader using GRUB-EFI."
-  (install-efi-loader grub-efi root))
-
-(define* (initialize-efi32-partition root
-                                     #:key
-                                     grub-efi32
-                                     #:allow-other-keys)
-  "Install in ROOT directory, an EFI 32bit loader using GRUB-EFI32."
-  (install-efi-loader grub-efi32 root
-                      #:targets (cond ((target-x86?)
-                                       '("i386-efi" . "BOOTIA32.EFI"))
-                                      ((target-arm?)
-                                       '("arm-efi" . "BOOTARM.EFI")))))
+(define (initialize-efi-partition root . rest)
+  (mkdir-p (string-append root "/EFI")))
+
+(define-deprecated/alias initialize-efi32-partition initialize-efi-partition)
 
 (define* (initialize-root-partition root
                                     #:key
diff --git a/gnu/image.scm b/gnu/image.scm
index 7fb06dec10..c6cc264147 100644
--- a/gnu/image.scm
+++ b/gnu/image.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2020, 2022 Mathieu Othacehe <othacehe@gnu.org>
 ;;; Copyright © 2023 Oleg Pykhalov <go.wigust@gmail.com>
+;;; Copyright © 2024 Lilah Tascheter <lilah@lunabee.space>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -35,6 +36,7 @@ (define-module (gnu image)
             partition-label
             partition-uuid
             partition-flags
+            partition-target
             partition-initializer
 
             image
@@ -131,6 +133,8 @@ (define-record-type* <partition> partition make-partition
   (flags                partition-flags
                         (default '())  ;list of symbols
                         (sanitize validate-partition-flags))
+  (target               partition-target ; bootloader target type: symbol | #f
+                        (default #f))
   (initializer          partition-initializer
                         (default #false))) ;gexp | #false
 
diff --git a/gnu/system/image.scm b/gnu/system/image.scm
index b0c96c60f0..8ac91800ad 100644
--- a/gnu/system/image.scm
+++ b/gnu/system/image.scm
@@ -6,6 +6,7 @@
 ;;; Copyright © 2022 Alex Griffin <a@ajgrf.com>
 ;;; Copyright © 2023 Efraim Flashner <efraim@flashner.co.il>
 ;;; Copyright © 2023 Oleg Pykhalov <go.wigust@gmail.com>
+;;; Copyright © 2024 Lilah Tascheter <lilah@lunabee.space>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -23,6 +24,7 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (gnu system image)
+  #:use-module (guix deprecation)
   #:use-module (guix diagnostics)
   #:use-module (guix discovery)
   #:use-module (guix gexp)
@@ -133,12 +135,10 @@ (define esp-partition
    ;; FAT-ness is based on file system size (16 in this case).
    (file-system "vfat")
    (flags '(esp))
-   (initializer (gexp initialize-efi-partition))))
+   (target 'esp)
+   (initializer #~initialize-efi-partition)))
 
-(define esp32-partition
-  (partition
-   (inherit esp-partition)
-   (initializer (gexp initialize-efi32-partition))))
+(define-deprecated/alias esp32-partition esp-partition)
 
 (define root-partition
   (partition
@@ -149,6 +149,7 @@ (define root-partition
    ;; with U-Boot.
    (file-system-options (list "-O" "^metadata_csum,^64bit"))
    (flags '(boot))
+   (target 'root)
    (initializer (gexp initialize-root-partition))))
 
 (define mbr-disk-image
@@ -173,11 +174,7 @@ (define efi-disk-image
    (partition-table-type 'gpt)
    (partitions (list esp-partition root-partition))))
 
-(define efi32-disk-image
-  (image-without-os
-   (format 'disk-image)
-   (partition-table-type 'gpt)
-   (partitions (list esp32-partition root-partition))))
+(define-deprecated/alias efi32-disk-image efi-disk-image)
 
 (define iso9660-image
   (image-without-os
@@ -238,10 +235,7 @@ (define efi-raw-image-type
    (name 'efi-raw)
    (constructor (cut image-with-os efi-disk-image <>))))
 
-(define efi32-raw-image-type
-  (image-type
-   (name 'efi32-raw)
-   (constructor (cut image-with-os efi32-disk-image <>))))
+(define-deprecated/alias efi32-raw-image-type efi-raw-image-type)
 
 (define qcow2-image-type
   (image-type
-- 
2.45.2