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: Use define-configuration.

Browse source 
* gnu/bootloader.scm (bootloader-target): Use define-configuration.

Change-Id: I9c98da238bcb00639137349b2312a34336928aac
This commit is contained in:
Herman Rimm 2024-10-01 13:57:57 +02:00 committed by Ryan Schanzenbacher
parent 3f3ce48900
commit affda634d5
Signed by: ryan77627
GPG key ID: 81B0E222A3E2308E
1 changed files with 40 additions and 19 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

59
gnu/bootloader.scm
View file

@ -29,6 +29,7 @@ (define-module (gnu bootloader)
#:autoload (gnu build file-systems) #:autoload (gnu build file-systems)
(read-partition-label read-partition-uuid (read-partition-label read-partition-uuid
find-partition-by-label find-partition-by-uuid) find-partition-by-label find-partition-by-uuid)
#:use-module (gnu services configuration)
#:use-module (gnu system file-systems) #:use-module (gnu system file-systems)
#:use-module (gnu system uuid) #:use-module (gnu system uuid)
#:autoload (guix build syscalls) #:autoload (guix build syscalls)
@ -305,20 +306,38 @@ (define-record-type* <bootloader>
;; <bootloader-target> represents different kinds of targets in a ;; <bootloader-target> represents different kinds of targets in a
;; normalized form. ;; normalized form.
(define-record-type* <bootloader-target> (define (string-or-boolean? x)
bootloader-target make-bootloader-target bootloader-target? (or (string? x) (boolean? x)))
(type bootloader-target-type) ; symbol
(expected? bootloader-target-expected? (default #f)) ; bool
(path bootloader-target-path (default #f)) ; string|#f (define (symbol-or-boolean? x)
(offset bootloader-target-offset (thunked) ; symbol|#f (or (symbol? x) (boolean? x)))
(default (and (bootloader-target-path this-record)
(not (eq? (bootloader-target-type this-record) 'root)) ;; XXX: Are file-system-labels all that good?
'root))) ;; Could a block-device record be better, instead?
(device bootloader-target-device (default #f)) ; string|#f (define (file-system-label-or-boolean? x)
(file-system bootloader-target-file-system (default #f)) ; string|#f (or (file-system-label? x) (boolean? x)))
(label bootloader-target-label (default #f)) ; string|#f
(uuid bootloader-target-uuid (default #f))) ; uuid|#f (define (uuid-or-boolean? x)
(or (uuid? x) (boolean? x)))
(define-configuration/no-serialization bootloader-target
(type symbol "What target this record describes, e.g. 'esp or 'disk.")
(expected? (boolean #f) "TODO")
(path (string-or-boolean #f) "TODO")
(offset (symbol-or-boolean #f) "TODO")
(device
(string-or-boolean #f)
"Refers to a physical device or partition. A string is interpreted
as a block device. Note that block devices can vary per boot and may
not exist at boot-time. The find-partition-uuid procedure returns a
block device's UUID.")
(file-system
(string-or-boolean #f)
"Set the type of the file system, in case it isn't being detected
properly, or it is unmounted during bootloader installation. See also
the find-file-system and uuid->file-system procedures.")
(label (string-or-boolean #f) "TODO")
(uuid (uuid-or-boolean #f) "TODO"))
(define-condition-type &target-error &error target-error? (define-condition-type &target-error &error target-error?
(type target-error-type) (type target-error-type)
@ -365,8 +384,8 @@ (define (pathcat p1 p2)
(string-append (string-trim-right p1 #\/) "/" (string-trim p2 #\/))) (string-append (string-trim-right p1 #\/) "/" (string-trim p2 #\/)))
(define* (get-target-of-type type targets #:optional require?) (define* (get-target-of-type type targets #:optional require?)
"Finds a target in TARGETS of type TYPE, returns REQUIRE? if #false, "Finds a target in TARGETS of type TYPE, returns #f if REQUIRE? is #f,
or provides an error otherwise." and provides an error otherwise."
(define (type? target) (define (type? target)
(eq? type (bootloader-target-type target))) (eq? type (bootloader-target-type target)))
(match (filter type? targets) (match (filter type? targets)
@ -406,13 +425,14 @@ (define* (ensure-target-types types targets #:optional (base? #f))
"Ensures all TYPES are provided in TARGETS. Returns #t iff every ensured "Ensures all TYPES are provided in TARGETS. Returns #t iff every ensured
target and its requirements are fully provided. Errors out when a required TYPE target and its requirements are fully provided. Errors out when a required TYPE
isn't provided. When BASE?, only ensure path requirements up to a device." isn't provided. When BASE?, only ensure path requirements up to a device."
(not (any bootloader-target-expected? (let ((base (if base? target-base? not)))
(ensure types targets (if base? target-base? not))))) (not (any bootloader-target-expected? (ensure types targets base)))))
(define (ensure-majors types targets) (define (ensure-majors types targets)
"Errors out when a required TYPE isn't provided, or when use of multiple major "Errors out when a required TYPE isn't provided, or when use of multiple major
targets is detected." targets is detected."
(let* ((all (map bootloader-target-type (ensure types targets target-base?))) (let* ((all (map bootloader-target-type
(ensure types targets target-base?)))
(majors (delete-duplicates (filter type-major? all) eq?))) (majors (delete-duplicates (filter type-major? all) eq?)))
(if (< (length majors) 2) #t (if (< (length majors) 2) #t
(raise (condition (&message (message (G_ "multiple major targets used"))) (raise (condition (&message (message (G_ "multiple major targets used")))
@ -473,7 +493,8 @@ (define blocks
((spec ... expr) ((spec ... expr)
(let* ((path? (cut syntax-case <> (:path) ((_ :path) #t) (_ #f))) (let* ((path? (cut syntax-case <> (:path) ((_ :path) #t) (_ #f)))
(qualified? (cut syntax-case <> (=>) (qualified? (cut syntax-case <> (=>)
((_ => spec ...) (any path? #'(spec ...))) ((_ => spec ...)
(any path? #'(spec ...)))
(_ #f))) (_ #f)))
(specs #'(spec ...)) (specs #'(spec ...))
(lets (apply append (filter-map binds specs))) (lets (apply append (filter-map binds specs)))