nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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:
Ludovic Courtès 2015-07-14 12:34:38 +02:00
parent f868637527
commit 0ec5ee9486
1 changed files with 85 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

124
gnu/build/file-systems.scm
View File

@ -22,13 +22,16 @@
#:use-module (rnrs bytevectors) #:use-module (rnrs bytevectors)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (ice-9 rdelim) #:use-module (ice-9 rdelim)
#:use-module (ice-9 format)
#:use-module (system foreign) #:use-module (system foreign)
#:autoload (system repl repl) (start-repl) #:autoload (system repl repl) (start-repl)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:export (disk-partitions #:export (disk-partitions
partition-label-predicate partition-label-predicate
partition-uuid-predicate
find-partition-by-label find-partition-by-label
find-partition-by-uuid
canonicalize-device-spec canonicalize-device-spec
MS_RDONLY MS_RDONLY
@ -159,29 +162,42 @@ if DEVICE does not contain an ext2 file system."
(loop (cons name parts)) (loop (cons name parts))
(loop parts)))))))))) (loop parts))))))))))
(define (partition-label-predicate label) (define (read-ext2-superblock* device)
"Return a procedure that, when applied to a partition name such as \"sda1\", "Like 'read-ext2-superblock', but return #f when DEVICE does not exist
return #t if that partition's volume name is LABEL." instead of throwing an exception."
(lambda (part) (catch 'system-error
(let* ((device (string-append "/dev/" part)) (lambda ()
(sblock (catch 'system-error (read-ext2-superblock device))
(lambda () (lambda args
(read-ext2-superblock device)) ;; When running on the hand-made /dev,
(lambda args ;; 'disk-partitions' could return partitions for which
;; When running on the hand-made /dev, ;; we have no /dev node. Handle that gracefully.
;; 'disk-partitions' could return partitions for which (if (= ENOENT (system-error-errno args))
;; we have no /dev node. Handle that gracefully. (begin
(if (= ENOENT (system-error-errno args)) (format (current-error-port)
(begin "warning: device '~a' not found~%" device)
(format (current-error-port) #f)
"warning: device '~a' not found~%" (apply throw args)))))
device)
#f) (define (partition-predicate field =)
(apply throw args)))))) "Return a predicate that returns true if the FIELD of an ext2 superblock is
(and sblock = to the given value."
(let ((volume (ext2-superblock-volume-name sblock))) (lambda (expected)
(and volume "Return a procedure that, when applied to a partition name such as \"sda1\",
(string=? volume label))))))) 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) (define (find-partition-by-label label)
"Return the first partition found whose volume name is LABEL, or #f if none "Return the first partition found whose volume name is LABEL, or #f if none
@ -190,6 +206,28 @@ were found."
(disk-partitions)) (disk-partitions))
(cut string-append "/dev/" <>))) (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)) (define* (canonicalize-device-spec spec #:optional (title 'any))
"Return the device name corresponding to SPEC. TITLE is a symbol, one of "Return the device name corresponding to SPEC. TITLE is a symbol, one of
the following: the following:
@ -198,6 +236,8 @@ the following:
\"/dev/sda1\"; \"/dev/sda1\";
• 'label', in which case SPEC is known to designate a partition label--e.g., • 'label', in which case SPEC is known to designate a partition label--e.g.,
\"my-root-part\"; \"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. • 'any', in which case SPEC can be anything.
" "
(define max-trials (define max-trials
@ -210,30 +250,36 @@ the following:
(define canonical-title (define canonical-title
;; The realm of canonicalization. ;; The realm of canonicalization.
(if (eq? title 'any) (if (eq? title 'any)
(if (string-prefix? "/" spec) (if (string? spec)
'device (if (string-prefix? "/" spec)
'label) 'device
'label)
'uuid)
title)) 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 (case canonical-title
((device) ((device)
;; Nothing to do. ;; Nothing to do.
spec) spec)
((label) ((label)
;; Resolve the label. ;; Resolve the label.
(let loop ((count 0)) (resolve find-partition-by-label spec identity))
(let ((device (find-partition-by-label spec))) ((uuid)
(or device (resolve find-partition-by-uuid spec uuid->string))
;; 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.
(else (else
(error "unknown device title" title)))) (error "unknown device title" title))))