aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--gnu/build/file-systems.scm112
1 files changed, 95 insertions, 17 deletions
diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm
index 9af4f5ad1b..f277cbfa34 100644
--- a/gnu/build/file-systems.scm
+++ b/gnu/build/file-systems.scm
@@ -32,8 +32,10 @@
#:export (disk-partitions
partition-label-predicate
partition-uuid-predicate
+ partition-luks-uuid-predicate
find-partition-by-label
find-partition-by-uuid
+ find-partition-by-luks-uuid
canonicalize-device-spec
uuid->string
@@ -79,6 +81,11 @@
"Bind-mount SOURCE at TARGET."
(mount source target "" MS_BIND))
+
+;;;
+;;; Ext2 file systems.
+;;;
+
(define-syntax %ext2-endianness
;; Endianness of ext2 file systems.
(identifier-syntax (endianness little)))
@@ -136,6 +143,63 @@ if DEVICE does not contain an ext2 file system."
#f
(list->string (map integer->char bytes))))))
+
+;;;
+;;; LUKS encrypted devices.
+;;;
+
+;; The LUKS header format is described in "LUKS On-Disk Format Specification":
+;; <http://wiki.cryptsetup.googlecode.com/git/LUKS-standard/>. We follow
+;; version 1.2.1 of this document.
+
+(define-syntax %luks-endianness
+ ;; Endianness of LUKS headers.
+ (identifier-syntax (endianness big)))
+
+(define-syntax %luks-header-size
+ ;; Size in bytes of the LUKS header, including key slots.
+ (identifier-syntax 592))
+
+(define %luks-magic
+ ;; The 'LUKS_MAGIC' constant.
+ (u8-list->bytevector (append (map char->integer (string->list "LUKS"))
+ (list #xba #xbe))))
+
+(define (sub-bytevector bv start size)
+ "Return a copy of the SIZE bytes of BV starting from offset START."
+ (let ((result (make-bytevector size)))
+ (bytevector-copy! bv start result 0 size)
+ result))
+
+(define (read-luks-header file)
+ "Read a LUKS header from FILE. Return the raw header on success, and #f if
+not valid header was found."
+ (call-with-input-file file
+ (lambda (port)
+ (let ((header (make-bytevector %luks-header-size)))
+ (match (get-bytevector-n! port header 0 (bytevector-length header))
+ ((? eof-object?)
+ #f)
+ ((? number? len)
+ (and (= len (bytevector-length header))
+ (let ((magic (sub-bytevector header 0 6)) ;XXX: inefficient
+ (version (bytevector-u16-ref header 6 %luks-endianness)))
+ (and (bytevector=? magic %luks-magic)
+ (= version 1)
+ header)))))))))
+
+(define (luks-header-uuid header)
+ "Return the LUKS UUID from HEADER, as a 16-byte bytevector."
+ ;; 40 bytes are reserved for the UUID, but in practice, it contains the 36
+ ;; bytes of its ASCII representation.
+ (let ((uuid (sub-bytevector header 168 36)))
+ (string->uuid (utf8->string uuid))))
+
+
+;;;
+;;; Partition lookup.
+;;;
+
(define (disk-partitions)
"Return the list of device names corresponding to valid disk partitions."
(define (partition? major minor)
@@ -185,28 +249,35 @@ warning and #f as the result."
#f)
(apply throw args))))))
-(define read-ext2-superblock*
- (ENOENT-safe read-ext2-superblock))
-
-(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\",
+(define (partition-predicate read field =)
+ "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-ext2-superblock* device)))
- (and sblock
- (let ((actual (field sblock)))
- (and actual
- (= actual expected))))))))
+ (lambda (part)
+ (let* ((device (string-append "/dev/" part))
+ (sblock (read device)))
+ (and sblock
+ (let ((actual (field sblock)))
+ (and actual
+ (= actual expected)))))))))
(define partition-label-predicate
- (partition-predicate ext2-superblock-volume-name string=?))
+ (partition-predicate read-ext2-superblock
+ ext2-superblock-volume-name
+ string=?))
(define partition-uuid-predicate
- (partition-predicate ext2-superblock-uuid bytevector=?))
+ (partition-predicate read-ext2-superblock
+ ext2-superblock-uuid
+ bytevector=?))
+
+(define partition-luks-uuid-predicate
+ (partition-predicate 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
@@ -222,6 +293,13 @@ or #f if none was found."
(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 (partition-luks-uuid-predicate uuid)
+ (disk-partitions))
+ (cut string-append "/dev/" <>)))
+
;;;
;;; UUIDs.