summaryrefslogtreecommitdiff
path: root/gnu
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2017-10-03 23:25:38 +0200
committerLudovic Courtès <ludo@gnu.org>2017-10-11 11:12:33 +0200
commit1c65cca5743e9171bbd94307195f123d26c0535e (patch)
tree7ce49ab08817158f722d0a0129e54efc0ad170cc /gnu
parentf26af33aec586bafcf21838d6ed3b7e00e2b5b03 (diff)
file-systems: 'mount-file-system' now takes a <file-system> object.
* gnu/build/file-systems.scm (mount-file-system): Rename 'spec' to 'fs' and assume it's a <file-system>. * gnu/build/linux-boot.scm (boot-system): Assume MOUNTS is a list of <file-system> and adjust accordingly. * gnu/build/linux-container.scm (mount-file-systems): Remove 'file-system->spec' call. * gnu/services/base.scm (file-system-shepherd-service): Add 'spec->file-system' call. Add (gnu system file-systems) to 'modules'. * gnu/system/linux-initrd.scm (raw-initrd): Use (gnu system file-systems). Add 'spec->file-system' call for #:mounts.
Diffstat (limited to 'gnu')
-rw-r--r--gnu/build/file-systems.scm71
-rw-r--r--gnu/build/linux-boot.scm20
-rw-r--r--gnu/build/linux-container.scm3
-rw-r--r--gnu/services/base.scm6
-rw-r--r--gnu/system/linux-initrd.scm6
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