@@ -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)))
+
+;;;
+;;; 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)))
+
;;;
;;; Bootloaders.
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(+)