ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-07 07:26:13 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

gnu: bootloader: Add bootloader-configurations->gexp.

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

Change-Id: I3654d160f7306bb45a78b82ea6b249ff4281f739
This commit is contained in:
Lilah Tascheter 2024-08-06 19:11:17 -05:00 committed by Ryan Schanzenbacher
parent 3e536e9efd
commit c2482d9e1d
Signed by: ryan77627
GPG key ID: 81B0E222A3E2308E
1 changed files with 108 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

108
gnu/bootloader.scm
View file

@ -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.