aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--gnu/build/file-systems.scm99
1 files changed, 58 insertions, 41 deletions
diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm
index d753b6b792..e76854490c 100644
--- a/gnu/build/file-systems.scm
+++ b/gnu/build/file-systems.scm
@@ -1,6 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
-;;; Copyright © 2016 David Craven <david@craven.ch>
+;;; Copyright © 2016, 2017 David Craven <david@craven.ch>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -238,56 +238,73 @@ warning and #f as the result."
(else
(apply throw args))))))))
-(define (partition-predicate read field =)
+(define (partition-field-reader read field)
+ "Return a procedure that takes a device and returns the value of a FIELD in
+the partition superblock or #f."
+ (let ((read (ENOENT-safe read)))
+ (lambda (device)
+ (let ((sblock (read device)))
+ (and sblock
+ (field sblock))))))
+
+(define (read-partition-field device partition-field-readers)
+ "Returns the value of a FIELD in the partition superblock of DEVICE or #f. It
+takes a list of PARTITION-FIELD-READERS and returns the result of the first
+partition field reader that returned a value."
+ (match (filter-map (cut apply <> (list device)) partition-field-readers)
+ ((field . _) field)
+ (_ #f)))
+
+(define %partition-label-readers
+ (list (partition-field-reader read-ext2-superblock
+ ext2-superblock-volume-name)))
+
+(define %partition-uuid-readers
+ (list (partition-field-reader read-ext2-superblock
+ ext2-superblock-uuid)))
+
+(define read-partition-label
+ (cut read-partition-field <> %partition-label-readers))
+
+(define read-partition-uuid
+ (cut read-partition-field <> %partition-uuid-readers))
+
+(define (partition-predicate reader =)
"Return a predicate that returns true if the FIELD of partition header that
was READ is = to the given value."
- (let ((read (ENOENT-safe read)))
- (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 device)))
- (and sblock
- (let ((actual (field sblock)))
- (and actual
- (= actual expected)))))))))
+ (lambda (expected)
+ (lambda (device)
+ (let ((actual (reader device)))
+ (and actual
+ (= actual expected))))))
(define partition-label-predicate
- (partition-predicate read-ext2-superblock
- ext2-superblock-volume-name
- string=?))
+ (partition-predicate read-partition-label string=?))
(define partition-uuid-predicate
- (partition-predicate read-ext2-superblock
- ext2-superblock-uuid
- bytevector=?))
+ (partition-predicate read-partition-uuid bytevector=?))
(define luks-partition-uuid-predicate
- (partition-predicate read-luks-header
- luks-header-uuid
- bytevector=?))
+ (partition-predicate
+ (partition-field-reader read-luks-header luks-header-uuid)
+ bytevector=?))
-(define (find-partition-by-label label)
- "Return the first partition found whose volume name is LABEL, or #f if none
+(define (find-partition predicate)
+ "Return the first partition found that matches PREDICATE, or #f if none
were found."
- (and=> (find (partition-label-predicate 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 (find-partition-by-luks-uuid uuid)
- "Return the first LUKS partition whose unique identifier is UUID (a bytevector),
-or #f if none was found."
- (and=> (find (luks-partition-uuid-predicate uuid)
- (disk-partitions))
- (cut string-append "/dev/" <>)))
+ (lambda (expected)
+ (find (predicate expected)
+ (map (cut string-append "/dev/" <>)
+ (disk-partitions)))))
+
+(define find-partition-by-label
+ (find-partition partition-label-predicate))
+
+(define find-partition-by-uuid
+ (find-partition partition-uuid-predicate))
+
+(define find-partition-by-luks-uuid
+ (find-partition luks-partition-uuid-predicate))
;;;