Merge branch 'master' into core-updates

1 files changed, 67 insertions, 21 deletions

diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm
index fe98df95d5..47aa77dd3e 100644
--- a/gnu/build/file-systems.scm
+++ b/gnu/build/file-systems.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2016, 2017 David Craven <david@craven.ch>
+;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -47,12 +48,7 @@
 
             mount-flags->bit-mask
             check-file-system
-            mount-file-system)
-  #:re-export (mount
-               umount
-               MS_BIND
-               MS_MOVE
-               MS_RDONLY))
+            mount-file-system))
 
 ;;; Commentary:
 ;;;
@@ -61,13 +57,6 @@
 ;;;
 ;;; Code:
 
-;; 'mount' is already defined in the statically linked Guile used for initial
-;; RAM disks, in which case the bindings in (guix build syscalls) do not work
-;; (the FFI bindings do not work there).  Override them in that case.
-(when (module-defined? the-scm-module 'mount)
-  (set! mount (@ (guile) mount))
-  (set! umount (@ (guile) umount)))
-
 (define (bind-mount source target)
   "Bind-mount SOURCE at TARGET."
   (mount source target "" MS_BIND))
@@ -241,6 +230,63 @@ Trailing spaces are trimmed."
 
 
 ;;;
+;;; ISO9660 file systems.
+;;;
+
+;; <http://www.ecma-international.org/publications/files/ECMA-ST/Ecma-119.pdf>.
+
+(define (iso9660-superblock? sblock)
+  "Return #t when SBLOCK is a iso9660 superblock."
+  (bytevector=? (sub-bytevector sblock 1 6)
+                ;; Note: "\x01" is the volume descriptor format version
+                (string->utf8 "CD001\x01")))
+
+(define (read-iso9660-primary-volume-descriptor device offset)
+  "Find and read the first primary volume descriptor, starting at OFFSET.
+   Return #f if not found."
+  (let* ((sblock    (read-superblock device offset 2048 iso9660-superblock?))
+         (type-code (if sblock (array-ref sblock 0) 255)))
+    (match type-code
+      (255 #f) ; Volume Descriptor Set Terminator.
+      (1 sblock) ; Primary Volume Descriptor
+      (_ (read-iso9660-primary-volume-descriptor device (+ offset 2048))))))
+
+(define (read-iso9660-superblock device)
+  "Return the raw contents of DEVICE's iso9660 superblock as a bytevector, or
+#f if DEVICE does not contain a iso9660 file system."
+  ;; Start reading at sector 16.
+  (read-iso9660-primary-volume-descriptor device (* 2048 16)))
+
+(define (iso9660-superblock-uuid sblock)
+  "Return the modification time of a iso9660 superblock SBLOCK as a bytevector."
+  ;; Drops GMT offset for compatibility with Grub, blkid and /dev/disk/by-uuid.
+  ;; Compare Grub: "2014-12-02-19-30-23-00".
+  ;; Compare blkid result: "2014-12-02-19-30-23-00".
+  ;; Compare /dev/disk/by-uuid entry: "2014-12-02-19-30-23-00".
+  (sub-bytevector sblock 830 16))
+
+(define (iso9660-uuid->string uuid)
+  "Given an UUID bytevector, return its timestamp string."
+  (define (digits->string bytes)
+    (latin1->string bytes (lambda (c) #f)))
+  (let* ((year (sub-bytevector uuid 0 4))
+         (month (sub-bytevector uuid 4 2))
+         (day (sub-bytevector uuid 6 2))
+         (hour (sub-bytevector uuid 8 2))
+         (minute (sub-bytevector uuid 10 2))
+         (second (sub-bytevector uuid 12 2))
+         (hundredths (sub-bytevector uuid 14 2))
+         (parts (list year month day hour minute second hundredths)))
+    (string-append (string-join (map digits->string parts)))))
+
+(define (iso9660-superblock-volume-name sblock)
+  "Return the volume name of SBLOCK as a string.  The volume name is an ASCII
+string.  Trailing spaces are trimmed."
+  (string-trim-right (latin1->string (sub-bytevector sblock 40 32)
+                                     (lambda (c) #f)) #\space))
+
+
+;;;
 ;;; LUKS encrypted devices.
 ;;;
 
@@ -351,7 +397,9 @@ partition field reader that returned a value."
     (_ #f)))
 
 (define %partition-label-readers
-  (list (partition-field-reader read-ext2-superblock
+  (list (partition-field-reader read-iso9660-superblock
+                                iso9660-superblock-volume-name)
+        (partition-field-reader read-ext2-superblock
                                 ext2-superblock-volume-name)
         (partition-field-reader read-btrfs-superblock
                                 btrfs-superblock-volume-name)
@@ -359,7 +407,9 @@ partition field reader that returned a value."
                                 fat32-superblock-volume-name)))
 
 (define %partition-uuid-readers
-  (list (partition-field-reader read-ext2-superblock
+  (list (partition-field-reader read-iso9660-superblock
+                                iso9660-superblock-uuid)
+        (partition-field-reader read-ext2-superblock
                                 ext2-superblock-uuid)
         (partition-field-reader read-btrfs-superblock
                                 btrfs-superblock-uuid)
@@ -576,10 +626,6 @@ corresponds to the symbols listed in FLAGS."
       (()
        0))))
 
-(define (regular-file? file-name)
-  "Return #t if FILE-NAME is a regular file."
-  (eq? (stat:type (stat file-name)) 'regular))
-
 (define* (mount-file-system spec #:key (root "/root"))
   "Mount the file system described by SPEC under ROOT.  SPEC must have the
 form:
@@ -619,9 +665,9 @@ run a file system check."
          (check-file-system source type))
 
        ;; Create the mount point.  Most of the time this is a directory, but
-       ;; in the case of a bind mount, a regular file may be needed.
+       ;; in the case of a bind mount, a regular file or socket may be needed.
        (if (and (= MS_BIND (logand flags MS_BIND))
-                (regular-file? source))
+                (not (file-is-directory? source)))
            (unless (file-exists? mount-point)
              (mkdir-p (dirname mount-point))
              (call-with-output-file mount-point (const #t)))