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: Merge uuid and label into device.

Browse source 
Change-Id: If035bf0b1ee01bc93f638d04ed19df500ef4bc04
This commit is contained in:
Herman Rimm 2024-10-01 22:09:30 +02:00 committed by Ryan Schanzenbacher
parent affda634d5
commit 3bb77e73e1
Signed by: ryan77627
GPG key ID: 81B0E222A3E2308E
2 changed files with 25 additions and 39 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

60
gnu/bootloader.scm
View file

@ -82,8 +82,6 @@ (define-module (gnu bootloader)
bootloader-target-offset bootloader-target-offset
bootloader-target-device bootloader-target-device
bootloader-target-file-system bootloader-target-file-system
bootloader-target-label
bootloader-target-uuid
target-error? target-error?
target-error-type target-error-type
@ -317,8 +315,9 @@ (define (symbol-or-boolean? x)
(define (file-system-label-or-boolean? x) (define (file-system-label-or-boolean? x)
(or (file-system-label? x) (boolean? x))) (or (file-system-label? x) (boolean? x)))
(define (uuid-or-boolean? x) ;; TODO: Create wrapper record for block-device.
(or (uuid? x) (boolean? x))) (define (uuid-or-string-or-boolean? x)
(or (uuid? x) (string? x) (boolean? x)))
(define-configuration/no-serialization bootloader-target (define-configuration/no-serialization bootloader-target
(type symbol "What target this record describes, e.g. 'esp or 'disk.") (type symbol "What target this record describes, e.g. 'esp or 'disk.")
@ -326,7 +325,7 @@ (define-configuration/no-serialization bootloader-target
(path (string-or-boolean #f) "TODO") (path (string-or-boolean #f) "TODO")
(offset (symbol-or-boolean #f) "TODO") (offset (symbol-or-boolean #f) "TODO")
(device (device
(string-or-boolean #f) (uuid-or-string-or-boolean #f)
"Refers to a physical device or partition. A string is interpreted "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 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 not exist at boot-time. The find-partition-uuid procedure returns a
@ -335,9 +334,7 @@ (define-configuration/no-serialization bootloader-target
(string-or-boolean #f) (string-or-boolean #f)
"Set the type of the file system, in case it isn't being detected "Set the type of the file system, in case it isn't being detected
properly, or it is unmounted during bootloader installation. See also properly, or it is unmounted during bootloader installation. See also
the find-file-system and uuid->file-system procedures.") 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)
@ -410,8 +407,8 @@ (define (unfold-pathcat target targets)
(define (target-base? t) (define (target-base? t)
(or (not t) (match-record t <bootloader-target> (or (not t) (match-record t <bootloader-target>
(expected? offset device label uuid) (expected? offset device)
(or device label uuid (not offset) expected?)))) (or device (not offset) expected?))))
(define (type-major? target) (memq target '(root esp disk))) (define (type-major? target) (memq target '(root esp disk)))
@ -464,9 +461,15 @@ (define (resolve in target base)
(:path :devpath :device :fs :label :uuid) (:path :devpath :device :fs :label :uuid)
((name _) (not (identifier? #'name)) ((name _) (not (identifier? #'name))
#`(_ (syntax-error "binds must be to identifiers" #,in))) #`(_ (syntax-error "binds must be to identifiers" #,in)))
((name :device) #'(name (bootloader-target-device base))) ((name :device)
((name :label) #'(name (bootloader-target-label base))) #'(name (and (string? (bootloader-target-device base))
((name :uuid) #'(name (bootloader-target-uuid base))) (bootloader-target-device base))))
((name :label)
#'(name (and (string? (bootloader-target-device base))
(bootloader-target-device base))))
((name :uuid)
#'(name (and (uuid? (bootloader-target-device base))
(bootloader-target-device base))))
((name :fs) #'(name (bootloader-target-file-system base))) ((name :fs) #'(name (bootloader-target-file-system base)))
((name :path) #'(name (unfold-pathcat target targets))) ((name :path) #'(name (unfold-pathcat target targets)))
((name :devpath) ((name :devpath)
@ -650,22 +653,6 @@ (define (mass m)
`((,(mount-source m) . ,m) `((,(mount-source m) . ,m)
(,(mount-point 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) (define (arborify target targets)
(let* ((up (lambda (t) (and t (parent-of t targets)))) (let* ((up (lambda (t) (and t (parent-of t targets))))
(proto (unfold target-base? identity up (up target) list)) (proto (unfold target-base? identity up (up target) list))
@ -681,23 +668,22 @@ (define (assoc-mnt f)
(define (scrape target) (define (scrape target)
(match-record target <bootloader-target> (match-record target <bootloader-target>
(expected? path offset device label uuid file-system) (expected? path offset device file-system)
(if expected? target (if expected? target
(bootloader-target (bootloader-target
(inherit target) (inherit target)
(device (or device (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) (and path ((assoc-mnt mount-source)
(unfold-pathcat target targets))))) (unfold-pathcat target targets)))))
(label (or label (accessible=> device read-partition-label))) (file-system (or file-system
(uuid (or uuid (accessible=> device read-partition-uuid))) (match device
(file-system (or file-system (and=> device (assoc-mnt mount-type)))) ((? string?) ((assoc-mnt mount-type) device))
((? uuid?) (uuid->file-system device))
(_ #f))))
(offset (and path offset)) (offset (and path offset))
(path (or path (and=> device (assoc-mnt mount-point)))))))) (path (or path (and=> device (assoc-mnt mount-point))))))))
(let ((mid (map (compose fixuuid scrape) targets))) (let ((mid (map scrape targets)))
(map (cut arborify <> mid) mid)))) (map (cut arborify <> mid) mid))))
(define* (bootloader-configuration->gexp bootloader-config args #:key (define* (bootloader-configuration->gexp bootloader-config args #:key

4
gnu/system/image.scm
View file

@ -389,8 +389,8 @@ (define (targets current)
(path (and current? "tmp-root")) (path (and current? "tmp-root"))
(offset #f) (offset #f)
(file-system (partition-file-system partition)) (file-system (partition-file-system partition))
(label (partition-label partition)) (device (or (partition-uuid partition)
(uuid (partition-uuid partition))))) (partition-label partition))))))
(filter partition-target (image-partitions image))))) (filter partition-target (image-partitions image)))))
(define (image->genimage-cfg image) (define (image->genimage-cfg image)