[bug#72457] [PATCH v6 03/12] gnu: bootloader: Update bootloader-configuration targets field.

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

From: Lilah Tascheter <lilah@lunabee.space>

* gnu/bootloader.scm (warn-update-targets): New procedure.
(bootloader-configuration)[targets]: Use warn-update-targets sanitizer.
* gnu/installer/parted.scm (bootloader-configuration): Use new target
field format.
* gnu/system/images/hurd.scm (hurd-barebones-os)[bootloader],
gnu/system/images/novena.scm (novena-barebones-os)[bootloader],
gnu/system/images/orangepi-r1-plus-lts-rk3328.scm
(orangepi-r1-plus-lts-rk3328-barebones-os)[bootloader],
gnu/system/images/pine64.scm (pine64-barebones-os)[bootloader],
gnu/system/images/pinebook-pro.scm
(pinebook-pro-barebones-os)[bootloader],
gnu/system/images/rock64.scm (rock64-barebones-os)[bootloader],
gnu/system/images/unmatched.scm (unmatched-barebones-os)[bootloader],
gnu/system/images/visionfive2.scm
(visionfive2-barebones-os)[bootloader]: Use new target format.
* gnu/system/install.scm (installation-os)[bootloader]: Use new format.
(embedded-installation-os): Use new format and adjust description.
(beaglebone-black-installation-os, a20-olinuxino-lime-installation-os,
a20-olinuxino-lime2-emmc-installation-os,
a20-olinuxino-micro-installation-os, bananapi-m2-ultra-installation-os,
firefly-rk3399-installation-os, mx6cuboxi-installation-os,
novena-installation-os, nintendo-nes-classic-edition-installation-os,
orangepi-r1-plus-lts-rk3328-installation-os, pine64-plus-installation-os,
pinebook-installation-os, rock64-installation-os,
rockpro64-installation-os, rk3399-puma-installation-os,
wandboard-installation-os): Don't guess block device.

Change-Id: I3654d160f7306bb45a78b82ea6b249ff4281f739
---
 gnu/bootloader.scm                            | 46 +++++++++-
 gnu/installer/parted.scm                      | 12 ++-
 gnu/system/images/hurd.scm                    |  4 +-
 gnu/system/images/novena.scm                  |  3 +-
 .../images/orangepi-r1-plus-lts-rk3328.scm    |  3 +-
 gnu/system/images/pine64.scm                  |  3 +-
 gnu/system/images/pinebook-pro.scm            |  3 +-
 gnu/system/images/rock64.scm                  |  3 +-
 gnu/system/images/unmatched.scm               |  3 +-
 gnu/system/images/visionfive2.scm             |  3 +-
 gnu/system/install.scm                        | 85 ++++++-------------
 11 files changed, 88 insertions(+), 80 deletions(-)

diff --git a/gnu/bootloader.scm b/gnu/bootloader.scm
index 0a06c736c6..14066e11f9 100644
--- a/gnu/bootloader.scm
+++ b/gnu/bootloader.scm
@@ -43,6 +43,7 @@ (define-module (gnu bootloader)
   #:use-module (guix utils)
   #:use-module (ice-9 match)
   #:use-module (ice-9 receive)
+  #:use-module (ice-9 regex)
   #:use-module (rnrs bytevectors)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
@@ -486,9 +487,49 @@ (define-syntax with-targets
 ;;; Bootloader configuration record.
 ;;;
 
-;; The <bootloader-configuration> record contains bootloader independant
+;; The <bootloader-configuration> record contains bootloader independent
 ;; configuration used to fill bootloader configuration file.
 
+;; Based on report-duplicate-field-specifier from (guix records).
+(define (report-duplicate-type-field targets)
+  "Report the first target with duplicate type among TARGETS."
+  (let loop ((targets targets)
+             (seen    '()))
+    (match targets
+      ((target rest ...)
+       (let ((type (bootloader-target-type target)))
+         (when (memq type seen)
+           (error loc (G_ "target with duplicate type~%") duplicate))
+         (loop rest (cons type seen))))
+      (() #t))))
+
+(define-with-syntax-properties (warn-update-targets (value properties))
+  (let ((targets (wrap-element value))
+        (loc (source-properties->location properties)))
+    (define string->target
+      (match-lambda
+        ((? bootloader-target? target) target)
+        ((? string? s) (if (string-prefix? "/dev" s)
+                           (if (string-match ".+p[0-9]+$" s)
+                               (bootloader-target
+                                 (type 'part)
+                                 (device s))
+                               (bootloader-target
+                                 (type 'disk)
+                                 (device s)))
+                           (bootloader-target
+                             (type 'esp)
+                             (offset 'root)
+                             (path s))))
+        (x (error loc (G_ "invalid target '~a'~%") x))))
+
+    ;; XXX: Should this be an error?
+    (when (any string? targets)
+      (warning loc (G_ "the 'targets' field should now contain \
+<bootloader-target> records, inferring a best guess, this might break!~%")))
+    (let* ((targets (map string->target targets)))
+      (report-duplicate-type-field targets)
+      targets)))
 
 (define-record-type* <bootloader-configuration>
   bootloader-configuration make-bootloader-configuration
@@ -496,7 +537,8 @@ (define-record-type* <bootloader-configuration>
   (bootloader
    bootloader-configuration-bootloader)   ;<bootloader>
   (targets               bootloader-configuration-targets
-                         (default #f))     ;list of strings
+                         (default '())    ;list of strings
+                         (sanitize warn-update-targets))
   (menu-entries          bootloader-configuration-menu-entries
                          (default '()))   ;list of <menu-entry>
   (default-entry         bootloader-configuration-default-entry
diff --git a/gnu/installer/parted.scm b/gnu/installer/parted.scm
index dbdec1bba8..da19a57878 100644
--- a/gnu/installer/parted.scm
+++ b/gnu/installer/parted.scm
@@ -1460,15 +1460,19 @@ (define (root-user-partition? partition)
 
 (define (bootloader-configuration user-partitions)
   "Return the bootloader configuration field for USER-PARTITIONS."
-  (let* ((root-partition (find root-user-partition?
-                               user-partitions))
+  (let* ((root-partition (find root-user-partition? user-partitions))
          (root-partition-disk (user-partition-disk-file-name root-partition)))
     `((bootloader-configuration
        ,@(if (efi-installation?)
              `((bootloader grub-efi-bootloader)
-               (targets (list ,(default-esp-mount-point))))
+               (targets (list (bootloader-target
+                                (type 'esp)
+                                (path ,(default-esp-mount-point))))))
              `((bootloader grub-bootloader)
-               (targets (list ,root-partition-disk))))
+               (targets (list (bootloader-target
+                                (type 'disk)
+                                ;; TODO: Provide a uuid or label.
+                                (device ,root-partition-disk))))))
 
        ;; XXX: Assume we defined the 'keyboard-layout' field of
        ;; <operating-system> right above.
diff --git a/gnu/system/images/hurd.scm b/gnu/system/images/hurd.scm
index 9b618f7dc6..8fb00a6903 100644
--- a/gnu/system/images/hurd.scm
+++ b/gnu/system/images/hurd.scm
@@ -41,9 +41,7 @@ (define-module (gnu system images hurd)
 (define hurd-barebones-os
   (operating-system
     (inherit %hurd-default-operating-system)
-    (bootloader (bootloader-configuration
-                 (bootloader grub-minimal-bootloader)
-                 (targets '("/dev/sdX"))))
+    (bootloader (bootloader-configuration (bootloader grub-minimal-bootloader)))
     (file-systems (cons (file-system
                           (device (file-system-label "my-root"))
                           (mount-point "/")
diff --git a/gnu/system/images/novena.scm b/gnu/system/images/novena.scm
index 810e2bed5f..a7a1f499dd 100644
--- a/gnu/system/images/novena.scm
+++ b/gnu/system/images/novena.scm
@@ -39,8 +39,7 @@ (define novena-barebones-os
     (timezone "Europe/Paris")
     (locale "en_US.utf8")
     (bootloader (bootloader-configuration
-                 (bootloader u-boot-novena-bootloader)
-                 (targets '("/dev/vda"))))
+                 (bootloader u-boot-novena-bootloader)))
     (initrd-modules '())
     (kernel linux-libre-arm-generic)
     (kernel-arguments '("console=ttymxc1,115200"))
diff --git a/gnu/system/images/orangepi-r1-plus-lts-rk3328.scm b/gnu/system/images/orangepi-r1-plus-lts-rk3328.scm
index 6ec644f113..a3dae24377 100644
--- a/gnu/system/images/orangepi-r1-plus-lts-rk3328.scm
+++ b/gnu/system/images/orangepi-r1-plus-lts-rk3328.scm
@@ -39,8 +39,7 @@ (define orangepi-r1-plus-lts-rk3328-barebones-os
     (timezone "Europe/Amsterdam")
     (locale "en_US.utf8")
     (bootloader (bootloader-configuration
-                  (bootloader u-boot-orangepi-r1-plus-lts-rk3328-bootloader)
-                  (targets '("/dev/mmcblk0"))))
+                  (bootloader u-boot-orangepi-r1-plus-lts-rk3328-bootloader)))
     (initrd-modules '())
     (kernel linux-libre-arm64-generic)
     (file-systems (cons (file-system
diff --git a/gnu/system/images/pine64.scm b/gnu/system/images/pine64.scm
index 457ff4345f..b166838ddd 100644
--- a/gnu/system/images/pine64.scm
+++ b/gnu/system/images/pine64.scm
@@ -41,8 +41,7 @@ (define pine64-barebones-os
     (timezone "Europe/Paris")
     (locale "en_US.utf8")
     (bootloader (bootloader-configuration
-                 (bootloader u-boot-pine64-lts-bootloader)
-                 (targets '("/dev/vda"))))
+                 (bootloader u-boot-pine64-lts-bootloader)))
     (initrd-modules '())
     (kernel linux-libre-arm64-generic)
     (file-systems (cons (file-system
diff --git a/gnu/system/images/pinebook-pro.scm b/gnu/system/images/pinebook-pro.scm
index 3a0f3abf1f..b26adfb7b9 100644
--- a/gnu/system/images/pinebook-pro.scm
+++ b/gnu/system/images/pinebook-pro.scm
@@ -38,8 +38,7 @@ (define pinebook-pro-barebones-os
     (timezone "Europe/Paris")
     (locale "en_US.utf8")
     (bootloader (bootloader-configuration
-                 (bootloader u-boot-pinebook-pro-rk3399-bootloader)
-                 (targets '("/dev/vda"))))
+                 (bootloader u-boot-pinebook-pro-rk3399-bootloader)))
     (initrd-modules '())
     (kernel linux-libre-arm64-generic)
     (file-systems (cons (file-system
diff --git a/gnu/system/images/rock64.scm b/gnu/system/images/rock64.scm
index b3dcfc6193..0b243662d6 100644
--- a/gnu/system/images/rock64.scm
+++ b/gnu/system/images/rock64.scm
@@ -39,8 +39,7 @@ (define rock64-barebones-os
     (timezone "Europe/Oslo")
     (locale "en_US.utf8")
     (bootloader (bootloader-configuration
-                 (bootloader u-boot-rock64-rk3328-bootloader)
-                 (targets '("/dev/sda"))))
+                 (bootloader u-boot-rock64-rk3328-bootloader)))
     (initrd-modules '())
     (kernel linux-libre-arm64-generic)
     (file-systems (cons (file-system
diff --git a/gnu/system/images/unmatched.scm b/gnu/system/images/unmatched.scm
index d40a32f184..7eb147bbab 100644
--- a/gnu/system/images/unmatched.scm
+++ b/gnu/system/images/unmatched.scm
@@ -39,8 +39,7 @@ (define unmatched-barebones-os
     (timezone "Asia/Jerusalem")
     (locale "en_US.utf8")
     (bootloader (bootloader-configuration
-                 (bootloader u-boot-sifive-unmatched-bootloader)
-                 (targets '("/dev/vda"))))
+                 (bootloader u-boot-sifive-unmatched-bootloader)))
     (initrd-modules '())
     (kernel linux-libre-riscv64-generic)
     (file-systems (cons (file-system
diff --git a/gnu/system/images/visionfive2.scm b/gnu/system/images/visionfive2.scm
index 26f70afbc1..a1c0733692 100644
--- a/gnu/system/images/visionfive2.scm
+++ b/gnu/system/images/visionfive2.scm
@@ -62,8 +62,7 @@ (define visionfive2-barebones-os
     (timezone "Etc/UTC")
     (locale "en_US.utf8")
     (bootloader (bootloader-configuration
-                 (bootloader u-boot-starfive-visionfive2-bootloader)
-                 (targets '("/dev/mmcblk0"))))
+                  (bootloader u-boot-starfive-visionfive2-bootloader)))
     (file-systems (cons (file-system
                           (device (file-system-label "Guix_image"))
                           (mount-point "/")
diff --git a/gnu/system/install.scm b/gnu/system/install.scm
index 78a3cdaaec..2d0c9875fb 100644
--- a/gnu/system/install.scm
+++ b/gnu/system/install.scm
@@ -7,7 +7,8 @@
 ;;; Copyright © 2020 Florian Pelz <pelzflorian@pelzflorian.de>
 ;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il>
 ;;; Copyright © 2022 Josselin Poiret <dev@jpoiret.xyz>
-;;; Copyright © 2023 Herman Rimm <herman@rimm.ee>
+;;; Copyright © 2023-2024 Herman Rimm <herman@rimm.ee>
+;;; Copyright © 2024 Lilah Tascheter <lilah@lunabee.space>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -503,9 +504,7 @@ (define installation-os
     (timezone "Europe/Paris")
     (locale "en_US.utf8")
     (name-service-switch %mdns-host-lookup-nss)
-    (bootloader (bootloader-configuration
-                 (bootloader grub-bootloader)
-                 (targets '("/dev/sda"))))
+    (bootloader (bootloader-configuration (bootloader grub-bootloader)))
     (label (string-append "GNU Guix installation "
                           (or (getenv "GUIX_DISPLAYED_VERSION")
                               (package-version guix))))
@@ -569,17 +568,19 @@ (define* (os-with-u-boot os board #:key (bootloader-target "/dev/mmcblk0")
                               (package (make-u-boot-package board triplet))))
                  (targets (list bootloader-target))))))
 
-(define* (embedded-installation-os bootloader bootloader-target tty
-                                   #:key (extra-modules '()))
-  "Return an installation os for embedded systems.
-The initrd gets the extra modules EXTRA-MODULES.
-A getty is provided on TTY.
-The bootloader BOOTLOADER is installed to BOOTLOADER-TARGET."
+(define* (embedded-installation-os bootloader #:optional
+                                   (tty "ttyS0")
+                                   (extra-modules '())
+                                   (bootloader-targets '()))
+  "Return an installation OS for embedded systems.  The BOOTLOADER is
+installed to its default targets, or BOOTLOADER-TARGETS if provided.  A
+getty is provided on ttyS0, or on TTY if provided.  The initrd gets the
+EXTRA-MODULES."
   (operating-system
     (inherit installation-os)
     (bootloader (bootloader-configuration
-                 (bootloader bootloader)
-                 (targets (list bootloader-target))))
+                  (bootloader bootloader)
+                  (targets bootloader-targets)))
     (kernel linux-libre)
     (kernel-arguments
      (cons (string-append "console=" tty)
@@ -587,88 +588,58 @@ (define* (embedded-installation-os bootloader bootloader-target tty
     (initrd-modules (append extra-modules %base-initrd-modules))))
 
 (define beaglebone-black-installation-os
-  (embedded-installation-os u-boot-beaglebone-black-bootloader
-                            "/dev/sda"
-                            "ttyO0"
-                            #:extra-modules
-                            ;; This module is required to mount the sd card.
-                            '("omap_hsmmc")))
+  (embedded-installation-os
+    ;; The omap_hsmmc module is required to mount the microSD card.
+    u-boot-beaglebone-black-bootloader "ttyO0" '("omap_hsmmc")))
 
 
 (define a20-olinuxino-lime-installation-os
-  (embedded-installation-os u-boot-a20-olinuxino-lime-bootloader
-                            "/dev/mmcblk0" ; SD card storage
-                            "ttyS0"))
+  (embedded-installation-os u-boot-a20-olinuxino-lime-bootloader))
 
 (define a20-olinuxino-lime2-emmc-installation-os
-  (embedded-installation-os u-boot-a20-olinuxino-lime2-bootloader
-                            "/dev/mmcblk1" ; eMMC storage
-                            "ttyS0"))
+  (embedded-installation-os u-boot-a20-olinuxino-lime2-bootloader))
 
 (define a20-olinuxino-micro-installation-os
-  (embedded-installation-os u-boot-a20-olinuxino-micro-bootloader
-                            "/dev/mmcblk0" ; SD card storage
-                            "ttyS0"))
+  (embedded-installation-os u-boot-a20-olinuxino-micro-bootloader))
 
 (define bananapi-m2-ultra-installation-os
-  (embedded-installation-os u-boot-bananapi-m2-ultra-bootloader
-                            "/dev/mmcblk1" ; eMMC storage
-                            "ttyS0"))
+  (embedded-installation-os u-boot-bananapi-m2-ultra-bootloader))
 
 (define firefly-rk3399-installation-os
   (embedded-installation-os u-boot-firefly-rk3399-bootloader
-                            "/dev/mmcblk0" ; SD card/eMMC (SD priority) storage
                             "ttyS2")) ; UART2 connected on the Pi2 bus
 
 (define mx6cuboxi-installation-os
-  (embedded-installation-os u-boot-mx6cuboxi-bootloader
-                            "/dev/mmcblk0" ; SD card storage
-                            "ttymxc0"))
+  (embedded-installation-os u-boot-mx6cuboxi-bootloader "ttymxc0"))
 
 (define novena-installation-os
-  (embedded-installation-os u-boot-novena-bootloader
-                            "/dev/mmcblk1" ; SD card storage
-                            "ttymxc1"))
+  (embedded-installation-os u-boot-novena-bootloader "ttymxc1"))
 
 (define nintendo-nes-classic-edition-installation-os
-  (embedded-installation-os u-boot-nintendo-nes-classic-edition-bootloader
-                            "/dev/mmcblk0" ; SD card (solder it yourself)
-                            "ttyS0"))
+  (embedded-installation-os u-boot-nintendo-nes-classic-edition-bootloader))
 
 (define orangepi-r1-plus-lts-rk3328-installation-os
-  (embedded-installation-os u-boot-orangepi-r1-plus-lts-rk3328-bootloader
-                            "/dev/mmcblk0" ; SD card storage
-                            "ttyS0"))
+  (embedded-installation-os u-boot-orangepi-r1-plus-lts-rk3328-bootloader))
 
 (define pine64-plus-installation-os
-  (embedded-installation-os u-boot-pine64-plus-bootloader
-                            "/dev/mmcblk0" ; SD card storage
-                            "ttyS0"))
+  (embedded-installation-os u-boot-pine64-plus-bootloader))
 
 (define pinebook-installation-os
-  (embedded-installation-os u-boot-pinebook-bootloader
-                            "/dev/mmcblk0" ; SD card storage
-                            "ttyS0"))
+  (embedded-installation-os u-boot-pinebook-bootloader))
 
 (define rock64-installation-os
   (embedded-installation-os u-boot-rock64-rk3328-bootloader
-                            "/dev/mmcblk0" ; SD card/eMMC (SD priority) storage
                             "ttyS2")) ; UART2 connected on the Pi2 bus
 
 (define rockpro64-installation-os
   (embedded-installation-os u-boot-rockpro64-rk3399-bootloader
-                            "/dev/mmcblk0" ; SD card/eMMC (SD priority) storage
                             "ttyS2")) ; UART2 connected on the Pi2 bus
 
 (define rk3399-puma-installation-os
-  (embedded-installation-os u-boot-puma-rk3399-bootloader
-                            "/dev/mmcblk0" ; SD card storage
-                            "ttyS0"))
+  (embedded-installation-os u-boot-puma-rk3399-bootloader))
 
 (define wandboard-installation-os
-  (embedded-installation-os u-boot-wandboard-bootloader
-                            "/dev/mmcblk0" ; SD card storage
-                            "ttymxc0"))
+  (embedded-installation-os u-boot-wandboard-bootloader "ttymxc0"))
 
 ;; Return the default os here so 'guix system' can consume it directly.
 installation-os
-- 
2.45.2