mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 13:28:12 -05:00
file-systems: Implement partition lookup by UUID.
* gnu/build/file-systems.scm (read-ext2-superblock*, partition-predicate): New procedures. (partition-label-predicate): Rewrite in terms of 'partition-predicate'. (partition-uuid-predicate, find-partition-by-uuid, uuid->string): New procedures. (%network-byte-order): New macro. (canonicalize-device-spec)[canonical-title]: Check whether SPEC is a string. [resolve]: New procedure. Add 'uuid' case and use it.
This commit is contained in:
parent
f868637527
commit
0ec5ee9486
1 changed files with 85 additions and 39 deletions
|
@ -22,13 +22,16 @@ (define-module (gnu build file-systems)
|
|||
#:use-module (rnrs bytevectors)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (ice-9 rdelim)
|
||||
#:use-module (ice-9 format)
|
||||
#:use-module (system foreign)
|
||||
#:autoload (system repl repl) (start-repl)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (srfi srfi-26)
|
||||
#:export (disk-partitions
|
||||
partition-label-predicate
|
||||
partition-uuid-predicate
|
||||
find-partition-by-label
|
||||
find-partition-by-uuid
|
||||
canonicalize-device-spec
|
||||
|
||||
MS_RDONLY
|
||||
|
@ -159,29 +162,42 @@ (define (partition? major minor)
|
|||
(loop (cons name parts))
|
||||
(loop parts))))))))))
|
||||
|
||||
(define (partition-label-predicate label)
|
||||
"Return a procedure that, when applied to a partition name such as \"sda1\",
|
||||
return #t if that partition's volume name is LABEL."
|
||||
(lambda (part)
|
||||
(let* ((device (string-append "/dev/" part))
|
||||
(sblock (catch 'system-error
|
||||
(lambda ()
|
||||
(read-ext2-superblock device))
|
||||
(lambda args
|
||||
;; When running on the hand-made /dev,
|
||||
;; 'disk-partitions' could return partitions for which
|
||||
;; we have no /dev node. Handle that gracefully.
|
||||
(if (= ENOENT (system-error-errno args))
|
||||
(begin
|
||||
(format (current-error-port)
|
||||
"warning: device '~a' not found~%"
|
||||
device)
|
||||
#f)
|
||||
(apply throw args))))))
|
||||
(and sblock
|
||||
(let ((volume (ext2-superblock-volume-name sblock)))
|
||||
(and volume
|
||||
(string=? volume label)))))))
|
||||
(define (read-ext2-superblock* device)
|
||||
"Like 'read-ext2-superblock', but return #f when DEVICE does not exist
|
||||
instead of throwing an exception."
|
||||
(catch 'system-error
|
||||
(lambda ()
|
||||
(read-ext2-superblock device))
|
||||
(lambda args
|
||||
;; When running on the hand-made /dev,
|
||||
;; 'disk-partitions' could return partitions for which
|
||||
;; we have no /dev node. Handle that gracefully.
|
||||
(if (= ENOENT (system-error-errno args))
|
||||
(begin
|
||||
(format (current-error-port)
|
||||
"warning: device '~a' not found~%" device)
|
||||
#f)
|
||||
(apply throw args)))))
|
||||
|
||||
(define (partition-predicate field =)
|
||||
"Return a predicate that returns true if the FIELD of an ext2 superblock is
|
||||
= to the given value."
|
||||
(lambda (expected)
|
||||
"Return a procedure that, when applied to a partition name such as \"sda1\",
|
||||
returns #t if that partition's volume name is LABEL."
|
||||
(lambda (part)
|
||||
(let* ((device (string-append "/dev/" part))
|
||||
(sblock (read-ext2-superblock* device)))
|
||||
(and sblock
|
||||
(let ((actual (field sblock)))
|
||||
(and actual
|
||||
(= actual expected))))))))
|
||||
|
||||
(define partition-label-predicate
|
||||
(partition-predicate ext2-superblock-volume-name string=?))
|
||||
|
||||
(define partition-uuid-predicate
|
||||
(partition-predicate ext2-superblock-uuid bytevector=?))
|
||||
|
||||
(define (find-partition-by-label label)
|
||||
"Return the first partition found whose volume name is LABEL, or #f if none
|
||||
|
@ -190,6 +206,28 @@ (define (find-partition-by-label label)
|
|||
(disk-partitions))
|
||||
(cut string-append "/dev/" <>)))
|
||||
|
||||
(define (find-partition-by-uuid uuid)
|
||||
"Return the first partition whose unique identifier is UUID (a bytevector),
|
||||
or #f if none was found."
|
||||
(and=> (find (partition-uuid-predicate uuid)
|
||||
(disk-partitions))
|
||||
(cut string-append "/dev/" <>)))
|
||||
|
||||
(define-syntax %network-byte-order
|
||||
(identifier-syntax (endianness big)))
|
||||
|
||||
(define (uuid->string uuid)
|
||||
"Convert UUID, a 16-byte bytevector, to its string representation, something
|
||||
like \"6b700d61-5550-48a1-874c-a3d86998990e\"."
|
||||
;; See <https://tools.ietf.org/html/rfc4122>.
|
||||
(let ((time-low (bytevector-uint-ref uuid 0 %network-byte-order 4))
|
||||
(time-mid (bytevector-uint-ref uuid 4 %network-byte-order 2))
|
||||
(time-hi (bytevector-uint-ref uuid 6 %network-byte-order 2))
|
||||
(clock-seq (bytevector-uint-ref uuid 8 %network-byte-order 2))
|
||||
(node (bytevector-uint-ref uuid 10 %network-byte-order 6)))
|
||||
(format #f "~8,'0x-~4,'0x-~4,'0x-~4,'0x-~12,'0x"
|
||||
time-low time-mid time-hi clock-seq node)))
|
||||
|
||||
(define* (canonicalize-device-spec spec #:optional (title 'any))
|
||||
"Return the device name corresponding to SPEC. TITLE is a symbol, one of
|
||||
the following:
|
||||
|
@ -198,6 +236,8 @@ (define* (canonicalize-device-spec spec #:optional (title 'any))
|
|||
\"/dev/sda1\";
|
||||
• 'label', in which case SPEC is known to designate a partition label--e.g.,
|
||||
\"my-root-part\";
|
||||
• 'uuid', in which case SPEC must be a UUID (a 16-byte bytevector)
|
||||
designating a partition;
|
||||
• 'any', in which case SPEC can be anything.
|
||||
"
|
||||
(define max-trials
|
||||
|
@ -210,30 +250,36 @@ (define max-trials
|
|||
(define canonical-title
|
||||
;; The realm of canonicalization.
|
||||
(if (eq? title 'any)
|
||||
(if (string-prefix? "/" spec)
|
||||
'device
|
||||
'label)
|
||||
(if (string? spec)
|
||||
(if (string-prefix? "/" spec)
|
||||
'device
|
||||
'label)
|
||||
'uuid)
|
||||
title))
|
||||
|
||||
(define (resolve find-partition spec fmt)
|
||||
(let loop ((count 0))
|
||||
(let ((device (find-partition spec)))
|
||||
(or device
|
||||
;; Some devices take a bit of time to appear, most notably USB
|
||||
;; storage devices. Thus, wait for the device to appear.
|
||||
(if (> count max-trials)
|
||||
(error "failed to resolve partition" (fmt spec))
|
||||
(begin
|
||||
(format #t "waiting for partition '~a' to appear...~%"
|
||||
(fmt spec))
|
||||
(sleep 1)
|
||||
(loop (+ 1 count))))))))
|
||||
|
||||
(case canonical-title
|
||||
((device)
|
||||
;; Nothing to do.
|
||||
spec)
|
||||
((label)
|
||||
;; Resolve the label.
|
||||
(let loop ((count 0))
|
||||
(let ((device (find-partition-by-label spec)))
|
||||
(or device
|
||||
;; Some devices take a bit of time to appear, most notably USB
|
||||
;; storage devices. Thus, wait for the device to appear.
|
||||
(if (> count max-trials)
|
||||
(error "failed to resolve partition label" spec)
|
||||
(begin
|
||||
(format #t "waiting for partition '~a' to appear...~%"
|
||||
spec)
|
||||
(sleep 1)
|
||||
(loop (+ 1 count))))))))
|
||||
;; TODO: Add support for UUIDs.
|
||||
(resolve find-partition-by-label spec identity))
|
||||
((uuid)
|
||||
(resolve find-partition-by-uuid spec uuid->string))
|
||||
(else
|
||||
(error "unknown device title" title))))
|
||||
|
||||
|
|
Loading…
Reference in a new issue