[bug#73202] [PATCH v2 09/15] gnu: bootloader: Add bootloader-configurations->gexp.

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

From: Lilah Tascheter <lilah@lunabee.space>

* gnu/bootloader.scm (bootloader)[default-targets]: Add field.
(target-overrides, normalize, bootloader-configuration->gexp,
bootloader-configurations->gexp): New procedures.

Change-Id: I3654d160f7306bb45a78b82ea6b249ff4281f739
---
 gnu/bootloader.scm | 108 +++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 108 insertions(+)

diff --git a/gnu/bootloader.scm b/gnu/bootloader.scm
index 0c24996205..c77de6f55e 100644
--- a/gnu/bootloader.scm
+++ b/gnu/bootloader.scm
@@ -67,6 +67,7 @@ (define-module (gnu bootloader)
             bootloader?
             bootloader-name
             bootloader-package
+            bootloader-default-targets
             bootloader-installer
             bootloader-disk-image-installer
             bootloader-configuration-file
@@ -107,6 +108,8 @@ (define-module (gnu bootloader)
             bootloader-configuration-device-tree-support?
             bootloader-configuration-extra-initrd
 
+            bootloader-configuration->gexp
+            bootloader-configurations->gexp
 
             efi-bootloader-chain))
 
@@ -255,6 +258,7 @@ (define-record-type* <bootloader>
   bootloader?
   (name                            bootloader-name)
   (package                         bootloader-package)
+  (default-targets bootloader-default-targets (default '()))
   (installer                       bootloader-installer)
   (disk-image-installer            bootloader-disk-image-installer
                                    (default #f))
@@ -498,6 +502,110 @@ (define (bootloader-configuration-targets config)
       ;; hence the default value of '(#f) rather than '().
       (list #f)))
 
+\f
+;;;
+;;; Bootloader installation paths.
+;;;
+
+(define (target-overrides . layers)
+  (let* ((types (flat-map (cute map bootloader-target-type <>) layers))
+         ;; TODO: use loop instead of fold for early termination.
+         (pred (lambda (type layer found)
+                 (or found (get-target-of-type type layer))))
+         (find (lambda (type) (fold (cute pred type <> <>) #f layers))))
+    (filter identity (map find (delete-duplicates types)))))
+
+(define (normalize targets)
+  "Augments TARGETS with filesystem information at runtime, allowing
+users to specify a lot less information.  Puts TARGETS into a normal
+form, where each path is fully specified up to a device offset."
+  (define (mass m)
+    `((,(mount-source m) . ,m)
+      (,(mount-point m) . ,m)))
+
+  (define (accessible=> d f)
+    (and d (access? d R_OK) (f d)))
+
+  (define (fixuuid target)
+    (match-record target <bootloader-target> (uuid file-system)
+      (let ((type (cond ((not file-system) 'dce)
+                        ((member file-system '("vfat" "fat32")) 'fat)
+                        ((string=? file-system "ntfs") 'ntfs)
+                        ((string=? file-system "iso9660") 'iso9660)
+                        (else 'dce))))
+        (bootloader-target (inherit target)
+          (uuid (cond ((uuid? uuid) uuid)
+                  ((bytevector? uuid) (bytevector->uuid uuid type))
+                  ((string? uuid) (string->uuid uuid type))
+                  (else #f)))))))
+
+  (define (arborify target targets)
+    (let* ((up (lambda (t) (and t (parent-of t targets))))
+           (proto (unfold target-base? identity up (up target) list))
+           (chain (reverse (cons target proto))))
+      (bootloader-target
+        (inherit target)
+        (offset (and=> (car chain) bootloader-target-type))
+        (path (reduce pathcat #f (map bootloader-target-path (cdr chain)))))))
+
+  (let ((amounts (delay (apply append (map mass (mounts))))))
+    (define (assoc-mnt f)
+      (lambda (v) (and=> (assoc-ref (force amounts) v) f)))
+
+    (define (scrape target)
+      (match-record target <bootloader-target>
+        (expected? path offset device label uuid file-system)
+        (if expected? target
+          (bootloader-target
+            (inherit target)
+            (device (or device
+                        (false-if-exception
+                          (or (and=> uuid find-partition-by-uuid)
+                              (and=> label find-partition-by-label)))
+                        (and path ((assoc-mnt mount-source)
+                                   (unfold-pathcat target targets)))))
+            (label (or label (accessible=> device read-partition-label)))
+            (uuid (or uuid (accessible=> device read-partition-uuid)))
+            (file-system (or file-system (and=> device (assoc-mnt mount-type))))
+            (offset (and path offset))
+            (path (or path (and=> device (assoc-mnt mount-point))))))))
+
+    (let ((mid (map (compose fixuuid scrape) targets)))
+      (map (cut arborify <> mid) mid))))
+
+(define* (bootloader-configuration->gexp bootloader-config args #:key
+                                          (root-offset "/") (overrides '()))
+  "Returns a gexp to install BOOTLOADER-CONFIG to its targets, passing ARGS
+to each installer alongside the additional #:bootloader-config keyword
+arguments.  Target OVERRIDES are applied and all path targets have ROOT-OFFSET
+applied.  The following keyword arguments are expected in ARGS:
+@enumerate
+@item current-boot-alternative
+@item old-boot-alternatives
+@item locale (from bootmeta)
+@item store-directory-prefix (from bootmeta)
+@item store-crypto-devices (from bootmeta)
+@end enumerate"
+  (let* ((bootloader (bootloader-configuration-bootloader bootloader-config))
+         (installer (bootloader-installer bootloader))
+         (auto-targets (list (bootloader-target
+                               (type 'root)
+                               (path root-offset)
+                               (offset #f))))
+         (targets (target-overrides
+                    overrides
+                    (bootloader-configuration-targets bootloader-config)
+                    auto-targets
+                    (bootloader-default-targets bootloader)))
+         (conf (bootloader-configuration
+                 (inherit bootloader-config)
+                 (targets (normalize targets)))))
+    (apply installer #:bootloader-config conf args)))
+
+(define (bootloader-configurations->gexp bootloader-configs . rest)
+  (apply gbegin (filter-map (cut apply bootloader-configuration->gexp <> rest)
+                            bootloader-configs)))
+
 \f
 ;;;
 ;;; Bootloaders.
-- 
2.45.2