file-systems: Add 'find-partition-by-luks-uuid'.

* gnu/build/file-systems.scm (%luks-endianness, %luks-header-size): New
macros.
(%luks-magic): New variable.
(sub-bytevector, read-luks-header, luks-header-uuid): New procedures.
(partition-predicate): Add 'read' parameter; wrap it with 'ENOENT-safe'.
Use it instead of 'read-ext2-superblock*'.
(read-ext2-superblock*): Remove.
(partition-label-predicate, partition-uuid-predicate): Pass
'read-ext2-superblock' as the first argument.
(partition-luks-uuid-predicate): New variable.
(find-partition-by-luks-uuid): New procedure.

gnu/build/file-systems.scm

@@ -32,8 +32,10 @@ (define-module (gnu build file-systems)
   #: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 @@ (define (bind-mount source target)
   "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 @@ (define (ext2-superblock-volume-name sblock)
           #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 @@ (define (ENOENT-safe proc)
               #f)
             (apply throw args))))))
 
-(define read-ext2-superblock*
+(define (partition-predicate read field =)
-  (ENOENT-safe read-ext2-superblock))
+  "Return a predicate that returns true if the FIELD of partition header that
-
+was READ is = to the given value."
-(define (partition-predicate field =)
+  (let ((read (ENOENT-safe read)))
-  "Return a predicate that returns true if the FIELD of an ext2 superblock is
+    (lambda (expected)
-= to the given value."
+      "Return a procedure that, when applied to a partition name such as \"sda1\",
-  (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)
+      (lambda (part)
-      (let* ((device (string-append "/dev/" part))
+        (let* ((device (string-append "/dev/" part))
-             (sblock (read-ext2-superblock* device)))
+               (sblock (read device)))
-        (and sblock
+          (and sblock
-             (let ((actual (field sblock)))
+               (let ((actual (field sblock)))
-               (and actual
+                 (and actual
-                    (= actual expected))))))))
+                      (= 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 @@ (define (find-partition-by-uuid 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 (partition-luks-uuid-predicate uuid)
+               (disk-partitions))
+         (cut string-append "/dev/" <>)))
+
 
 ;;;
 ;;; UUIDs.