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

gnu: bootloader: Add find-mount procedure.

Browse source 
* gnu/bootloader.scm (find-mount, find-file-system, label->uuid,
uuid->file-system, mount-point->block-device): Add procedures.
This commit is contained in:
Herman Rimm 2024-09-29 13:31:21 +02:00 committed by Ryan Schanzenbacher
parent 5b7b514e4d
commit 3f3ce48900
Signed by: ryan77627
GPG key ID: 81B0E222A3E2308E
1 changed files with 43 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

43
gnu/bootloader.scm
View file

@ -88,6 +88,12 @@ (define-module (gnu bootloader)
target-error-type
target-error-targets
find-mount
find-file-system
label->uuid
uuid->file-system
mount-point->block-device
gbegin
:path :devpath :device :fs :label :uuid
with-targets
@ -318,6 +324,43 @@ (define-condition-type &target-error &error target-error?
(type target-error-type)
(targets target-error-targets))
;; XXX: Use a more appropriate name than FS?
(define (find-mount block-device-or-fs)
"Return the <mount> record with source BLOCK-DEVICE-OR-FS, or #f
otherwise. An FS could be efivarsfs, cgroup etc.."
(define (block-device-or-fs? mount)
(and (string=? block-device-or-fs (mount-source mount)) mount))
;; A mount source is either a block device or an FS.
(when (and (not (string-prefix? "/dev/" block-device-or-fs))
(or (string-contains "/" block-device-or-fs)
(string=? "none" block-device-or-fs)))
(error (G_ "not a block device with mount~%") block-device-or-fs))
(any block-device-or-fs? (mounts)))
(define (find-file-system block-device)
"Detects the type of a given block device. Return #f if not found."
(and=> (find-mount block-device) mount-type))
(define (label->uuid label)
(and=> (find-partition-by-label (file-system-label->string label))
read-partition-uuid))
(define (uuid->file-system uuid)
"Returns the UUID's type as a string. Does not depend on current
mounts, unlike find-file-system. Use together with the find-uuid, or
label->uuid procedure."
(symbol->string (uuid-type uuid)))
;; TODO: Test together with find-mount.
(define (mount-point->block-device point)
"Return the block device mounted on POINT, or #f otherwise."
(define (point? mount)
(and (string=? point (mount-point mount)) (mount-source mount)))
;; A mount point is an absolute path.
(unless (string-prefix? "/" point)
(error (G_ "mount point is not an absolute path~%") point))
(any point? (mounts)))
(define (pathcat p1 p2)
(string-append (string-trim-right p1 #\/) "/" (string-trim p2 #\/)))