diff options
| -rw-r--r-- | gnu/build/file-systems.scm | 124 |
1 files changed, 85 insertions, 39 deletions
diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm index 5814caf215..c58d23cfbd 100644 --- a/gnu/build/file-systems.scm +++ b/gnu/build/file-systems.scm @@ -22,13 +22,16 @@ #: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 @@ if DEVICE does not contain an ext2 file system." (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 @@ were found." (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 @@ the following: \"/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 @@ the following: (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)))) |