diff options
Diffstat (limited to 'gnu/system')
| -rw-r--r-- | gnu/system/file-systems.scm | 86 | ||||
| -rw-r--r-- | gnu/system/linux-initrd.scm | 29 | ||||
| -rw-r--r-- | gnu/system/vm.scm | 15 |
3 files changed, 109 insertions, 21 deletions
diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm index b41f66e943..0f94577760 100644 --- a/gnu/system/file-systems.scm +++ b/gnu/system/file-systems.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net> +;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -21,7 +22,10 @@ #:use-module (ice-9 match) #:use-module (rnrs bytevectors) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-2) #:use-module (srfi srfi-9) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-35) #:use-module (srfi srfi-9 gnu) #:use-module (guix records) #:use-module (gnu system uuid) @@ -38,6 +42,9 @@ file-system-needed-for-boot? file-system-flags file-system-options + file-system-options->alist + alist->file-system-options + file-system-mount? file-system-check? file-system-create-mount-point? @@ -45,6 +52,8 @@ file-system-location file-system-type-predicate + btrfs-subvolume? + btrfs-store-subvolume-file-name file-system-label file-system-label? @@ -251,6 +260,33 @@ UUID-TYPE, a symbol such as 'dce or 'iso9660." ((? string?) device))) +(define (file-system-options->alist string) + "Translate the option string format of a <file-system> record into an +association list of options or option/value pairs." + (if string + (let ((options (string-split string #\,))) + (map (lambda (param) + (let ((=index (string-index param #\=))) + (if =index + (cons (string-take param =index) + (string-drop param (1+ =index))) + param))) + options)) + '())) + +(define (alist->file-system-options options) + "Return the string representation of OPTIONS, an association list. The +string obtained can be used as the option field of a <file-system> record." + (if (null? options) + #f + (string-join (map (match-lambda + ((key . value) + (string-append key "=" value)) + (key + key)) + options) + ","))) + (define (file-system-needed-for-boot? fs) "Return true if FS has the 'needed-for-boot?' flag set, or if it holds the store--e.g., if FS is the root file system." @@ -535,4 +571,54 @@ system has the given TYPE." (lambda (fs) (string=? (file-system-type fs) type))) + +;;; +;;; Btrfs specific helpers. +;;; + +(define (btrfs-subvolume? fs) + "Predicate to check if FS, a file-system object, is a Btrfs subvolume." + (and-let* ((btrfs-file-system? (string= "btrfs" (file-system-type fs))) + (option-keys (map (match-lambda + ((key . value) key) + (key key)) + (file-system-options->alist + (file-system-options fs))))) + (find (cut string-prefix? "subvol" <>) option-keys))) + +(define (btrfs-store-subvolume-file-name file-systems) + "Return the subvolume file name within the Btrfs top level onto which the +store is located, else #f." + + (define (prepend-slash/maybe s) + (if (string=? "/" (string-take s 1)) + s + (string-append "/" s))) + + (define (file-name-depth file-name) + (length (string-tokenize file-name %not-slash))) + + (and-let* ((btrfs-subvolume-fs (filter btrfs-subvolume? file-systems)) + (btrfs-subvolume-fs* + (sort btrfs-subvolume-fs + (lambda (fs1 fs2) + (> (file-name-depth (file-system-mount-point fs1)) + (file-name-depth (file-system-mount-point fs2)))))) + (store-subvolume-fs + (find (lambda (fs) (file-prefix? (file-system-mount-point fs) + (%store-prefix))) + btrfs-subvolume-fs*)) + (options (file-system-options->alist + (file-system-options store-subvolume-fs)))) + ;; XXX: Deriving the subvolume name based from a subvolume ID is not + ;; supported, as we'd need to query the actual file system. + (or (and=> (assoc-ref options "subvol") prepend-slash/maybe) + ;; FIXME: Use &fix-hint once it no longer pulls in (guix utils). + (raise (condition + (&message + (message "The store is on a Btrfs subvolume, but the \ +subvolume name is unknown. +Hint: Use the \"subvol\" Btrfs file system option."))))))) + + ;;; file-systems.scm ends here diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm index c43d53a210..0971ec29e2 100644 --- a/gnu/system/linux-initrd.scm +++ b/gnu/system/linux-initrd.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2016 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org> ;;; Copyright © 2017, 2019 Mathieu Othacehe <m.othacehe@gmail.com> @@ -197,7 +197,7 @@ upon error." #~(begin (use-modules (gnu build linux-boot) (gnu system file-systems) - (guix build utils) + ((guix build utils) #:hide (delete)) (guix build bournish) ;add the 'bournish' meta-command (srfi srfi-26) @@ -213,18 +213,19 @@ upon error." (set-path-environment-variable "PATH" '("bin" "sbin") '#$helper-packages))) - (boot-system #:mounts - (map spec->file-system - '#$(map file-system->spec file-systems)) - #:pre-mount (lambda () - (and #$@device-mapping-commands)) - #:linux-modules '#$linux-modules - #:linux-module-directory '#$kodir - #:keymap-file #+(and=> keyboard-layout - keyboard-layout->console-keymap) - #:qemu-guest-networking? #$qemu-networking? - #:volatile-root? '#$volatile-root? - #:on-error '#$on-error))) + (parameterize ((current-warning-port (%make-void-port "w"))) + (boot-system #:mounts + (map spec->file-system + '#$(map file-system->spec file-systems)) + #:pre-mount (lambda () + (and #$@device-mapping-commands)) + #:linux-modules '#$linux-modules + #:linux-module-directory '#$kodir + #:keymap-file #+(and=> keyboard-layout + keyboard-layout->console-keymap) + #:qemu-guest-networking? #$qemu-networking? + #:volatile-root? '#$volatile-root? + #:on-error '#$on-error)))) #:name "raw-initrd")) (define* (file-system-packages file-systems #:key (volatile-root? #f)) diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 163e8b4e9c..3e483fd86c 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -199,6 +199,10 @@ substitutable." (sync) (reboot)))) + (define-syntax-rule (check predicate) + (let-system (system target) + (predicate (or target system)))) + (let ((initrd (or initrd (base-initrd file-systems #:on-error 'backtrace @@ -229,7 +233,8 @@ substitutable." (graphs '#$(match references-graphs (((graph-files . _) ...) graph-files) (_ #f))) - (target #$(or (%current-target-system) (%current-system))) + (target #$(let-system (system target) + (or target system))) (size #$(if (eq? 'guess disk-image-size) #~(+ (* 70 (expt 2 20)) ;ESP (estimated-partition-size graphs)) @@ -244,12 +249,8 @@ substitutable." #:memory-size #$memory-size #:make-disk-image? #$make-disk-image? #:single-file-output? #$single-file-output? - ;; FIXME: ‘target-arm32?’ and - ;; ‘target-aarch64?’ may not operate on the - ;; right system/target values. Rewrite - ;; using ‘let-system’ when available. - #:target-arm32? #$(target-arm32?) - #:target-aarch64? #$(target-aarch64?) + #:target-arm32? #$(check target-arm32?) + #:target-aarch64? #$(check target-aarch64?) #:disk-image-format #$disk-image-format #:disk-image-size size #:references-graphs graphs)))))) |