file-systems: Refactor file system detection logic.

* gnu/build/file-systems.scm (read-superblock,
  null-terminated-latin1->string): New variables.
  (sub-bytevector): Move to general section.
  (ext2-superblock?, read-ext2-superblock): New variables.
  (ext2-superblock-uuid, ext2-superblock-volume-name): Use
  sub-bytevector and null-terminated-latin1->string.
  (%ext2-sblock-magic, %ext2-sblock-creator-os, %ext2-sblock-uuid,
  %ext2-sblock-volume-name): Inline constants.
  (luks-superblock?, read-luks-header): New variables.
  (%luks-header-size, %luks-magic): Inline.
  (partition-label-predicate, partition-uuid-predicate,
  luks-partition-uuid-predicate): Use new functions.

gnu/build/file-systems.scm

@@ -1,5 +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>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -71,67 +72,69 @@
   "Bind-mount SOURCE at TARGET."
   (mount source target "" MS_BIND))
 
+(define (read-superblock device offset size magic?)
+  "Read a superblock of SIZE from OFFSET and DEVICE.  Return the raw
+superblock on success, and #f if no valid superblock was found.  MAGIC?
+takes a bytevector and returns #t when it's a valid superblock."
+  (call-with-input-file device
+    (lambda (port)
+      (seek port offset SEEK_SET)
+
+      (let ((block (make-bytevector size)))
+        (match (get-bytevector-n! port block 0 (bytevector-length block))
+          ((? eof-object?)
+           #f)
+          ((? number? len)
+           (and (= len (bytevector-length block))
+                (and (magic? block)
+                     block))))))))
+
+(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 (null-terminated-latin1->string bv)
+  "Return the volume name of SBLOCK as a string of at most 256 characters, or
+#f if SBLOCK has no volume name."
+    ;; This is a Latin-1, nul-terminated string.
+    (let ((bytes (take-while (negate zero?) (bytevector->u8-list bv))))
+      (if (null? bytes)
+          #f
+          (list->string (map integer->char bytes)))))
+
 
 ;;;
 ;;; Ext2 file systems.
 ;;;
 
+;; <http://www.nongnu.org/ext2-doc/ext2.html#DEF-SUPERBLOCK>.
+;; TODO: Use "packed structs" from Guile-OpenGL or similar.
+
 (define-syntax %ext2-endianness
   ;; Endianness of ext2 file systems.
   (identifier-syntax (endianness little)))
 
-;; Offset in bytes of interesting parts of an ext2 superblock.  See
+(define (ext2-superblock? sblock)
-;; <http://www.nongnu.org/ext2-doc/ext2.html#DEF-SUPERBLOCK>.
+  "Return #t when SBLOCK is an ext2 superblock."
-;; TODO: Use "packed structs" from Guile-OpenGL or similar.
+  (let ((magic (bytevector-u16-ref sblock 56 %ext2-endianness)))
-(define-syntax %ext2-sblock-magic       (identifier-syntax 56))
+    (= magic #xef53)))
-(define-syntax %ext2-sblock-creator-os  (identifier-syntax 72))
-(define-syntax %ext2-sblock-uuid        (identifier-syntax 104))
-(define-syntax %ext2-sblock-volume-name (identifier-syntax 120))
 
 (define (read-ext2-superblock device)
   "Return the raw contents of DEVICE's ext2 superblock as a bytevector, or #f
 if DEVICE does not contain an ext2 file system."
-  (define %ext2-magic
+  (read-superblock device 1024 264 ext2-superblock?))
-    ;; The magic bytes that identify an ext2 file system.
-    #xef53)
-
-  (define superblock-size
-    ;; Size of the interesting part of an ext2 superblock.
-    264)
-
-  (define block
-    ;; The superblock contents.
-    (make-bytevector superblock-size))
-
-  (call-with-input-file device
-    (lambda (port)
-      (seek port 1024 SEEK_SET)
-
-      ;; Note: work around <http://bugs.gnu.org/17466>.
-      (and (eqv? superblock-size (get-bytevector-n! port block 0
-                                                    superblock-size))
-           (let ((magic (bytevector-u16-ref block %ext2-sblock-magic
-                                            %ext2-endianness)))
-             (and (= magic %ext2-magic)
-                  block))))))
 
 (define (ext2-superblock-uuid sblock)
   "Return the UUID of ext2 superblock SBLOCK as a 16-byte bytevector."
-  (let ((uuid (make-bytevector 16)))
+  (sub-bytevector sblock 104 16))
-    (bytevector-copy! sblock %ext2-sblock-uuid uuid 0 16)
-    uuid))
 
 (define (ext2-superblock-volume-name sblock)
   "Return the volume name of SBLOCK as a string of at most 16 characters, or
 #f if SBLOCK has no volume name."
-  (let ((bv (make-bytevector 16)))
+  (null-terminated-latin1->string (sub-bytevector sblock 120 16)))
-    (bytevector-copy! sblock %ext2-sblock-volume-name bv 0 16)
 
-    ;; This is a Latin-1, nul-terminated string.
-    (let ((bytes (take-while (negate zero?) (bytevector->u8-list bv))))
-      (if (null? bytes)
-          #f
-          (list->string (map integer->char bytes))))))
 
 
 ;;;
@@ -146,37 +149,22 @@ if DEVICE does not contain an ext2 file system."
   ;; Endianness of LUKS headers.
   (identifier-syntax (endianness big)))
 
-(define-syntax %luks-header-size
+(define (luks-superblock? sblock)
-  ;; Size in bytes of the LUKS header, including key slots.
+  "Return #t when SBLOCK is a luks superblock."
-  (identifier-syntax 592))
+  (define %luks-magic
-
+    ;; The 'LUKS_MAGIC' constant.
-(define %luks-magic
+    (u8-list->bytevector (append (map char->integer (string->list "LUKS"))
-  ;; The 'LUKS_MAGIC' constant.
+                                 (list #xba #xbe))))
-  (u8-list->bytevector (append (map char->integer (string->list "LUKS"))
+  (let ((magic   (sub-bytevector sblock 0 6))
-                               (list #xba #xbe))))
+        (version (bytevector-u16-ref sblock 6 %luks-endianness)))
-
+    (and (bytevector=? magic %luks-magic)
-(define (sub-bytevector bv start size)
+         (= version 1))))
-  "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
+  ;; Size in bytes of the LUKS header, including key slots.
-    (lambda (port)
+  (read-superblock file 0 592 luks-superblock?))
-      (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."
@@ -267,7 +255,7 @@ returns #t if that partition's volume name is LABEL."
                        ext2-superblock-uuid
                        bytevector=?))
 
-(define partition-luks-uuid-predicate
+(define luks-partition-uuid-predicate
   (partition-predicate read-luks-header
                        luks-header-uuid
                        bytevector=?))
@@ -289,7 +277,7 @@ or #f if none was found."
 (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)
+  (and=> (find (luks-partition-uuid-predicate uuid)
                (disk-partitions))
          (cut string-append "/dev/" <>)))