diff options
Diffstat (limited to 'gnu')
| -rw-r--r-- | gnu/bootloader/grub.scm | 10 | ||||
| -rw-r--r-- | gnu/build/file-systems.scm | 54 | ||||
| -rw-r--r-- | gnu/build/linux-boot.scm | 12 | ||||
| -rw-r--r-- | gnu/services/base.scm | 17 | ||||
| -rw-r--r-- | gnu/system.scm | 38 | ||||
| -rw-r--r-- | gnu/system/examples/bare-bones.tmpl | 3 | ||||
| -rw-r--r-- | gnu/system/examples/beaglebone-black.tmpl | 3 | ||||
| -rw-r--r-- | gnu/system/examples/lightweight-desktop.tmpl | 4 | ||||
| -rw-r--r-- | gnu/system/examples/vm-image.tmpl | 3 | ||||
| -rw-r--r-- | gnu/system/file-systems.scm | 108 | ||||
| -rw-r--r-- | gnu/system/vm.scm | 5 |
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))) |