me
/
guix
Archived
1
0
Fork 0

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'.
master
Ludovic Courtès 2018-05-18 13:43:07 +02:00
parent 25816c4306
commit a5acc17a3c
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
13 changed files with 201 additions and 133 deletions

View File

@ -9210,20 +9210,31 @@ This is a string specifying the type of the file system---e.g.,
This designates the place where the file system is to be mounted. This designates the place where the file system is to be mounted.
@item @code{device} @item @code{device}
This names the ``source'' of the file system. By default it is the name This names the ``source'' of the file system. It can be one of three
of a node under @file{/dev}, but its meaning depends on the @code{title} things: a file system label, a file system UUID, or the name of a
field described below. @file{/dev} node. Labels and UUIDs offer a way to refer to file
systems without having to hard-code their actual device
name@footnote{Note that, while it is tempting to use
@file{/dev/disk/by-uuid} and similar device names to achieve the same
result, this is not recommended: These special device nodes are created
by the udev daemon and may be unavailable at the time the device is
mounted.}.
@item @code{title} (default: @code{'device}) @findex file-system-label
This is a symbol that specifies how the @code{device} field is to be File system labels are created using the @code{file-system-label}
interpreted. procedure, UUIDs are created using @code{uuid}, and @file{/dev} node are
plain strings. Here's an example of a file system referred to by its
label, as shown by the @command{e2label} command:
When it is the symbol @code{device}, then the @code{device} field is @example
interpreted as a file name; when it is @code{label}, then @code{device} (file-system
is interpreted as a file system label name; when it is @code{uuid}, (mount-point "/home")
@code{device} is interpreted as a file system unique identifier (UUID). (type "ext4")
(device (file-system-label "my-home")))
@end example
UUIDs may be converted from their string representation (as shown by the @findex uuid
UUIDs are converted from their string representation (as shown by the
@command{tune2fs -l} command) using the @code{uuid} form@footnote{The @command{tune2fs -l} command) using the @code{uuid} form@footnote{The
@code{uuid} form expects 16-byte UUIDs as defined in @code{uuid} form expects 16-byte UUIDs as defined in
@uref{https://tools.ietf.org/html/rfc4122, RFC@tie{}4122}. This is the @uref{https://tools.ietf.org/html/rfc4122, RFC@tie{}4122}. This is the
@ -9235,22 +9246,13 @@ like this:
(file-system (file-system
(mount-point "/home") (mount-point "/home")
(type "ext4") (type "ext4")
(title 'uuid)
(device (uuid "4dab5feb-d176-45de-b287-9b0a6e4c01cb"))) (device (uuid "4dab5feb-d176-45de-b287-9b0a6e4c01cb")))
@end example @end example
The @code{label} and @code{uuid} options offer a way to refer to file When the source of a file system is a mapped device (@pxref{Mapped
systems without having to hard-code their actual device
name@footnote{Note that, while it is tempting to use
@file{/dev/disk/by-uuid} and similar device names to achieve the same
result, this is not recommended: These special device nodes are created
by the udev daemon and may be unavailable at the time the device is
mounted.}.
However, when the source of a file system is a mapped device (@pxref{Mapped
Devices}), its @code{device} field @emph{must} refer to the mapped Devices}), its @code{device} field @emph{must} refer to the mapped
device name---e.g., @file{/dev/mapper/root-partition}---and consequently device name---e.g., @file{"/dev/mapper/root-partition"}.
@code{title} must be set to @code{'device}. This is required so that This is required so that
the system knows that mounting the file system depends on having the the system knows that mounting the file system depends on having the
corresponding device mapping established. corresponding device mapping established.

View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; 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 © 2016 Chris Marusich <cmmarusich@gmail.com>
;;; Copyright © 2017 Leo Famulari <leo@famulari.name> ;;; Copyright © 2017 Leo Famulari <leo@famulari.name>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
@ -31,6 +31,7 @@
#:use-module (gnu system) #:use-module (gnu system)
#:use-module (gnu bootloader) #:use-module (gnu bootloader)
#:use-module (gnu system uuid) #:use-module (gnu system uuid)
#:use-module (gnu system file-systems)
#:autoload (gnu packages bootloaders) (grub) #:autoload (gnu packages bootloaders) (grub)
#:autoload (gnu packages compression) (gzip) #:autoload (gnu packages compression) (gzip)
#:autoload (gnu packages gtk) (guile-cairo guile-rsvg) #:autoload (gnu packages gtk) (guile-cairo guile-rsvg)
@ -303,9 +304,10 @@ code."
((? uuid? uuid) ((? uuid? uuid)
(format #f "search --fs-uuid --set ~a" (format #f "search --fs-uuid --set ~a"
(uuid->string device))) (uuid->string device)))
((? string? label) ((? file-system-label? label)
(format #f "search --label --set ~a" label)) (format #f "search --label --set ~a"
(#f (file-system-label->string label)))
((or #f (? string?))
#~(format #f "search --file --set ~a" #$file))))) #~(format #f "search --file --set ~a" #$file)))))
(define* (grub-configuration-file config entries (define* (grub-configuration-file config entries

View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; 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 © 2016, 2017 David Craven <david@craven.ch>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; ;;;
@ -473,17 +473,9 @@ were found."
(find-partition luks-partition-uuid-predicate)) (find-partition luks-partition-uuid-predicate))
(define* (canonicalize-device-spec spec #:optional (title 'any)) (define (canonicalize-device-spec spec)
"Return the device name corresponding to SPEC. TITLE is a symbol, one of "Return the device name corresponding to SPEC, which can be a <uuid>, a
the following: <file-system-label>, or a string (typically a /dev file name)."
'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 max-trials (define max-trials
;; Number of times we retry partition label resolution, 1 second per ;; Number of times we retry partition label resolution, 1 second per
;; trial. Note: somebody reported a delay of 16 seconds (!) before their ;; trial. Note: somebody reported a delay of 16 seconds (!) before their
@ -491,19 +483,6 @@ the following:
;; this long. ;; this long.
20) 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) (define (resolve find-partition spec fmt)
(let loop ((count 0)) (let loop ((count 0))
(let ((device (find-partition spec))) (let ((device (find-partition spec)))
@ -518,23 +497,19 @@ the following:
(sleep 1) (sleep 1)
(loop (+ 1 count)))))))) (loop (+ 1 count))))))))
(case canonical-title (match spec
((device) ((? string?)
;; Nothing to do. ;; Nothing to do.
spec) spec)
((label) ((? file-system-label?)
;; Resolve the label. ;; Resolve the label.
(resolve find-partition-by-label spec identity)) (resolve find-partition-by-label
((uuid) (file-system-label->string spec)
identity))
((? uuid?)
(resolve find-partition-by-uuid (resolve find-partition-by-uuid
(cond ((string? spec) (uuid-bytevector spec)
(string->uuid spec)) uuid->string))))
((uuid? spec)
(uuid-bytevector spec))
(else spec))
uuid->string))
(else
(error "unknown device title" title))))
(define (check-file-system device type) (define (check-file-system device type)
"Run a file system check of TYPE on DEVICE." "Run a file system check of TYPE on DEVICE."
@ -615,8 +590,7 @@ run a file system check."
""))))) "")))))
(let ((type (file-system-type fs)) (let ((type (file-system-type fs))
(options (file-system-options fs)) (options (file-system-options fs))
(source (canonicalize-device-spec (file-system-device fs) (source (canonicalize-device-spec (file-system-device fs)))
(file-system-title fs)))
(mount-point (string-append root "/" (mount-point (string-append root "/"
(file-system-mount-point fs))) (file-system-mount-point fs)))
(flags (mount-flags->bit-mask (file-system-flags fs)))) (flags (mount-flags->bit-mask (file-system-flags fs))))

View File

@ -507,9 +507,15 @@ upon error."
(error "pre-mount actions failed"))) (error "pre-mount actions failed")))
(if root (if root
(mount-root-file-system (canonicalize-device-spec root) ;; The "--root=SPEC" kernel command-line option always provides a
root-fs-type ;; string, but the string can represent a device, a UUID, or a
#:volatile-root? volatile-root?) ;; 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 "none" "/root" "tmpfs"))
;; Mount the specified file systems. ;; Mount the specified file systems.

View File

@ -303,15 +303,14 @@ seconds after @code{SIGTERM} has been sent are terminated with
(define (file-system->fstab-entry file-system) (define (file-system->fstab-entry file-system)
"Return a @file{/etc/fstab} entry for @var{file-system}." "Return a @file{/etc/fstab} entry for @var{file-system}."
(string-append (case (file-system-title file-system) (string-append (match (file-system-device file-system)
((label) ((? file-system-label? label)
(string-append "LABEL=" (file-system-device file-system))) (string-append "LABEL="
((uuid) (file-system-label->string file-system)))
(string-append ((? uuid? uuid)
"UUID=" (string-append "UUID=" (uuid->string uuid)))
(uuid->string (file-system-device file-system)))) ((? string? device)
(else device))
(file-system-device file-system)))
"\t" "\t"
(file-system-mount-point file-system) "\t" (file-system-mount-point file-system) "\t"
(file-system-type file-system) "\t" (file-system-type file-system) "\t"

View File

@ -131,13 +131,16 @@
"Prepend extra arguments to KERNEL-ARGUMENTS that allow SYSTEM.DRV to be "Prepend extra arguments to KERNEL-ARGUMENTS that allow SYSTEM.DRV to be
booted from ROOT-DEVICE" booted from ROOT-DEVICE"
(cons* (string-append "--root=" (cons* (string-append "--root="
(if (uuid? root-device) (cond ((uuid? root-device)
;; Note: Always use the DCE format because that's ;; Note: Always use the DCE format because that's
;; what (gnu build linux-boot) expects for the ;; what (gnu build linux-boot) expects for the
;; '--root' kernel command-line option. ;; '--root' kernel command-line option.
(uuid->string (uuid-bytevector root-device) 'dce) (uuid->string (uuid-bytevector root-device)
root-device)) 'dce))
((file-system-label? root-device)
(file-system-label->string root-device))
(else root-device)))
#~(string-append "--system=" #$system.drv) #~(string-append "--system=" #$system.drv)
#~(string-append "--load=" #$system.drv "/boot") #~(string-append "--load=" #$system.drv "/boot")
kernel-arguments)) kernel-arguments))
@ -251,10 +254,16 @@ file system labels."
(match-lambda (match-lambda
(('uuid (? symbol? type) (? bytevector? bv)) (('uuid (? symbol? type) (? bytevector? bv))
(bytevector->uuid bv type)) (bytevector->uuid bv type))
(('file-system-label (? string? label))
(file-system-label label))
((? bytevector? bv) ;old format ((? bytevector? bv) ;old format
(bytevector->uuid bv 'dce)) (bytevector->uuid bv 'dce))
((? string? device) ((? 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) (match (read port)
(('boot-parameters ('version 0) (('boot-parameters ('version 0)
@ -377,7 +386,7 @@ marked as 'needed-for-boot'."
(let ((target (string-append "/dev/mapper/" (mapped-device-target device)))) (let ((target (string-append "/dev/mapper/" (mapped-device-target device))))
(find (lambda (fs) (find (lambda (fs)
(or (member device (file-system-dependencies 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)))) (string=? (file-system-device fs) target))))
file-systems))) file-systems)))
@ -934,13 +943,6 @@ listed in OS. The C library expects to find it under
(bootloader-configuration-bootloader bootloader-conf)) (bootloader-configuration-bootloader bootloader-conf))
bootloader-conf (list entry) #:old-entries old-entries))) 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) (define (operating-system-boot-parameters os system.drv root-device)
"Return a monadic <boot-parameters> record that describes the boot parameters "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 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))) (operating-system-user-kernel-arguments os)))
(initrd initrd) (initrd initrd)
(bootloader-name bootloader-name) (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)))))) (store-mount-point (file-system-mount-point store))))))
(define (device->sexp device) (define (device->sexp device)
@ -970,6 +972,8 @@ kernel arguments for that derivation to <boot-parameters>."
(match device (match device
((? uuid? uuid) ((? uuid? uuid)
`(uuid ,(uuid-type uuid) ,(uuid-bytevector uuid))) `(uuid ,(uuid-type uuid) ,(uuid-bytevector uuid)))
((? file-system-label? label)
`(file-system-label ,(file-system-label->string label)))
(_ (_
device))) device)))

View File

@ -16,8 +16,7 @@
(bootloader grub-bootloader) (bootloader grub-bootloader)
(target "/dev/sdX"))) (target "/dev/sdX")))
(file-systems (cons (file-system (file-systems (cons (file-system
(device "my-root") (device (file-system-label "my-root"))
(title 'label)
(mount-point "/") (mount-point "/")
(type "ext4")) (type "ext4"))
%base-file-systems)) %base-file-systems))

View File

@ -20,8 +20,7 @@
(initrd-modules (cons "omap_hsmmc" %base-initrd-modules)) (initrd-modules (cons "omap_hsmmc" %base-initrd-modules))
(file-systems (cons (file-system (file-systems (cons (file-system
(device "my-root") (device (file-system-label "my-root"))
(title 'label)
(mount-point "/") (mount-point "/")
(type "ext4")) (type "ext4"))
%base-file-systems)) %base-file-systems))

View File

@ -20,13 +20,11 @@
;; Assume the target root file system is labelled "my-root", ;; Assume the target root file system is labelled "my-root",
;; and the EFI System Partition has UUID 1234-ABCD. ;; and the EFI System Partition has UUID 1234-ABCD.
(file-systems (cons* (file-system (file-systems (cons* (file-system
(device "my-root") (device (file-system-label "my-root"))
(title 'label)
(mount-point "/") (mount-point "/")
(type "ext4")) (type "ext4"))
(file-system (file-system
(device (uuid "1234-ABCD" 'fat)) (device (uuid "1234-ABCD" 'fat))
(title 'uuid)
(mount-point "/boot/efi") (mount-point "/boot/efi")
(type "vfat")) (type "vfat"))
%base-file-systems)) %base-file-systems))

View File

@ -31,8 +31,7 @@ partprobe, and then 2) resizing the filesystem with resize2fs.\n"))
(target "/dev/sda") (target "/dev/sda")
(terminal-outputs '(console)))) (terminal-outputs '(console))))
(file-systems (cons (file-system (file-systems (cons (file-system
(device "my-root") (device (file-system-label "my-root"))
(title 'label)
(mount-point "/") (mount-point "/")
(type "ext4")) (type "ext4"))
%base-file-systems)) %base-file-systems))

View File

@ -20,6 +20,8 @@
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (rnrs bytevectors) #:use-module (rnrs bytevectors)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu)
#:use-module (guix records) #:use-module (guix records)
#:use-module (gnu system uuid) #:use-module (gnu system uuid)
#:re-export (uuid ;backward compatibility #:re-export (uuid ;backward compatibility
@ -28,7 +30,7 @@
#:export (file-system #:export (file-system
file-system? file-system?
file-system-device file-system-device
file-system-title file-system-title ;deprecated
file-system-mount-point file-system-mount-point
file-system-type file-system-type
file-system-needed-for-boot? file-system-needed-for-boot?
@ -42,6 +44,10 @@
file-system-type-predicate file-system-type-predicate
file-system-label
file-system-label?
file-system-label->string
file-system->spec file-system->spec
spec->file-system spec->file-system
specification->file-system-mapping specification->file-system-mapping
@ -82,12 +88,10 @@
;;; Code: ;;; Code:
;; File system declaration. ;; File system declaration.
(define-record-type* <file-system> file-system (define-record-type* <file-system> %file-system
make-file-system make-file-system
file-system? file-system?
(device file-system-device) ; string (device file-system-device) ; string | <uuid> | <file-system-label>
(title file-system-title ; 'device | 'label | 'uuid
(default 'device))
(mount-point file-system-mount-point) ; string (mount-point file-system-mount-point) ; string
(type file-system-type) ; string (type file-system-type) ; string
(flags file-system-flags ; list of symbols (flags file-system-flags ; list of symbols
@ -108,6 +112,83 @@
(default (current-source-location)) (default (current-source-location))
(innate))) (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. ;; 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 ;; Arrange not to pull (guix store) and (guix config) because the latter
;; differs from user to user. ;; 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 "Return a list corresponding to file-system FS that can be passed to the
initrd code." initrd code."
(match fs (match fs
(($ <file-system> device title mount-point type flags options _ _ check?) (($ <file-system> device mount-point type flags options _ _ check?)
(list (if (uuid? device) (list (cond ((uuid? device)
`(uuid ,(uuid-type device) ,(uuid-bytevector device)) `(uuid ,(uuid-type device) ,(uuid-bytevector device)))
device) ((file-system-label? device)
title mount-point type flags options check?)))) `(file-system-label ,(file-system-label->string device)))
(else device))
mount-point type flags options check?))))
(define (spec->file-system sexp) (define (spec->file-system sexp)
"Deserialize SEXP, a list, to the corresponding <file-system> object." "Deserialize SEXP, a list, to the corresponding <file-system> object."
(match sexp (match sexp
((device title mount-point type flags options check?) ((device mount-point type flags options check?)
(file-system (file-system
(device (match device (device (match device
(('uuid (? symbol? type) (? bytevector? bv)) (('uuid (? symbol? type) (? bytevector? bv))
(bytevector->uuid bv type)) (bytevector->uuid bv type))
(('file-system-label (? string? label))
(file-system-label label))
(_ (_
device))) device)))
(title title)
(mount-point mount-point) (type type) (mount-point mount-point) (type type)
(flags flags) (options options) (flags flags) (options options)
(check? check?))))) (check? check?)))))

View File

@ -693,13 +693,12 @@ environment with the store shared with the host. MAPPINGS is a list of
(source (file-system-device fs))) (source (file-system-device fs)))
(or (string=? target (%store-prefix)) (or (string=? target (%store-prefix))
(string=? target "/") (string=? target "/")
(and (eq? 'device (file-system-title fs)) (and (string? source)
(string-prefix? "/dev/" source)) (string-prefix? "/dev/" source))
;; Labels and UUIDs are necessarily invalid in the VM. ;; Labels and UUIDs are necessarily invalid in the VM.
(and (file-system-mount? fs) (and (file-system-mount? fs)
(or (eq? 'label (file-system-title fs)) (or (file-system-label? source)
(eq? 'uuid (file-system-title fs))
(uuid? source)))))) (uuid? source))))))
(operating-system-file-systems os))) (operating-system-file-systems os)))

View File

@ -590,17 +590,17 @@ any, are available. Raise an error if they're not."
(define labeled (define labeled
(filter (lambda (fs) (filter (lambda (fs)
(eq? (file-system-title fs) 'label)) (file-system-label? (file-system-device fs)))
relevant)) relevant))
(define literal (define literal
(filter (lambda (fs) (filter (lambda (fs)
(eq? (file-system-title fs) 'device)) (string? (file-system-device fs)))
relevant)) relevant))
(define uuid (define uuid
(filter (lambda (fs) (filter (lambda (fs)
(eq? (file-system-title fs) 'uuid)) (uuid? (file-system-device fs)))
relevant)) relevant))
(define fail? #f) (define fail? #f)
@ -628,15 +628,15 @@ any, are available. Raise an error if they're not."
(strerror errno)) (strerror errno))
(unless (string-prefix? "/" device) (unless (string-prefix? "/" device)
(display-hint (format #f (G_ "If '~a' is a file system (display-hint (format #f (G_ "If '~a' is a file system
label, you need to add @code{(title 'label)} to your @code{file-system} label, write @code{(file-system-label ~s)} in your @code{device} field.")
definition.") device device)))))))
device)))))))
literal) literal)
(for-each (lambda (fs) (for-each (lambda (fs)
(unless (find-partition-by-label (file-system-device fs)) (let ((label (file-system-label->string
(error (G_ "~a: error: file system with label '~a' not found~%") (file-system-device fs))))
(file-system-location* fs) (unless (find-partition-by-label label)
(file-system-device fs)))) (error (G_ "~a: error: file system with label '~a' not found~%")
(file-system-location* fs) label))))
labeled) labeled)
(for-each (lambda (fs) (for-each (lambda (fs)
(unless (find-partition-by-uuid (file-system-device fs)) (unless (find-partition-by-uuid (file-system-device fs))
@ -677,10 +677,13 @@ available in the initrd. Note that mapped devices are responsible for
checking this by themselves in their 'check' procedure." checking this by themselves in their 'check' procedure."
(define (file-system-/dev fs) (define (file-system-/dev fs)
(let ((device (file-system-device fs))) (let ((device (file-system-device fs)))
(match (file-system-title fs) (match device
('device device) ((? string?)
('uuid (find-partition-by-uuid device)) device)
('label (find-partition-by-label device))))) ((? uuid?)
(find-partition-by-uuid device))
((? file-system-label?)
(find-partition-by-label (file-system-label->string device))))))
(define file-systems (define file-systems
(filter file-system-needed-for-boot? (filter file-system-needed-for-boot?