aboutsummaryrefslogtreecommitdiff
path: root/gnu
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2018-05-18 13:43:07 +0200
committerLudovic Courtès <ludo@gnu.org>2018-05-28 13:24:11 +0200
commita5acc17a3c10a3779b5b8b1a2565ef130be77e51 (patch)
tree988afc136bcdb5848543167375118283a958fb38 /gnu
parent25816c4306ff7d4cec21a3f0e7ce917aea75385f (diff)
downloadguix-a5acc17a3c10a3779b5b8b1a2565ef130be77e51.tar
guix-a5acc17a3c10a3779b5b8b1a2565ef130be77e51.tar.gz
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'.
Diffstat (limited to 'gnu')
-rw-r--r--gnu/bootloader/grub.scm10
-rw-r--r--gnu/build/file-systems.scm54
-rw-r--r--gnu/build/linux-boot.scm12
-rw-r--r--gnu/services/base.scm17
-rw-r--r--gnu/system.scm38
-rw-r--r--gnu/system/examples/bare-bones.tmpl3
-rw-r--r--gnu/system/examples/beaglebone-black.tmpl3
-rw-r--r--gnu/system/examples/lightweight-desktop.tmpl4
-rw-r--r--gnu/system/examples/vm-image.tmpl3
-rw-r--r--gnu/system/file-systems.scm108
-rw-r--r--gnu/system/vm.scm5
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)))