system: File system sources can be marked as labels or devices.

* gnu/system/file-systems.scm (<file-system>)[title]: New field.
* gnu/services/base.scm (file-system-service): Add #:title parameter.
  In 'start' gexp, use 'canonicalize-device-spec' and honor TITLE.
* gnu/system.scm (other-file-system-services,
  operating-system-root-file-system, operating-system-initrd-file):
  Adjust accordingly.
* gnu/system/linux-initrd.scm (file-system->spec): Likewise.
* gnu/system/vm.scm (system-disk-image): Add 'title' field for the root
  file system.
* guix/build/linux-initrd.scm (mount-file-system): Expect the second
  element of SPEC to be the title.
  (boot-system)[root-mount-point?, root-fs-type]: Likewise.
* gnu/services/dmd.scm (dmd-configuration-file): Select
  'canonicalize-device-spec'.

7 files changed, 29 insertions, 18 deletions

diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index 3643f7cfc1..4442203524 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -89,9 +89,11 @@ This service must be the root of the service dependency graph so that its
       (respawn? #f)))))
 
 (define* (file-system-service device target type
-                              #:key (check? #t) options)
+                              #:key (check? #t) options (title 'any))
   "Return a service that mounts DEVICE on TARGET as a file system TYPE with
-OPTIONS.  When CHECK? is true, check the file system before mounting it."
+OPTIONS.  TITLE is a symbol specifying what kind of name DEVICE is: 'label for
+a partition label, 'device for a device file name, or 'any.  When CHECK? is
+true, check the file system before mounting it."
   (with-monad %store-monad
     (return
      (service
@@ -99,10 +101,11 @@ OPTIONS.  When CHECK? is true, check the file system before mounting it."
       (requirement '(root-file-system))
       (documentation "Check, mount, and unmount the given file system.")
       (start #~(lambda args
-                 #$(if check?
-                       #~(check-file-system #$device #$type)
-                       #~#t)
-                 (mount #$device #$target #$type 0 #$options)
+                 (let ((device (canonicalize-device-spec #$device '#$title)))
+                   #$(if check?
+                         #~(check-file-system device #$type)
+                         #~#t)
+                   (mount device #$target #$type 0 #$options))
                  #t))
       (stop #~(lambda args
                 ;; Normally there are no processes left at this point, so
diff --git a/gnu/services/dmd.scm b/gnu/services/dmd.scm
index 982c196fe4..74adb27885 100644
--- a/gnu/services/dmd.scm
+++ b/gnu/services/dmd.scm
@@ -50,7 +50,7 @@
           (use-modules (ice-9 ftw)
                        (guix build syscalls)
                        ((guix build linux-initrd)
-                        #:select (check-file-system)))
+                        #:select (check-file-system canonicalize-device-spec)))
 
           (register-services
            #$@(map (lambda (service)
diff --git a/gnu/system.scm b/gnu/system.scm
index d05ec60b29..548184f5d5 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -182,8 +182,10 @@ as 'needed-for-boot'."
 
   (sequence %store-monad
             (map (match-lambda
-                  (($ <file-system> device target type flags opts #f check?)
+                  (($ <file-system> device title target type flags opts
+                                    #f check?)
                    (file-system-service device target type
+                                        #:title title
                                         #:check? check?
                                         #:options opts)))
                  file-systems)))
@@ -449,7 +451,7 @@ we're running in the final root."
 (define (operating-system-root-file-system os)
   "Return the root file system of OS."
   (find (match-lambda
-         (($ <file-system> _ "/") #t)
+         (($ <file-system> _ _ "/") #t)
          (_ #f))
         (operating-system-file-systems os)))
 
@@ -457,9 +459,10 @@ we're running in the final root."
   "Return a gexp denoting the initrd file of OS."
   (define boot-file-systems
     (filter (match-lambda
-             (($ <file-system> device "/")
+             (($ <file-system> device title "/")
               #t)
-             (($ <file-system> device mount-point type flags options boot?)
+             (($ <file-system> device title mount-point type flags
+                               options boot?)
               boot?))
             (operating-system-file-systems os)))
 
diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm
index 485150ea51..7852a6ab26 100644
--- a/gnu/system/file-systems.scm
+++ b/gnu/system/file-systems.scm
@@ -22,6 +22,7 @@
             file-system
             file-system?
             file-system-device
+            file-system-title
             file-system-mount-point
             file-system-type
             file-system-needed-for-boot?
@@ -42,6 +43,8 @@
   make-file-system
   file-system?
   (device           file-system-device)           ; string
+  (title            file-system-title             ; 'device | 'label | 'uuid
+                    (default 'device))
   (mount-point      file-system-mount-point)      ; string
   (type             file-system-type)             ; string
   (flags            file-system-flags             ; list of symbols
diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm
index b80ff10f1e..17fec4f7f4 100644
--- a/gnu/system/linux-initrd.scm
+++ b/gnu/system/linux-initrd.scm
@@ -198,8 +198,8 @@ a list of Guile module names to be embedded in the initrd."
   "Return a list corresponding to file-system FS that can be passed to the
 initrd code."
   (match fs
-    (($ <file-system> device mount-point type flags options _ check?)
-     (list device mount-point type flags options check?))))
+    (($ <file-system> device title mount-point type flags options _ check?)
+     (list device title mount-point type flags options check?))))
 
 (define* (qemu-initrd file-systems
                       #:key
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 184f2512f1..c85445cd5f 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -290,6 +290,7 @@ to USB sticks meant to be read-only."
               (file-systems (cons (file-system
                                     (mount-point "/")
                                     (device root-label)
+                                    (title 'label)
                                     (type file-system-type))
                                   file-systems-to-keep)))))
 
diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm
index 05f6bf14bf..c1a0247aff 100644
--- a/guix/build/linux-initrd.scm
+++ b/guix/build/linux-initrd.scm
@@ -37,6 +37,7 @@
             disk-partitions
             partition-label-predicate
             find-partition-by-label
+            canonicalize-device-spec
 
             check-file-system
             mount-file-system
@@ -485,7 +486,7 @@ UNIONFS."
   "Mount the file system described by SPEC under ROOT.  SPEC must have the
 form:
 
-  (DEVICE MOUNT-POINT TYPE (FLAGS ...) OPTIONS CHECK?)
+  (DEVICE TITLE MOUNT-POINT TYPE (FLAGS ...) OPTIONS CHECK?)
 
 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
@@ -500,8 +501,8 @@ run a file system check."
       0)))
 
   (match spec
-    ((source mount-point type (flags ...) options check?)
-     (let ((source      (canonicalize-device-spec source))
+    ((source title mount-point type (flags ...) options check?)
+     (let ((source      (canonicalize-device-spec source title))
            (mount-point (string-append root "/" mount-point)))
        (when check?
          (check-file-system source type))
@@ -596,12 +597,12 @@ to it are lost."
 
   (define root-mount-point?
     (match-lambda
-     ((device "/" _ ...) #t)
+     ((device _ "/" _ ...) #t)
      (_ #f)))
 
   (define root-fs-type
     (or (any (match-lambda
-              ((device "/" type _ ...) type)
+              ((device _ "/" type _ ...) type)
               (_ #f))
              mounts)
         "ext4"))