M gnu/build/file-systems.scm => gnu/build/file-systems.scm +36 -35
@@ 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
M gnu/build/linux-boot.scm => gnu/build/linux-boot.scm +10 -10
@@ 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"))
M gnu/build/linux-container.scm => gnu/build/linux-container.scm +1 -2
@@ 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.
M gnu/services/base.scm => gnu/services/base.scm +4 -2
@@ 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)
M gnu/system/linux-initrd.scm => gnu/system/linux-initrd.scm +5 -1
@@ 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