From 3e629738a3acd908acc510023c85db448e3553c3 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Fri, 23 Mar 2018 02:16:14 -0400 Subject: gnu: cross-base: Use invoke in (gnu build cross-toolchain). * gnu/build/cross-toolchain.scm (set-cross-path/mingw, install-strip): Use invoke. --- gnu/build/cross-toolchain.scm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'gnu/build') diff --git a/gnu/build/cross-toolchain.scm b/gnu/build/cross-toolchain.scm index 450443ca6..d430b8afc 100644 --- a/gnu/build/cross-toolchain.scm +++ b/gnu/build/cross-toolchain.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès -;;; Copyright © 2014, 2015 Mark H Weaver +;;; Copyright © 2014, 2015, 2018 Mark H Weaver ;;; Copyright © 2016 Jan Nieuwenhuizen ;;; Copyright © 2016 Manolis Fragkiskos Ragkousis ;;; @@ -119,7 +119,7 @@ C_*INCLUDE_PATH." ;; libc is false, so we are building xgcc-sans-libc. ;; Add essential headers from mingw-w64. (let ((mingw-source (assoc-ref inputs "mingw-source"))) - (system* "tar" "xvf" mingw-source) + (invoke "tar" "xvf" mingw-source) (let ((mingw-headers (unpacked-mingw-dir))) ;; We need _mingw.h which will gets built from _mingw.h.in by ;; mingw-w64's configure. We cannot configure mingw-w64 until we @@ -160,7 +160,7 @@ C_*INCLUDE_PATH." "Install a stripped GCC." ;; Unlike our 'strip' phase, this will do the right thing for ;; cross-compilers. - (zero? (system* "make" "install-strip"))) + (invoke "make" "install-strip")) (define* (cross-gcc-build-phases target #:optional (phases %standard-phases)) -- cgit v1.3 From 353df40102b209a06376044af946a28c2594377b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 23 May 2018 10:14:20 +0200 Subject: vm: Print the label and UUID of partitions. * gnu/build/vm.scm (create-ext-file-system): Print the label and UUID. --- gnu/build/vm.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'gnu/build') diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm index 527b4c495..989b74f4f 100644 --- a/gnu/build/vm.scm +++ b/gnu/build/vm.scm @@ -265,7 +265,8 @@ actual /dev name based on DEVICE." #:key label uuid) "Create an ext-family file system of TYPE on PARTITION. If LABEL is true, use that as the volume name. If UUID is true, use it as the partition UUID." - (format #t "creating ~a partition...\n" type) + (format #t "creating ~a partition... ~@[label: ~s~] ~@[uuid: ~s~]\n" + type label (and uuid (uuid->string uuid))) (apply invoke (string-append "mkfs." type) "-F" partition `(,@(if label -- cgit v1.3 From 98e0b1288f387165f5a2240cb98f2ae1f8d2fc8a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 25 May 2018 12:04:22 +0200 Subject: vm: Pass "panic=1" to Linux. * gnu/build/vm.scm (load-in-linux-vm): Always pass "panic=1" after '-append'. --- gnu/build/vm.scm | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) (limited to 'gnu/build') diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm index 989b74f4f..fa3ce7790 100644 --- a/gnu/build/vm.scm +++ b/gnu/build/vm.scm @@ -106,11 +106,16 @@ the #:references-graphs parameter of 'derivation'." (not target-arm32?)) '("-enable-kvm") '()) + + ;; Pass "panic=1" so that the guest dies upon error. "-append" - ;; The serial port name differs between emulated architectures/machines. - ,@(if target-arm32? - `(,(string-append "console=ttyAMA0 --load=" builder)) - `(,(string-append "console=ttyS0 --load=" builder))) + ,(string-append "panic=1 --load=" builder + + ;; The serial port name differs between emulated + ;; architectures/machines. + " console=" + (if target-arm32? "ttyAMA0" "ttyS0")) + ;; NIC is not supported on ARM "virt" machine, so use a user mode ;; network stack instead. ,@(if target-arm32? -- cgit v1.3 From a5acc17a3c10a3779b5b8b1a2565ef130be77e51 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 18 May 2018 13:43:07 +0200 Subject: file-systems: Remove 'title' field and add . 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 (): Change constructor name to '%file-system'. [title]: Remove. (): 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 . * 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'. --- doc/guix.texi | 48 ++++++------ gnu/bootloader/grub.scm | 10 ++- gnu/build/file-systems.scm | 54 ++++---------- gnu/build/linux-boot.scm | 12 ++- gnu/services/base.scm | 17 ++--- gnu/system.scm | 38 +++++----- gnu/system/examples/bare-bones.tmpl | 3 +- gnu/system/examples/beaglebone-black.tmpl | 3 +- gnu/system/examples/lightweight-desktop.tmpl | 4 +- gnu/system/examples/vm-image.tmpl | 3 +- gnu/system/file-systems.scm | 108 ++++++++++++++++++++++++--- gnu/system/vm.scm | 5 +- guix/scripts/system.scm | 31 ++++---- 13 files changed, 202 insertions(+), 134 deletions(-) (limited to 'gnu/build') diff --git a/doc/guix.texi b/doc/guix.texi index 5129b998b..5eee40fc3 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -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. @item @code{device} -This names the ``source'' of the file system. By default it is the name -of a node under @file{/dev}, but its meaning depends on the @code{title} -field described below. +This names the ``source'' of the file system. It can be one of three +things: a file system label, a file system UUID, or the name of a +@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}) -This is a symbol that specifies how the @code{device} field is to be -interpreted. +@findex file-system-label +File system labels are created using the @code{file-system-label} +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 -interpreted as a file name; when it is @code{label}, then @code{device} -is interpreted as a file system label name; when it is @code{uuid}, -@code{device} is interpreted as a file system unique identifier (UUID). +@example +(file-system + (mount-point "/home") + (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 @code{uuid} form expects 16-byte UUIDs as defined in @uref{https://tools.ietf.org/html/rfc4122, RFC@tie{}4122}. This is the @@ -9235,22 +9246,13 @@ like this: (file-system (mount-point "/home") (type "ext4") - (title 'uuid) (device (uuid "4dab5feb-d176-45de-b287-9b0a6e4c01cb"))) @end example -The @code{label} and @code{uuid} options 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.}. - -However, when the source of a file system is a mapped device (@pxref{Mapped +When the source of a file system is a mapped device (@pxref{Mapped Devices}), its @code{device} field @emph{must} refer to the mapped -device name---e.g., @file{/dev/mapper/root-partition}---and consequently -@code{title} must be set to @code{'device}. This is required so that +device name---e.g., @file{"/dev/mapper/root-partition"}. +This is required so that the system knows that mounting the file system depends on having the corresponding device mapping established. diff --git a/gnu/bootloader/grub.scm b/gnu/bootloader/grub.scm index 3b01125c7..eca6d97b1 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 +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès ;;; Copyright © 2016 Chris Marusich ;;; Copyright © 2017 Leo Famulari ;;; Copyright © 2017 Mathieu Othacehe @@ -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 145b3b14e..3dd7358fd 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 +;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès ;;; Copyright © 2016, 2017 David Craven ;;; Copyright © 2017 Mathieu Othacehe ;;; @@ -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 , a +, 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 18d87260a..44b350628 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 eb82b2ddc..09a1ce95e 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 1052e9355..288c1e880 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 object, return a value suitable for use as the -device in a ." - (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 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 ." (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 ." (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 7e0c8fbee..cb6d2623d 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 97201330c..d1130c76b 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 65a8ee180..360ee62ff 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 ce3653c8b..36e272722 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 93289dbd5..2b5948256 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 +(define-record-type* %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 | | (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 label) + file-system-label? + (label file-system-label->string)) + +(set-record-type-printer! + (lambda (obj port) + (format port "#" + (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 - (($ 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?)))) + (($ 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 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 eb73b5ca7..7f8014715 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))) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index af501eb8f..5d0df1492 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -590,17 +590,17 @@ any, are available. Raise an error if they're not." (define labeled (filter (lambda (fs) - (eq? (file-system-title fs) 'label)) + (file-system-label? (file-system-device fs))) relevant)) (define literal (filter (lambda (fs) - (eq? (file-system-title fs) 'device)) + (string? (file-system-device fs))) relevant)) (define uuid (filter (lambda (fs) - (eq? (file-system-title fs) 'uuid)) + (uuid? (file-system-device fs))) relevant)) (define fail? #f) @@ -628,15 +628,15 @@ any, are available. Raise an error if they're not." (strerror errno)) (unless (string-prefix? "/" device) (display-hint (format #f (G_ "If '~a' is a file system -label, you need to add @code{(title 'label)} to your @code{file-system} -definition.") - device))))))) +label, write @code{(file-system-label ~s)} in your @code{device} field.") + device device))))))) literal) (for-each (lambda (fs) - (unless (find-partition-by-label (file-system-device fs)) - (error (G_ "~a: error: file system with label '~a' not found~%") - (file-system-location* fs) - (file-system-device fs)))) + (let ((label (file-system-label->string + (file-system-device fs)))) + (unless (find-partition-by-label label) + (error (G_ "~a: error: file system with label '~a' not found~%") + (file-system-location* fs) label)))) labeled) (for-each (lambda (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." (define (file-system-/dev fs) (let ((device (file-system-device fs))) - (match (file-system-title fs) - ('device device) - ('uuid (find-partition-by-uuid device)) - ('label (find-partition-by-label device))))) + (match device + ((? string?) + device) + ((? uuid?) + (find-partition-by-uuid device)) + ((? file-system-label?) + (find-partition-by-label (file-system-label->string device)))))) (define file-systems (filter file-system-needed-for-boot? -- cgit v1.3 From 9ceeca0880248eee8c2796f5e6ebc172b95277f7 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 18 May 2018 15:04:36 +0200 Subject: system: Remove uses of the 'title' field of . * gnu/system/install.scm (installation-os): Remove uses of the 'title' field of 'file-system'; use 'file-system-label' as appropriate. * gnu/system/vm.scm (system-disk-image, system-qemu-image): Likewise. * gnu/tests.scm (%simple-os): Likewise. * gnu/tests/install.scm (%minimal-os, %minimal-extlinux-os) (%minimal-os-on-vda, %separate-home-os, %separate-store-os) (%raid-root-os, %encrypted-root-os, %btrfs-root-os): Likewise. * gnu/build/shepherd.scm (default-mounts)[tmpfs]: Likewise. * tests/guix-system.sh: Likewise. * tests/system.scm (%root-fs): Likewise. ("operating-system-boot-mapped-devices, implicit dependency"): Likewise. --- gnu/build/shepherd.scm | 3 +-- gnu/system/install.scm | 4 +--- gnu/system/vm.scm | 2 -- gnu/tests.scm | 3 +-- gnu/tests/install.scm | 26 ++++++++------------------ tests/guix-system.sh | 9 +++------ tests/system.scm | 6 ++---- 7 files changed, 16 insertions(+), 37 deletions(-) (limited to 'gnu/build') diff --git a/gnu/build/shepherd.scm b/gnu/build/shepherd.scm index c955e3c83..f38325992 100644 --- a/gnu/build/shepherd.scm +++ b/gnu/build/shepherd.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017 Ludovic Courtès +;;; Copyright © 2017, 2018 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -55,7 +55,6 @@ (define (tmpfs directory) (file-system (device "none") - (title 'device) (mount-point directory) (type "tmpfs") (check? #f))) diff --git a/gnu/system/install.scm b/gnu/system/install.scm index 3efff915a..acc9f15e0 100644 --- a/gnu/system/install.scm +++ b/gnu/system/install.scm @@ -328,8 +328,7 @@ You have been warned. Thanks for being so brave.\x1b[0m ;; the appropriate one. (cons* (file-system (mount-point "/") - (device "GuixSD_image") - (title 'label) + (device (file-system-label "GuixSD_image")) (type "ext4")) ;; Make /tmp a tmpfs instead of keeping the overlayfs. This @@ -341,7 +340,6 @@ You have been warned. Thanks for being so brave.\x1b[0m (file-system (mount-point "/tmp") (device "none") - (title 'device) (type "tmpfs") (check? #f)) diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 7f8014715..4cffc71d7 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -571,7 +571,6 @@ to USB sticks meant to be read-only." (file-systems (cons (file-system (mount-point "/") (device root-uuid) - (title 'uuid) (type file-system-type)) file-systems-to-keep))))) @@ -636,7 +635,6 @@ of the GNU system as described by OS." (file-systems (cons (file-system (mount-point "/") (device root-uuid) - (title 'uuid) (type file-system-type)) file-systems-to-keep))))) (mlet* %store-monad diff --git a/gnu/tests.scm b/gnu/tests.scm index 2aef370af..5d4a4f806 100644 --- a/gnu/tests.scm +++ b/gnu/tests.scm @@ -208,8 +208,7 @@ the system under test." (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/tests/install.scm b/gnu/tests/install.scm index e3bb1b46a..4764ffffd 100644 --- a/gnu/tests/install.scm +++ b/gnu/tests/install.scm @@ -66,8 +66,7 @@ (target "/dev/vdb"))) (kernel-arguments '("console=ttyS0")) (file-systems (cons (file-system - (device "my-root") - (title 'label) + (device (file-system-label "my-root")) (mount-point "/") (type "ext4")) %base-file-systems)) @@ -105,8 +104,7 @@ (target "/dev/vdb"))) (kernel-arguments '("console=ttyS0")) (file-systems (cons (file-system - (device "my-root") - (title 'label) + (device (file-system-label "my-root")) (mount-point "/") (type "ext4")) %base-file-systems)) @@ -351,8 +349,7 @@ per %test-installed-os, this test is expensive in terms of CPU and storage.") (target "/dev/vda"))) (kernel-arguments '("console=ttyS0")) (file-systems (cons (file-system - (device "my-root") - (title 'label) + (device (file-system-label "my-root")) (mount-point "/") (type "ext4")) %base-file-systems)) @@ -428,13 +425,11 @@ reboot\n") (target "/dev/vdb"))) (kernel-arguments '("console=ttyS0")) (file-systems (cons* (file-system - (device "my-root") - (title 'label) + (device (file-system-label "my-root")) (mount-point "/") (type "ext4")) (file-system (device "none") - (title 'device) (type "tmpfs") (mount-point "/home") (type "tmpfs")) @@ -488,13 +483,11 @@ partition. In particular, home directories must be correctly created (see (target "/dev/vdb"))) (kernel-arguments '("console=ttyS0")) (file-systems (cons* (file-system - (device "root-fs") - (title 'label) + (device (file-system-label "root-fs")) (mount-point "/") (type "ext4")) (file-system - (device "store-fs") - (title 'label) + (device (file-system-label "store-fs")) (mount-point "/gnu") (type "ext4")) %base-file-systems)) @@ -574,8 +567,7 @@ where /gnu lives on a separate partition.") (target "/dev/md0") (type raid-device-mapping)))) (file-systems (cons (file-system - (device "root-fs") - (title 'label) + (device (file-system-label "root-fs")) (mount-point "/") (type "ext4") (dependencies mapped-devices)) @@ -658,7 +650,6 @@ by 'mdadm'.") (type luks-device-mapping)))) (file-systems (cons (file-system (device "/dev/mapper/the-root-device") - (title 'device) (mount-point "/") (type "ext4")) %base-file-systems)) @@ -779,8 +770,7 @@ build (current-guix) and then store a couple of full system images.") (target "/dev/vdb"))) (kernel-arguments '("console=ttyS0")) (file-systems (cons (file-system - (device "my-root") - (title 'label) + (device (file-system-label "my-root")) (mount-point "/") (type "btrfs")) %base-file-systems)) diff --git a/tests/guix-system.sh b/tests/guix-system.sh index 2b94bc051..36ba5fbd5 100644 --- a/tests/guix-system.sh +++ b/tests/guix-system.sh @@ -111,8 +111,7 @@ cat > "$tmpfile" < +;;; Copyright © 2016, 2018 Ludovic Courtès ;;; Copyright © 2017 Tobias Geerinckx-Rice ;;; ;;; This file is part of GNU Guix. @@ -27,8 +27,7 @@ (define %root-fs (file-system - (device "my-root") - (title 'label) + (device (file-system-label "my-root")) (mount-point "/") (type "ext4"))) @@ -114,7 +113,6 @@ (inherit %os-with-mapped-device) (file-systems (cons (file-system (device "/dev/mapper/my-luks-device") - (title 'device) (mount-point "/") (type "ext4")) %base-file-systems))))) -- cgit v1.3 From 69a05eab355f410e38ffd69007b9b8d740d92b59 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 31 May 2018 16:52:01 +0200 Subject: file-systems: Always wait for devices to show up. Previously, 'canonicalize-device-spec' would wait for devices when they were specified as a label or UUID, but would not wait when the user passed a "/dev" file name directly. This could cause problems when the /dev node takes a while to show up. * gnu/build/file-systems.scm (canonicalize-device-spec): Add 'resolve' call in the 'string?' case. --- gnu/build/file-systems.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'gnu/build') diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm index 3dd7358fd..3f97afeed 100644 --- a/gnu/build/file-systems.scm +++ b/gnu/build/file-systems.scm @@ -499,8 +499,8 @@ were found." (match spec ((? string?) - ;; Nothing to do. - spec) + ;; Nothing to do, but wait until SPEC shows up. + (resolve identity spec identity)) ((? file-system-label?) ;; Resolve the label. (resolve find-partition-by-label -- cgit v1.3 From 7a4e2eaab34f7fad6951f312203ac0d9dfa3d44a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 1 Jun 2018 10:01:05 +0200 Subject: marionette: Add 'wait-for-tcp-port'. * gnu/build/marionette.scm (wait-for-tcp-port): New procedure. * gnu/tests/dict.scm (run-dicod-test)["connect inside"]: Use it instead of the inline loop. --- gnu/build/marionette.scm | 27 +++++++++++++++++++++++++++ gnu/tests/dict.scm | 19 ++----------------- 2 files changed, 29 insertions(+), 17 deletions(-) (limited to 'gnu/build') diff --git a/gnu/build/marionette.scm b/gnu/build/marionette.scm index 173a67cef..bb018fc9c 100644 --- a/gnu/build/marionette.scm +++ b/gnu/build/marionette.scm @@ -26,6 +26,7 @@ make-marionette marionette-eval wait-for-file + wait-for-tcp-port marionette-control marionette-screen-text wait-for-screen-text @@ -187,6 +188,32 @@ FILE has not shown up after TIMEOUT seconds, raise an error." ('failure (error "file didn't show up" file)))) +(define* (wait-for-tcp-port port marionette + #:key (timeout 20)) + "Wait for up to TIMEOUT seconds for PORT to accept connections in +MARIONETTE. Raise an error on failure." + ;; Note: The 'connect' loop has to run within the guest because, when we + ;; forward ports to the host, connecting to the host never raises + ;; ECONNREFUSED. + (match (marionette-eval + `(begin + (let ((sock (socket PF_INET SOCK_STREAM 0))) + (let loop ((i 0)) + (catch 'system-error + (lambda () + (connect sock AF_INET INADDR_LOOPBACK ,port) + 'success) + (lambda args + (if (< i ,timeout) + (begin + (sleep 1) + (loop (+ 1 i))) + 'failure)))))) + marionette) + ('success #t) + ('failure + (error "nobody's listening on port" port)))) + (define (marionette-control command marionette) "Run COMMAND in the QEMU monitor of MARIONETTE. COMMAND is a string such as \"sendkey ctrl-alt-f1\" or \"screendump foo.ppm\" (info \"(qemu-doc) diff --git a/gnu/tests/dict.scm b/gnu/tests/dict.scm index b9c741e3e..4431e37dc 100644 --- a/gnu/tests/dict.scm +++ b/gnu/tests/dict.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017 Ludovic Courtès +;;; Copyright © 2017, 2018 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -96,22 +96,7 @@ ;; Wait until dicod is actually listening. ;; TODO: Use a PID file instead. (test-assert "connect inside" - (marionette-eval - '(begin - (use-modules (ice-9 rdelim)) - (let ((sock (socket PF_INET SOCK_STREAM 0))) - (let loop ((i 0)) - (pk 'try i) - (catch 'system-error - (lambda () - (connect sock AF_INET INADDR_LOOPBACK 2628)) - (lambda args - (pk 'connection-error args) - (when (< i 20) - (sleep 1) - (loop (+ 1 i)))))) - (read-line sock 'concat))) - marionette)) + (wait-for-tcp-port 2628 marionette)) (test-assert "connect" (let ((addr (make-socket-address AF_INET INADDR_LOOPBACK 8000))) -- cgit v1.3 From 33d8a871042e73d6b236793d02e5a8287a47ebe4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 28 May 2018 21:47:01 +0200 Subject: bootloader: grub: Use 'with-extensions'. * gnu/bootloader/grub.scm (svg->png): Use 'with-extensions'. Remove 'add-to-load-path' calls. * gnu/build/svg.scm: Use (rsvg) and (cairo) the normal way. Remove 'module-autoload!' calls. --- gnu/bootloader/grub.scm | 19 ++++++------------- gnu/build/svg.scm | 11 +++-------- 2 files changed, 9 insertions(+), 21 deletions(-) (limited to 'gnu/build') diff --git a/gnu/bootloader/grub.scm b/gnu/bootloader/grub.scm index e90a6a11e..a131f3b50 100644 --- a/gnu/bootloader/grub.scm +++ b/gnu/bootloader/grub.scm @@ -123,19 +123,12 @@ otherwise." "Build a PNG of HEIGHT x WIDTH from SVG." (gexp->derivation "grub-image.png" (with-imported-modules '((gnu build svg)) - #~(begin - ;; We need these two libraries. - (add-to-load-path (string-append #+guile-rsvg - "/share/guile/site/" - (effective-version))) - (add-to-load-path (string-append #+guile-cairo - "/share/guile/site/" - (effective-version))) - - (use-modules (gnu build svg)) - (svg->png #+svg #$output - #:width #$width - #:height #$height))))) + (with-extensions (list guile-rsvg guile-cairo) + #~(begin + (use-modules (gnu build svg)) + (svg->png #+svg #$output + #:width #$width + #:height #$height)))))) (define* (grub-background-image config #:key (width 1024) (height 768)) "Return the GRUB background image defined in CONFIG with a ratio of diff --git a/gnu/build/svg.scm b/gnu/build/svg.scm index b5474ec4a..6f1f4b368 100644 --- a/gnu/build/svg.scm +++ b/gnu/build/svg.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016, 2017 Ludovic Courtès +;;; Copyright © 2016, 2017, 2018 Ludovic Courtès ;;; Copyright © 2015 Andy Wingo ;;; ;;; This file is part of GNU Guix. @@ -18,16 +18,11 @@ ;;; along with GNU Guix. If not, see . (define-module (gnu build svg) + #:use-module (rsvg) + #:use-module (cairo) #:use-module (srfi srfi-11) #:export (svg->png)) -;; We need Guile-RSVG and Guile-Cairo. Load them lazily, at run time, to -;; allow compilation to proceed. See also . -(module-autoload! (current-module) - '(rsvg) '(rsvg-handle-new-from-file)) -(module-autoload! (current-module) - '(cairo) '(cairo-image-surface-create)) - (define* (downscaled-surface surface #:key source-width source-height -- cgit v1.3