file-systems: Remove 'title' field and add <file-system-label>.

The 'title' field was easily overlooked and was an endless source of
confusion.  Now, the value of the 'device' field is self-contained.

* gnu/system/file-systems.scm (<file-system>): Change constructor name
to '%file-system'.
[title]: Remove.
(<file-system-label>): New record type with printer.
(report-deprecation, device-expression)
(process-file-system-declaration, file-system): New macros.
(file-system-title): New procedure.
(file-system->spec, spec->file-system): Adjust to handle
<file-system-label>.
* gnu/system.scm (bootable-kernel-arguments): Add case for
'file-system-label?'.
(read-boot-parameters): Likewise.
(mapped-device-user): Avoid 'file-system-title'.
(fs->boot-device): Remove.
(operating-system-boot-parameters): Use 'file-system-device' instead of
'fs->boot-device'.
(device->sexp): Add case for 'file-system-label?'.
* gnu/bootloader/grub.scm (grub-root-search): Add case for
'file-system-label?'.
* gnu/system/examples/bare-bones.tmpl,
gnu/system/examples/beaglebone-black.tmpl,
gnu/system/examples/lightweight-desktop.tmpl,
gnu/system/examples/vm-image.tmpl: Remove uses of 'title'.
* gnu/system/vm.scm (virtualized-operating-system): Remove uses of
'file-system-title'.
* guix/scripts/system.scm (check-file-system-availability): Likewise,
and adjust fix-it hint.
(check-initrd-modules)[file-system-/dev]: Likewise.
* gnu/build/file-systems.scm (canonicalize-device-spec): Remove 'title'
parameter.
[canonical-title]: Remove.
Match on SPEC's type rather than on CANONICAL-TITLE.
(mount-file-system): Adjust caller.
* gnu/build/linux-boot.scm (boot-system): Interpret ROOT here.
* gnu/services/base.scm (file-system->fstab-entry): Remove use of
'file-system-title'.
* doc/guix.texi (File Systems): Remove documentation of the 'title'
field.  Rewrite documentation of 'device' and document
'file-system-label'.

11 files changed, 160 insertions, 97 deletions

diff --git a/gnu/bootloader/grub.scm b/gnu/bootloader/grub.scm
index 3b01125c78..eca6d97b19 100644
--- a/gnu/bootloader/grub.scm
+++ b/gnu/bootloader/grub.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
 ;;; Copyright © 2017 Leo Famulari <leo@famulari.name>
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
@@ -31,6 +31,7 @@
   #:use-module (gnu system)
   #:use-module (gnu bootloader)
   #:use-module (gnu system uuid)
+  #:use-module (gnu system file-systems)
   #:autoload   (gnu packages bootloaders) (grub)
   #:autoload   (gnu packages compression) (gzip)
   #:autoload   (gnu packages gtk) (guile-cairo guile-rsvg)
@@ -303,9 +304,10 @@ code."
         ((? uuid? uuid)
          (format #f "search --fs-uuid --set ~a"
                  (uuid->string device)))
-        ((? string? label)
-         (format #f "search --label --set ~a" label))
-        (#f
+        ((? file-system-label? label)
+         (format #f "search --label --set ~a"
+                 (file-system-label->string label)))
+        ((or #f (? string?))
          #~(format #f "search --file --set ~a" #$file)))))
 
 (define* (grub-configuration-file config entries
diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm
index 145b3b14e7..3dd7358fd3 100644
--- a/gnu/build/file-systems.scm
+++ b/gnu/build/file-systems.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2016, 2017 David Craven <david@craven.ch>
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;;
@@ -473,17 +473,9 @@ were found."
   (find-partition luks-partition-uuid-predicate))
 
 
-(define* (canonicalize-device-spec spec #:optional (title 'any))
-  "Return the device name corresponding to SPEC.  TITLE is a symbol, one of
-the following:
-
-  • 'device', in which case SPEC is known to designate a device node--e.g.,
-     \"/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 designating a partition;
-  • 'any', in which case SPEC can be anything.
-"
+(define (canonicalize-device-spec spec)
+  "Return the device name corresponding to SPEC, which can be a <uuid>, a
+<file-system-label>, or a string (typically a /dev file name)."
   (define max-trials
     ;; Number of times we retry partition label resolution, 1 second per
     ;; trial.  Note: somebody reported a delay of 16 seconds (!) before their
@@ -491,19 +483,6 @@ the following:
     ;; this long.
     20)
 
-  (define canonical-title
-    ;; The realm of canonicalization.
-    (if (eq? title 'any)
-        (if (string? spec)
-            ;; The "--root=SPEC" kernel command-line option always provides a
-            ;; string, but the string can represent a device, a UUID, or a
-            ;; label.  So check for all three.
-            (cond ((string-prefix? "/" spec) 'device)
-                  ((string->uuid spec) 'uuid)
-                  (else 'label))
-            'uuid)
-        title))
-
   (define (resolve find-partition spec fmt)
     (let loop ((count 0))
       (let ((device (find-partition spec)))
@@ -518,23 +497,19 @@ the following:
                   (sleep 1)
                   (loop (+ 1 count))))))))
 
-  (case canonical-title
-    ((device)
+  (match spec
+    ((? string?)
      ;; Nothing to do.
      spec)
-    ((label)
+    ((? file-system-label?)
      ;; Resolve the label.
-     (resolve find-partition-by-label spec identity))
-    ((uuid)
+     (resolve find-partition-by-label
+              (file-system-label->string spec)
+              identity))
+    ((? uuid?)
      (resolve find-partition-by-uuid
-              (cond ((string? spec)
-                     (string->uuid spec))
-                    ((uuid? spec)
-                     (uuid-bytevector spec))
-                    (else spec))
-              uuid->string))
-    (else
-     (error "unknown device title" title))))
+              (uuid-bytevector spec)
+              uuid->string))))
 
 (define (check-file-system device type)
   "Run a file system check of TYPE on DEVICE."
@@ -615,8 +590,7 @@ run a file system check."
                                 "")))))
   (let ((type        (file-system-type fs))
         (options     (file-system-options fs))
-        (source      (canonicalize-device-spec (file-system-device fs)
-                                               (file-system-title fs)))
+        (source      (canonicalize-device-spec (file-system-device fs)))
         (mount-point (string-append root "/"
                                     (file-system-mount-point fs)))
         (flags       (mount-flags->bit-mask (file-system-flags fs))))
diff --git a/gnu/build/linux-boot.scm b/gnu/build/linux-boot.scm
index 18d87260a9..44b3506284 100644
--- a/gnu/build/linux-boot.scm
+++ b/gnu/build/linux-boot.scm
@@ -507,9 +507,15 @@ upon error."
            (error "pre-mount actions failed")))
 
        (if root
-           (mount-root-file-system (canonicalize-device-spec root)
-                                   root-fs-type
-                                   #:volatile-root? volatile-root?)
+           ;; The "--root=SPEC" kernel command-line option always provides a
+           ;; string, but the string can represent a device, a UUID, or a
+           ;; label.  So check for all three.
+           (let ((root (cond ((string-prefix? "/" root) root)
+                             ((uuid root) => identity)
+                             (else (file-system-label root)))))
+             (mount-root-file-system (canonicalize-device-spec root)
+                                     root-fs-type
+                                     #:volatile-root? volatile-root?))
            (mount "none" "/root" "tmpfs"))
 
        ;; Mount the specified file systems.
diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index eb82b2ddcf..09a1ce95e3 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -303,15 +303,14 @@ seconds after @code{SIGTERM} has been sent are terminated with
 
 (define (file-system->fstab-entry file-system)
   "Return a @file{/etc/fstab} entry for @var{file-system}."
-  (string-append (case (file-system-title file-system)
-                   ((label)
-                    (string-append "LABEL=" (file-system-device file-system)))
-                   ((uuid)
-                    (string-append
-                     "UUID="
-                     (uuid->string (file-system-device file-system))))
-                   (else
-                    (file-system-device file-system)))
+  (string-append (match (file-system-device file-system)
+                   ((? file-system-label? label)
+                    (string-append "LABEL="
+                                   (file-system-label->string file-system)))
+                   ((? uuid? uuid)
+                    (string-append "UUID=" (uuid->string uuid)))
+                   ((? string? device)
+                    device))
                  "\t"
                  (file-system-mount-point file-system) "\t"
                  (file-system-type file-system) "\t"
diff --git a/gnu/system.scm b/gnu/system.scm
index 1052e9355d..288c1e8801 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -131,13 +131,16 @@
   "Prepend extra arguments to KERNEL-ARGUMENTS that allow SYSTEM.DRV to be
 booted from ROOT-DEVICE"
   (cons* (string-append "--root="
-                        (if (uuid? root-device)
-
-                            ;; Note: Always use the DCE format because that's
-                            ;; what (gnu build linux-boot) expects for the
-                            ;; '--root' kernel command-line option.
-                            (uuid->string (uuid-bytevector root-device) 'dce)
-                            root-device))
+                        (cond ((uuid? root-device)
+
+                               ;; Note: Always use the DCE format because that's
+                               ;; what (gnu build linux-boot) expects for the
+                               ;; '--root' kernel command-line option.
+                               (uuid->string (uuid-bytevector root-device)
+                                             'dce))
+                              ((file-system-label? root-device)
+                               (file-system-label->string root-device))
+                              (else root-device)))
          #~(string-append "--system=" #$system.drv)
          #~(string-append "--load=" #$system.drv "/boot")
          kernel-arguments))
@@ -251,10 +254,16 @@ file system labels."
     (match-lambda
       (('uuid (? symbol? type) (? bytevector? bv))
        (bytevector->uuid bv type))
+      (('file-system-label (? string? label))
+       (file-system-label label))
       ((? bytevector? bv)                         ;old format
        (bytevector->uuid bv 'dce))
       ((? string? device)
-       device)))
+       ;; It used to be that we would not distinguish between labels and
+       ;; device names.  Try to infer the right thing here.
+       (if (string-prefix? "/dev/" device)
+           device
+           (file-system-label device)))))
 
   (match (read port)
     (('boot-parameters ('version 0)
@@ -377,7 +386,7 @@ marked as 'needed-for-boot'."
   (let ((target (string-append "/dev/mapper/" (mapped-device-target device))))
     (find (lambda (fs)
             (or (member device (file-system-dependencies fs))
-                (and (eq? 'device (file-system-title fs))
+                (and (string? (file-system-device fs))
                      (string=? (file-system-device fs) target))))
           file-systems)))
 
@@ -934,13 +943,6 @@ listed in OS.  The C library expects to find it under
       (bootloader-configuration-bootloader bootloader-conf))
      bootloader-conf (list entry) #:old-entries old-entries)))
 
-(define (fs->boot-device fs)
-  "Given FS, a <file-system> object, return a value suitable for use as the
-device in a <menu-entry>."
-  (case (file-system-title fs)
-    ((uuid label device) (file-system-device fs))
-    (else #f)))
-
 (define (operating-system-boot-parameters os system.drv root-device)
   "Return a monadic <boot-parameters> record that describes the boot parameters
 of OS.  SYSTEM.DRV is either a derivation or #f.  If it's a derivation, adds
@@ -962,7 +964,7 @@ kernel arguments for that derivation to <boot-parameters>."
                 (operating-system-user-kernel-arguments os)))
              (initrd initrd)
              (bootloader-name bootloader-name)
-             (store-device (ensure-not-/dev (fs->boot-device store)))
+             (store-device (ensure-not-/dev (file-system-device store)))
              (store-mount-point (file-system-mount-point store))))))
 
 (define (device->sexp device)
@@ -970,6 +972,8 @@ kernel arguments for that derivation to <boot-parameters>."
   (match device
     ((? uuid? uuid)
      `(uuid ,(uuid-type uuid) ,(uuid-bytevector uuid)))
+    ((? file-system-label? label)
+     `(file-system-label ,(file-system-label->string label)))
     (_
      device)))
 
diff --git a/gnu/system/examples/bare-bones.tmpl b/gnu/system/examples/bare-bones.tmpl
index 7e0c8fbee0..cb6d2623db 100644
--- a/gnu/system/examples/bare-bones.tmpl
+++ b/gnu/system/examples/bare-bones.tmpl
@@ -16,8 +16,7 @@
                 (bootloader grub-bootloader)
                 (target "/dev/sdX")))
   (file-systems (cons (file-system
-                        (device "my-root")
-                        (title 'label)
+                        (device (file-system-label "my-root"))
                         (mount-point "/")
                         (type "ext4"))
                       %base-file-systems))
diff --git a/gnu/system/examples/beaglebone-black.tmpl b/gnu/system/examples/beaglebone-black.tmpl
index 97201330c7..d1130c76b6 100644
--- a/gnu/system/examples/beaglebone-black.tmpl
+++ b/gnu/system/examples/beaglebone-black.tmpl
@@ -20,8 +20,7 @@
   (initrd-modules (cons "omap_hsmmc" %base-initrd-modules))
 
   (file-systems (cons (file-system
-                        (device "my-root")
-                        (title 'label)
+                        (device (file-system-label "my-root"))
                         (mount-point "/")
                         (type "ext4"))
                       %base-file-systems))
diff --git a/gnu/system/examples/lightweight-desktop.tmpl b/gnu/system/examples/lightweight-desktop.tmpl
index 65a8ee1809..360ee62ffe 100644
--- a/gnu/system/examples/lightweight-desktop.tmpl
+++ b/gnu/system/examples/lightweight-desktop.tmpl
@@ -20,13 +20,11 @@
   ;; Assume the target root file system is labelled "my-root",
   ;; and the EFI System Partition has UUID 1234-ABCD.
   (file-systems (cons* (file-system
-                         (device "my-root")
-                         (title 'label)
+                         (device (file-system-label "my-root"))
                          (mount-point "/")
                          (type "ext4"))
                        (file-system
                          (device (uuid "1234-ABCD" 'fat))
-                         (title 'uuid)
                          (mount-point "/boot/efi")
                          (type "vfat"))
                        %base-file-systems))
diff --git a/gnu/system/examples/vm-image.tmpl b/gnu/system/examples/vm-image.tmpl
index ce3653c8b4..36e272722d 100644
--- a/gnu/system/examples/vm-image.tmpl
+++ b/gnu/system/examples/vm-image.tmpl
@@ -31,8 +31,7 @@ partprobe, and then 2) resizing the filesystem with resize2fs.\n"))
                (target "/dev/sda")
                (terminal-outputs '(console))))
   (file-systems (cons (file-system
-                        (device "my-root")
-                        (title 'label)
+                        (device (file-system-label "my-root"))
                         (mount-point "/")
                         (type "ext4"))
                       %base-file-systems))
diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm
index 93289dbd5d..2b5948256a 100644
--- a/gnu/system/file-systems.scm
+++ b/gnu/system/file-systems.scm
@@ -20,6 +20,8 @@
   #:use-module (ice-9 match)
   #:use-module (rnrs bytevectors)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-9 gnu)
   #:use-module (guix records)
   #:use-module (gnu system uuid)
   #:re-export (uuid                               ;backward compatibility
@@ -28,7 +30,7 @@
   #:export (file-system
             file-system?
             file-system-device
-            file-system-title
+            file-system-title                     ;deprecated
             file-system-mount-point
             file-system-type
             file-system-needed-for-boot?
@@ -42,6 +44,10 @@
 
             file-system-type-predicate
 
+            file-system-label
+            file-system-label?
+            file-system-label->string
+
             file-system->spec
             spec->file-system
             specification->file-system-mapping
@@ -82,12 +88,10 @@
 ;;; Code:
 
 ;; File system declaration.
-(define-record-type* <file-system> file-system
+(define-record-type* <file-system> %file-system
   make-file-system
   file-system?
-  (device           file-system-device)           ; string
-  (title            file-system-title             ; 'device | 'label | 'uuid
-                    (default 'device))
+  (device           file-system-device) ; string | <uuid> | <file-system-label>
   (mount-point      file-system-mount-point)      ; string
   (type             file-system-type)             ; string
   (flags            file-system-flags             ; list of symbols
@@ -108,6 +112,83 @@
                     (default (current-source-location))
                     (innate)))
 
+;; A file system label for use in the 'device' field.
+(define-record-type <file-system-label>
+  (file-system-label label)
+  file-system-label?
+  (label file-system-label->string))
+
+(set-record-type-printer! <file-system-label>
+                          (lambda (obj port)
+                            (format port "#<file-system-label ~s>"
+                                    (file-system-label->string obj))))
+
+(define-syntax report-deprecation
+  (lambda (s)
+    "Report the use of the now-deprecated 'title' field."
+    (syntax-case s ()
+      ((_ field)
+       (let* ((source (syntax-source #'field))
+              (file   (and source (assq-ref source 'filename)))
+              (line   (and source
+                           (and=> (assq-ref source 'line) 1+)))
+              (column (and source (assq-ref source 'column))))
+         (format (current-error-port)
+                 "~a:~a:~a: warning: 'title' field is deprecated~%"
+                 file line column)
+         #t)))))
+
+;; Helper for 'process-file-system-declaration'.
+(define-syntax device-expression
+  (syntax-rules (quote label uuid device)
+    ((_ (quote label) dev)
+     (file-system-label dev))
+    ((_ (quote uuid) dev)
+     (if (uuid? dev) dev (uuid dev)))
+    ((_ (quote device) dev)
+     dev)
+    ((_ title dev)
+     (case title
+       ((label) (file-system-label dev))
+       ((uuid)  (uuid dev))
+       (else    dev)))))
+
+;; Helper to interpret the now-deprecated 'title' field.  Detect forms like
+;; (title 'label), remove them, and adjust the 'device' field accordingly.
+;; TODO: Remove this once 'title' has been deprecated long enough.
+(define-syntax process-file-system-declaration
+  (syntax-rules (device title)
+    ((_ () (rest ...) #f #f)                 ;no 'title' and no 'device' field
+     (%file-system rest ...))
+    ((_ () (rest ...) dev #f)                     ;no 'title' field
+     (%file-system rest ... (device dev)))
+    ((_ () (rest ...) dev titl)                   ;got a 'title' field
+     (%file-system rest ...
+                   (device (device-expression titl dev))))
+    ((_ ((title titl) rest ...) (previous ...) dev _)
+     (begin
+       (report-deprecation (title titl))
+       (process-file-system-declaration (rest ...)
+                                        (previous ...)
+                                        dev titl)))
+    ((_ ((device dev) rest ...) (previous ...) _ titl)
+     (process-file-system-declaration (rest ...)
+                                      (previous ...)
+                                      dev titl))
+    ((_ (field rest ...) (previous ...) dev titl)
+     (process-file-system-declaration (rest ...)
+                                      (previous ... field)
+                                      dev titl))))
+
+(define-syntax-rule (file-system fields ...)
+  (process-file-system-declaration (fields ...) () #f #f))
+
+(define (file-system-title fs)                    ;deprecated
+  (match (file-system-device fs)
+    ((? file-system-label?) 'label)
+    ((? uuid?)              'uuid)
+    ((? string?)            'device)))
+
 ;; Note: This module is used both on the build side and on the host side.
 ;; Arrange not to pull (guix store) and (guix config) because the latter
 ;; differs from user to user.
@@ -160,23 +241,26 @@ store--e.g., if FS is the root file system."
   "Return a list corresponding to file-system FS that can be passed to the
 initrd code."
   (match fs
-    (($ <file-system> device title mount-point type flags options _ _ check?)
-     (list (if (uuid? device)
-               `(uuid ,(uuid-type device) ,(uuid-bytevector device))
-               device)
-           title mount-point type flags options check?))))
+    (($ <file-system> device mount-point type flags options _ _ check?)
+     (list (cond ((uuid? device)
+                  `(uuid ,(uuid-type device) ,(uuid-bytevector device)))
+                 ((file-system-label? device)
+                  `(file-system-label ,(file-system-label->string device)))
+                 (else device))
+           mount-point type flags options check?))))
 
 (define (spec->file-system sexp)
   "Deserialize SEXP, a list, to the corresponding <file-system> object."
   (match sexp
-    ((device title mount-point type flags options check?)
+    ((device mount-point type flags options check?)
      (file-system
        (device (match device
                  (('uuid (? symbol? type) (? bytevector? bv))
                   (bytevector->uuid bv type))
+                 (('file-system-label (? string? label))
+                  (file-system-label label))
                  (_
                   device)))
-       (title title)
        (mount-point mount-point) (type type)
        (flags flags) (options options)
        (check? check?)))))
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index eb73b5ca7a..7f80147150 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -693,13 +693,12 @@ environment with the store shared with the host.  MAPPINGS is a list of
                     (source (file-system-device fs)))
                 (or (string=? target (%store-prefix))
                     (string=? target "/")
-                    (and (eq? 'device (file-system-title fs))
+                    (and (string? source)
                          (string-prefix? "/dev/" source))
 
                     ;; Labels and UUIDs are necessarily invalid in the VM.
                     (and (file-system-mount? fs)
-                         (or (eq? 'label (file-system-title fs))
-                             (eq? 'uuid (file-system-title fs))
+                         (or (file-system-label? source)
                              (uuid? source))))))
             (operating-system-file-systems os)))