diff options
Diffstat (limited to 'gnu/services')
| -rw-r--r-- | gnu/services/base.scm | 105 | ||||
| -rw-r--r-- | gnu/services/shepherd.scm | 43 |
2 files changed, 66 insertions, 82 deletions
diff --git a/gnu/services/base.scm b/gnu/services/base.scm index d9c60778a1..02e3b41904 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -229,59 +229,58 @@ FILE-SYSTEM." (create? (file-system-create-mount-point? file-system)) (dependencies (file-system-dependencies file-system))) (if (file-system-mount? file-system) - (list - (shepherd-service - (provision (list (file-system->shepherd-service-name file-system))) - (requirement `(root-file-system - ,@(map dependency->shepherd-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) - (guix build bournish) - ,@%default-imported-modules)))) + (with-imported-modules '((gnu build file-systems) + (guix build bournish)) + (list + (shepherd-service + (provision (list (file-system->shepherd-service-name file-system))) + (requirement `(root-file-system + ,@(map dependency->shepherd-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))))) '()))) (define file-system-service-type diff --git a/gnu/services/shepherd.scm b/gnu/services/shepherd.scm index 5d829e4c38..f35a6bf10a 100644 --- a/gnu/services/shepherd.scm +++ b/gnu/services/shepherd.scm @@ -47,9 +47,7 @@ shepherd-service-stop shepherd-service-auto-start? shepherd-service-modules - shepherd-service-imported-modules - %default-imported-modules %default-modules shepherd-service-file @@ -138,9 +136,7 @@ for a service that extends SHEPHERD-ROOT-SERVICE-TYPE and nothing else." (auto-start? shepherd-service-auto-start? ;Boolean (default #t)) (modules shepherd-service-modules ;list of module names - (default %default-modules)) - (imported-modules shepherd-service-imported-modules ;list of module names - (default %default-imported-modules))) + (default %default-modules))) (define (shepherd-service-canonical-name service) "Return the 'canonical name' of SERVICE." @@ -203,37 +199,26 @@ stored." (define (shepherd-service-file service) "Return a file defining SERVICE." (gexp->file (shepherd-service-file-name service) - #~(begin - (use-modules #$@(shepherd-service-modules service)) - - (make <service> - #:docstring '#$(shepherd-service-documentation service) - #:provides '#$(shepherd-service-provision service) - #:requires '#$(shepherd-service-requirement service) - #:respawn? '#$(shepherd-service-respawn? service) - #:start #$(shepherd-service-start service) - #:stop #$(shepherd-service-stop service))))) + (with-imported-modules %default-imported-modules + #~(begin + (use-modules #$@(shepherd-service-modules service)) + + (make <service> + #:docstring '#$(shepherd-service-documentation service) + #:provides '#$(shepherd-service-provision service) + #:requires '#$(shepherd-service-requirement service) + #:respawn? '#$(shepherd-service-respawn? service) + #:start #$(shepherd-service-start service) + #:stop #$(shepherd-service-stop service)))))) (define (shepherd-configuration-file services) "Return the shepherd configuration file for SERVICES." - (define modules - (delete-duplicates - (append-map shepherd-service-imported-modules services))) - (assert-valid-graph services) - (mlet %store-monad ((modules (imported-modules modules)) - (compiled (compiled-modules modules)) - (files (mapm %store-monad - shepherd-service-file - services))) + (mlet %store-monad ((files (mapm %store-monad + shepherd-service-file services))) (define config #~(begin - (eval-when (expand load eval) - (set! %load-path (cons #$modules %load-path)) - (set! %load-compiled-path - (cons #$compiled %load-compiled-path))) - (use-modules (srfi srfi-34) (system repl error-handling)) |