diff options
| -rw-r--r-- | gnu/build/file-systems.scm | 71 | ||||
| -rw-r--r-- | gnu/build/linux-boot.scm | 20 | ||||
| -rw-r--r-- | gnu/build/linux-container.scm | 3 | ||||
| -rw-r--r-- | gnu/services/base.scm | 6 | ||||
| -rw-r--r-- | gnu/system/linux-initrd.scm | 6 |
5 files changed, 56 insertions, 50 deletions
diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm index 140bcb414b..bcb0c53628 100644 --- a/gnu/build/file-systems.scm +++ b/gnu/build/file-systems.scm @@ -20,9 +20,11 @@ (define-module (gnu build file-systems) #:use-module (gnu system uuid) + #:use-module (gnu system file-systems) #:use-module (guix build utils) #:use-module (guix build bournish) - #:use-module (guix build syscalls) + #:use-module ((guix build syscalls) + #:hide (file-system-type)) #:use-module (rnrs io ports) #:use-module (rnrs bytevectors) #:use-module (ice-9 match) @@ -552,11 +554,8 @@ corresponds to the symbols listed in FLAGS." (() 0)))) -(define* (mount-file-system spec #:key (root "/root")) - "Mount the file system described by SPEC under ROOT. SPEC must have the -form: - - (DEVICE TITLE MOUNT-POINT TYPE (FLAGS ...) OPTIONS CHECK?) +(define* (mount-file-system fs #:key (root "/root")) + "Mount the file system described by FS, a <file-system> object, under ROOT. DEVICE, MOUNT-POINT, and TYPE must be strings; OPTIONS can be a string or #f; FLAGS must be a list of symbols. CHECK? is a Boolean indicating whether to @@ -582,34 +581,36 @@ run a file system check." (if options (string-append "," options) ""))))) - (match spec - ((source title mount-point type (flags ...) options check?) - (let ((source (canonicalize-device-spec source title)) - (mount-point (string-append root "/" mount-point)) - (flags (mount-flags->bit-mask flags))) - (when check? - (check-file-system source type)) - - ;; Create the mount point. Most of the time this is a directory, but - ;; in the case of a bind mount, a regular file or socket may be needed. - (if (and (= MS_BIND (logand flags MS_BIND)) - (not (file-is-directory? source))) - (unless (file-exists? mount-point) - (mkdir-p (dirname mount-point)) - (call-with-output-file mount-point (const #t))) - (mkdir-p mount-point)) - - (cond - ((string-prefix? "nfs" type) - (mount-nfs source mount-point type flags options)) - (else - (mount source mount-point type flags options))) - - ;; For read-only bind mounts, an extra remount is needed, as per - ;; <http://lwn.net/Articles/281157/>, which still applies to Linux 4.0. - (when (and (= MS_BIND (logand flags MS_BIND)) - (= MS_RDONLY (logand flags MS_RDONLY))) - (let ((flags (logior MS_BIND MS_REMOUNT MS_RDONLY))) - (mount source mount-point type flags #f))))))) + (let ((type (file-system-type fs)) + (options (file-system-options fs)) + (source (canonicalize-device-spec (file-system-device fs) + (file-system-title fs))) + (mount-point (string-append root "/" + (file-system-mount-point fs))) + (flags (mount-flags->bit-mask (file-system-flags fs)))) + (when (file-system-check? fs) + (check-file-system source type)) + + ;; Create the mount point. Most of the time this is a directory, but + ;; in the case of a bind mount, a regular file or socket may be needed. + (if (and (= MS_BIND (logand flags MS_BIND)) + (not (file-is-directory? source))) + (unless (file-exists? mount-point) + (mkdir-p (dirname mount-point)) + (call-with-output-file mount-point (const #t))) + (mkdir-p mount-point)) + + (cond + ((string-prefix? "nfs" type) + (mount-nfs source mount-point type flags options)) + (else + (mount source mount-point type flags options))) + + ;; For read-only bind mounts, an extra remount is needed, as per + ;; <http://lwn.net/Articles/281157/>, which still applies to Linux 4.0. + (when (and (= MS_BIND (logand flags MS_BIND)) + (= MS_RDONLY (logand flags MS_RDONLY))) + (let ((flags (logior MS_BIND MS_REMOUNT MS_RDONLY))) + (mount source mount-point type flags #f))))) ;;; file-systems.scm ends here diff --git a/gnu/build/linux-boot.scm b/gnu/build/linux-boot.scm index 360ef3faed..3712abe910 100644 --- a/gnu/build/linux-boot.scm +++ b/gnu/build/linux-boot.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; ;;; This file is part of GNU Guix. @@ -27,9 +27,11 @@ #:use-module (ice-9 match) #:use-module (ice-9 ftw) #:use-module (guix build utils) - #:use-module (guix build syscalls) + #:use-module ((guix build syscalls) + #:hide (file-system-type)) #:use-module (gnu build linux-modules) #:use-module (gnu build file-systems) + #:use-module (gnu system file-systems) #:export (mount-essential-file-systems linux-command-line find-long-option @@ -349,19 +351,17 @@ supports kernel command-line options '--load', '--root', and '--repl'. Mount the root file system, specified by the '--root' command-line argument, if any. -MOUNTS must be a list suitable for 'mount-file-system'. +MOUNTS must be a list of <file-system> objects. When VOLATILE-ROOT? is true, the root file system is writable but any changes to it are lost." - (define root-mount-point? - (match-lambda - ((device _ "/" _ ...) #t) - (_ #f))) + (define (root-mount-point? fs) + (string=? (file-system-mount-point fs) "/")) (define root-fs-type - (or (any (match-lambda - ((device _ "/" type _ ...) type) - (_ #f)) + (or (any (lambda (fs) + (and (root-mount-point? fs) + (file-system-type fs))) mounts) "ext4")) diff --git a/gnu/build/linux-container.scm b/gnu/build/linux-container.scm index 95bfd92dde..70e789403f 100644 --- a/gnu/build/linux-container.scm +++ b/gnu/build/linux-container.scm @@ -152,8 +152,7 @@ for the process." ;; Mount user-specified file systems. (for-each (lambda (file-system) - (mount-file-system (file-system->spec file-system) - #:root root)) + (mount-file-system file-system #:root root)) mounts) ;; Jail the process inside the container's root file system. diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 64620a9b0a..541ca76f14 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -307,7 +307,8 @@ FILE-SYSTEM." '#$packages)))) (lambda () (mount-file-system - '#$(file-system->spec file-system) + (spec->file-system + '#$(file-system->spec file-system)) #:root "/")) (lambda () (setenv "PATH" $PATH))) @@ -322,9 +323,10 @@ FILE-SYSTEM." (umount #$target) #f)) - ;; We need an additional module. + ;; We need additional modules. (modules `(((gnu build file-systems) #:select (mount-file-system)) + (gnu system file-systems) ,@%default-modules))))))) (define (file-system-shepherd-services file-systems) diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm index 969a89266c..948c543a15 100644 --- a/gnu/system/linux-initrd.scm +++ b/gnu/system/linux-initrd.scm @@ -187,9 +187,11 @@ to it are lost." '((gnu build linux-boot) (guix build utils) (guix build bournish) + (gnu system file-systems) (gnu build file-systems))) #~(begin (use-modules (gnu build linux-boot) + (gnu system file-systems) (guix build utils) (guix build bournish) ;add the 'bournish' meta-command (srfi srfi-26) @@ -206,7 +208,9 @@ to it are lost." (set-path-environment-variable "PATH" '("bin" "sbin") '#$helper-packages))) - (boot-system #:mounts '#$(map file-system->spec file-systems) + (boot-system #:mounts + (map spec->file-system + '#$(map file-system->spec file-systems)) #:pre-mount (lambda () (and #$@device-mapping-commands)) #:linux-modules '#$linux-modules |