Merge 'master' into core-updates

3 files changed, 88 insertions, 56 deletions

diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm
index 140bcb414b..3e516a4d3c 100644
--- a/gnu/build/file-systems.scm
+++ b/gnu/build/file-systems.scm
@@ -20,9 +20,11 @@
 
 (define-module (gnu build file-systems)
   #:use-module (gnu system uuid)
+  #:use-module (gnu system file-systems)
   #:use-module (guix build utils)
   #:use-module (guix build bournish)
-  #:use-module (guix build syscalls)
+  #:use-module ((guix build syscalls)
+                #:hide (file-system-type))
   #:use-module (rnrs io ports)
   #:use-module (rnrs bytevectors)
   #:use-module (ice-9 match)
@@ -192,7 +194,7 @@ if DEVICE does not contain a btrfs file system."
 Trailing spaces are trimmed."
   (string-trim-right (latin1->string (sub-bytevector sblock 71 11) (lambda (c) #f)) #\space))
 
-(define (check-fat32-file-system device)
+(define (check-fat-file-system device)
   "Return the health of a fat file system on DEVICE."
   (match (status:exit-val
           (system* "fsck.vfat" "-v" "-a" device))
@@ -202,6 +204,33 @@ Trailing spaces are trimmed."
 
 
 ;;;
+;;; FAT16 file systems.
+;;;
+
+(define (fat16-superblock? sblock)
+  "Return #t when SBLOCK is a fat16 boot record."
+  (bytevector=? (sub-bytevector sblock 54 8)
+                (string->utf8 "FAT16   ")))
+
+(define (read-fat16-superblock device)
+  "Return the raw contents of DEVICE's fat16 superblock as a bytevector, or
+#f if DEVICE does not contain a fat16 file system."
+  (read-superblock device 0 62 fat16-superblock?))
+
+(define (fat16-superblock-uuid sblock)
+  "Return the Volume ID of a fat superblock SBLOCK as a 4-byte bytevector."
+  (sub-bytevector sblock 39 4))
+
+(define (fat16-superblock-volume-name sblock)
+  "Return the volume name of SBLOCK as a string of at most 11 characters, or
+#f if SBLOCK has no volume name.  The volume name is a latin1 string.
+Trailing spaces are trimmed."
+  (string-trim-right (latin1->string (sub-bytevector sblock 43 11)
+                                     (lambda (c) #f))
+                     #\space))
+
+
+;;;
 ;;; ISO9660 file systems.
 ;;;
 
@@ -384,7 +413,9 @@ partition field reader that returned a value."
         (partition-field-reader read-btrfs-superblock
                                 btrfs-superblock-volume-name)
         (partition-field-reader read-fat32-superblock
-                                fat32-superblock-volume-name)))
+                                fat32-superblock-volume-name)
+        (partition-field-reader read-fat16-superblock
+                                fat16-superblock-volume-name)))
 
 (define %partition-uuid-readers
   (list (partition-field-reader read-iso9660-superblock
@@ -394,7 +425,9 @@ partition field reader that returned a value."
         (partition-field-reader read-btrfs-superblock
                                 btrfs-superblock-uuid)
         (partition-field-reader read-fat32-superblock
-                                fat32-superblock-uuid)))
+                                fat32-superblock-uuid)
+        (partition-field-reader read-fat16-superblock
+                                fat16-superblock-uuid)))
 
 (define read-partition-label
   (cut read-partition-field <> %partition-label-readers))
@@ -448,8 +481,7 @@ the following:
      \"/dev/sda1\";
   • 'label', in which case SPEC is known to designate a partition label--e.g.,
      \"my-root-part\";
-  • 'uuid', in which case SPEC must be a UUID (a 16-byte bytevector)
-     designating a partition;
+  • 'uuid', in which case SPEC must be a UUID designating a partition;
   • 'any', in which case SPEC can be anything.
 "
   (define max-trials
@@ -495,9 +527,11 @@ the following:
      (resolve find-partition-by-label spec identity))
     ((uuid)
      (resolve find-partition-by-uuid
-              (if (string? spec)
-                  (string->uuid spec)
-                  spec)
+              (cond ((string? spec)
+                     (string->uuid spec))
+                    ((uuid? spec)
+                     (uuid-bytevector spec))
+                    (else spec))
               uuid->string))
     (else
      (error "unknown device title" title))))
@@ -508,7 +542,7 @@ the following:
     (cond
      ((string-prefix? "ext" type) check-ext2-file-system)
      ((string-prefix? "btrfs" type) check-btrfs-file-system)
-     ((string-suffix? "fat" type) check-fat32-file-system)
+     ((string-suffix? "fat" type) check-fat-file-system)
      (else #f)))
 
   (if check-procedure
@@ -552,11 +586,8 @@ corresponds to the symbols listed in FLAGS."
       (()
        0))))
 
-(define* (mount-file-system spec #:key (root "/root"))
-  "Mount the file system described by SPEC under ROOT.  SPEC must have the
-form:
-
-  (DEVICE TITLE MOUNT-POINT TYPE (FLAGS ...) OPTIONS CHECK?)
+(define* (mount-file-system fs #:key (root "/root"))
+  "Mount the file system described by FS, a <file-system> object, under ROOT.
 
 DEVICE, MOUNT-POINT, and TYPE must be strings; OPTIONS can be a string or #f;
 FLAGS must be a list of symbols.  CHECK? is a Boolean indicating whether to
@@ -582,34 +613,36 @@ run a file system check."
                             (if options
                                 (string-append "," options)
                                 "")))))
-  (match spec
-    ((source title mount-point type (flags ...) options check?)
-     (let ((source      (canonicalize-device-spec source title))
-           (mount-point (string-append root "/" mount-point))
-           (flags       (mount-flags->bit-mask flags)))
-       (when 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 or socket may be needed.
-       (if (and (= MS_BIND (logand flags MS_BIND))
-                (not (file-is-directory? source)))
-           (unless (file-exists? mount-point)
-             (mkdir-p (dirname mount-point))
-             (call-with-output-file mount-point (const #t)))
-           (mkdir-p mount-point))
-
-       (cond
-        ((string-prefix? "nfs" type)
-         (mount-nfs source mount-point type flags options))
-        (else
-         (mount source mount-point type flags options)))
-
-       ;; For read-only bind mounts, an extra remount is needed, as per
-       ;; <http://lwn.net/Articles/281157/>, which still applies to Linux 4.0.
-       (when (and (= MS_BIND (logand flags MS_BIND))
-                  (= MS_RDONLY (logand flags MS_RDONLY)))
-         (let ((flags (logior MS_BIND MS_REMOUNT MS_RDONLY)))
-           (mount source mount-point type flags #f)))))))
+  (let ((type        (file-system-type fs))
+        (options     (file-system-options fs))
+        (source      (canonicalize-device-spec (file-system-device fs)
+                                               (file-system-title fs)))
+        (mount-point (string-append root "/"
+                                    (file-system-mount-point fs)))
+        (flags       (mount-flags->bit-mask (file-system-flags fs))))
+    (when (file-system-check? fs)
+      (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 or socket may be needed.
+    (if (and (= MS_BIND (logand flags MS_BIND))
+             (not (file-is-directory? source)))
+        (unless (file-exists? mount-point)
+          (mkdir-p (dirname mount-point))
+          (call-with-output-file mount-point (const #t)))
+        (mkdir-p mount-point))
+
+    (cond
+     ((string-prefix? "nfs" type)
+      (mount-nfs source mount-point type flags options))
+     (else
+      (mount source mount-point type flags options)))
+
+    ;; For read-only bind mounts, an extra remount is needed, as per
+    ;; <http://lwn.net/Articles/281157/>, which still applies to Linux 4.0.
+    (when (and (= MS_BIND (logand flags MS_BIND))
+               (= MS_RDONLY (logand flags MS_RDONLY)))
+      (let ((flags (logior MS_BIND MS_REMOUNT MS_RDONLY)))
+        (mount source mount-point type flags #f)))))
 
 ;;; file-systems.scm ends here
diff --git a/gnu/build/linux-boot.scm b/gnu/build/linux-boot.scm
index 360ef3faed..3712abe910 100644
--- a/gnu/build/linux-boot.scm
+++ b/gnu/build/linux-boot.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -27,9 +27,11 @@
   #:use-module (ice-9 match)
   #:use-module (ice-9 ftw)
   #:use-module (guix build utils)
-  #:use-module (guix build syscalls)
+  #:use-module ((guix build syscalls)
+                #:hide (file-system-type))
   #:use-module (gnu build linux-modules)
   #:use-module (gnu build file-systems)
+  #:use-module (gnu system file-systems)
   #:export (mount-essential-file-systems
             linux-command-line
             find-long-option
@@ -349,19 +351,17 @@ supports kernel command-line options '--load', '--root', and '--repl'.
 Mount the root file system, specified by the '--root' command-line argument,
 if any.
 
-MOUNTS must be a list suitable for 'mount-file-system'.
+MOUNTS must be a list of <file-system> objects.
 
 When VOLATILE-ROOT? is true, the root file system is writable but any changes
 to it are lost."
-  (define root-mount-point?
-    (match-lambda
-     ((device _ "/" _ ...) #t)
-     (_ #f)))
+  (define (root-mount-point? fs)
+    (string=? (file-system-mount-point fs) "/"))
 
   (define root-fs-type
-    (or (any (match-lambda
-              ((device _ "/" type _ ...) type)
-              (_ #f))
+    (or (any (lambda (fs)
+               (and (root-mount-point? fs)
+                    (file-system-type fs)))
              mounts)
         "ext4"))
 
diff --git a/gnu/build/linux-container.scm b/gnu/build/linux-container.scm
index 95bfd92dde..70e789403f 100644
--- a/gnu/build/linux-container.scm
+++ b/gnu/build/linux-container.scm
@@ -152,8 +152,7 @@ for the process."
 
   ;; Mount user-specified file systems.
   (for-each (lambda (file-system)
-              (mount-file-system (file-system->spec file-system)
-                                 #:root root))
+              (mount-file-system file-system #:root root))
             mounts)
 
   ;; Jail the process inside the container's root file system.