diff options
Diffstat (limited to 'gnu')
| -rw-r--r-- | gnu/services/base.scm | 107 | ||||
| -rw-r--r-- | gnu/system/file-systems.scm | 5 |
2 files changed, 59 insertions, 53 deletions
diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 67eeecdf17..25143c80a6 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -222,57 +222,60 @@ FILE-SYSTEM." (check? (file-system-check? file-system)) (create? (file-system-create-mount-point? file-system)) (dependencies (file-system-dependencies file-system))) - (list (dmd-service - (provision (list (file-system->dmd-service-name file-system))) - (requirement `(root-file-system - ,@(map dependency->dmd-service-name dependencies))) - (documentation "Check, mount, and unmount the given file system.") - (start #~(lambda args - ;; FIXME: Use or factorize with 'mount-file-system'. - (let ((device (canonicalize-device-spec #$device '#$title)) - (flags #$(mount-flags->bit-mask - (file-system-flags file-system)))) - #$(if create? - #~(mkdir-p #$target) - #~#t) - #$(if check? - #~(begin - ;; Make sure fsck.ext2 & co. can be found. - (setenv "PATH" - (string-append - #$e2fsprogs "/sbin:" - "/run/current-system/profile/sbin:" - (getenv "PATH"))) - (check-file-system device #$type)) - #~#t) - - (mount device #$target #$type flags - #$(file-system-options file-system)) - - ;; 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))) - (mount device #$target #$type - (logior MS_BIND MS_REMOUNT MS_RDONLY)))) - #t)) - (stop #~(lambda args - ;; Normally there are no processes left at this point, so - ;; TARGET can be safely unmounted. - - ;; Make sure PID 1 doesn't keep TARGET busy. - (chdir "/") - - (umount #$target) - #f)) - - ;; We need an additional module. - (modules `(((gnu build file-systems) - #:select (check-file-system canonicalize-device-spec)) - ,@%default-modules)) - (imported-modules `((gnu build file-systems) - ,@%default-imported-modules)))))) + (if (file-system-mount? file-system) + (list + (dmd-service + (provision (list (file-system->dmd-service-name file-system))) + (requirement `(root-file-system + ,@(map dependency->dmd-service-name dependencies))) + (documentation "Check, mount, and unmount the given file system.") + (start #~(lambda args + ;; FIXME: Use or factorize with 'mount-file-system'. + (let ((device (canonicalize-device-spec #$device '#$title)) + (flags #$(mount-flags->bit-mask + (file-system-flags file-system)))) + #$(if create? + #~(mkdir-p #$target) + #~#t) + #$(if check? + #~(begin + ;; Make sure fsck.ext2 & co. can be found. + (setenv "PATH" + (string-append + #$e2fsprogs "/sbin:" + "/run/current-system/profile/sbin:" + (getenv "PATH"))) + (check-file-system device #$type)) + #~#t) + + (mount device #$target #$type flags + #$(file-system-options file-system)) + + ;; 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))) + (mount device #$target #$type + (logior MS_BIND MS_REMOUNT MS_RDONLY)))) + #t)) + (stop #~(lambda args + ;; Normally there are no processes left at this point, so + ;; TARGET can be safely unmounted. + + ;; Make sure PID 1 doesn't keep TARGET busy. + (chdir "/") + + (umount #$target) + #f)) + + ;; We need an additional module. + (modules `(((gnu build file-systems) + #:select (check-file-system canonicalize-device-spec)) + ,@%default-modules)) + (imported-modules `((gnu build file-systems) + ,@%default-imported-modules)))) + '()))) (define file-system-service-type ;; TODO(?): Make this an extensible service that takes <file-system> objects @@ -416,7 +419,7 @@ services corresponding to FILE-SYSTEMS. All the services that spawn processes must depend on this one so that they are stopped before 'kill' is called." (service user-processes-service-type - (list file-systems grace-delay))) + (list (filter file-system-mount? file-systems) grace-delay))) ;;; diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm index 0a4b385fe3..47a3dbc1e8 100644 --- a/gnu/system/file-systems.scm +++ b/gnu/system/file-systems.scm @@ -35,6 +35,7 @@ file-system-needed-for-boot? file-system-flags file-system-options + file-system-mount? file-system-check? file-system-create-mount-point? file-system-dependencies @@ -93,6 +94,8 @@ (default '())) (options file-system-options ; string or #f (default #f)) + (mount? file-system-mount? ; Boolean + (default #t)) (needed-for-boot? %file-system-needed-for-boot? ; Boolean (default #f)) (check? file-system-check? ; Boolean @@ -112,7 +115,7 @@ file system." "Return a list corresponding to file-system FS that can be passed to the initrd code." (match fs - (($ <file-system> device title mount-point type flags options _ check?) + (($ <file-system> device title mount-point type flags options _ _ check?) (list device title mount-point type flags options check?)))) (define %uuid-rx |