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-device
bootloader-target-file-system
bootloader-target-label
bootloader-target-uuid
target-error?
target-error-type
@ -317,8 +315,9 @@ (define (symbol-or-boolean? x)
(define (file-system-label-or-boolean? x)
(or (file-system-label? x) (boolean? x)))
(define (uuid-or-boolean? x)
(or (uuid? x) (boolean? x)))
;; TODO: Create wrapper record for block-device.
(define (uuid-or-string-or-boolean? x)
(or (uuid? x) (string? x) (boolean? x)))
(define-configuration/no-serialization bootloader-target
(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")
(offset (symbol-or-boolean #f) "TODO")
(device
(string-or-boolean #f)
(uuid-or-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
@ -335,9 +334,7 @@ (define-configuration/no-serialization bootloader-target
(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"))
the find-file-system and uuid->file-system procedures."))
(define-condition-type &target-error &error target-error?
(type target-error-type)
@ -410,8 +407,8 @@ (define (unfold-pathcat target targets)
(define (target-base? t)
(or (not t) (match-record t <bootloader-target>
(expected? offset device label uuid)
(or device label uuid (not offset) expected?))))
(expected? offset device)
(or device (not offset) expected?))))
(define (type-major? target) (memq target '(root esp disk)))
@ -464,9 +461,15 @@ (define (resolve in target base)
(:path :devpath :device :fs :label :uuid)
((name _) (not (identifier? #'name))
#`(_ (syntax-error "binds must be to identifiers" #,in)))
((name :device) #'(name (bootloader-target-device base)))
((name :label) #'(name (bootloader-target-label base)))
((name :uuid) #'(name (bootloader-target-uuid base)))
((name :device)
#'(name (and (string? (bootloader-target-device 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 :path) #'(name (unfold-pathcat target targets)))
((name :devpath)
@ -650,22 +653,6 @@ (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))
@ -681,23 +668,22 @@ (define (assoc-mnt f)
(define (scrape target)
(match-record target <bootloader-target>
(expected? path offset device label uuid file-system)
(expected? path offset device 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))))
(file-system (or file-system
(match device
((? string?) ((assoc-mnt mount-type) device))
((? uuid?) (uuid->file-system device))
(_ #f))))
(offset (and path offset))
(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))))
(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"))
(offset #f)
(file-system (partition-file-system partition))
(label (partition-label partition))
(uuid (partition-uuid partition)))))
(device (or (partition-uuid partition)
(partition-label partition))))))
(filter partition-target (image-partitions image)))))
(define (image->genimage-cfg image)