From c2482d9e1d26f8618ceefa63313fd42a2fdf4daa Mon Sep 17 00:00:00 2001 From: Lilah Tascheter Date: Tue, 6 Aug 2024 19:11:17 -0500 Subject: [PATCH] gnu: bootloader: Add bootloader-configurations->gexp. * 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? (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))) + +;;; +;;; 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 (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 + (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))) + ;;; ;;; Bootloaders.