diff --git a/gnu/services/base.scm b/gnu/services/base.scm index e0f2888ee0721798aaa21aacdc9bae35b8f8e45b..6431a3aaba64ac9f2445ae6f8002c9335927ea9c 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -30,6 +30,7 @@ (define-module (gnu services base) #:use-module (srfi srfi-26) #:use-module (ice-9 format) #:export (root-file-system-service + file-system-service user-processes-service host-name-service mingetty-service @@ -87,19 +88,44 @@ (define (root-file-system-service) #f))))) (respawn? #f))))) -(define* (user-processes-service #:key (grace-delay 2)) +(define* (file-system-service device target type + #:key (check? #t) options) + "Return a service that mounts DEVICE on TARGET as a file system TYPE with +OPTIONS. When CHECK? is true, check the file system before mounting it." + (with-monad %store-monad + (return + (service + (provision (list (symbol-append 'file-system- (string->symbol target)))) + (requirement '(root-file-system)) + (documentation "Check, mount, and unmount the given file system.") + (start #~(lambda args + #$(if check? + #~(check-file-system #$device #$type) + #~#t) + (mount #$device #$target #$type 0 #$options) + #t)) + (stop #~(lambda args + ;; Normally there are no processes left at this point, so + ;; TARGET can be safely unmounted. + (umount #$target) + #f)))))) + +(define* (user-processes-service requirements #:key (grace-delay 2)) "Return the service that is responsible for terminating all the processes so that the root file system can be re-mounted read-only, just before rebooting/halting. Processes still running GRACE-DELAY seconds after SIGTERM has been sent are terminated with SIGKILL. +The returned service will depend on 'root-file-system' and on all the services +listed in REQUIREMENTS. + All the services that spawn processes must depend on this one so that they are stopped before 'kill' is called." (with-monad %store-monad (return (service (documentation "When stopped, terminate all user processes.") (provision '(user-processes)) - (requirement '(root-file-system)) + (requirement (cons 'root-file-system requirements)) (start #~(const #t)) (stop #~(lambda _ ;; When this happens, all the processes have been diff --git a/gnu/services/dmd.scm b/gnu/services/dmd.scm index 8d4c483cc4532c337a09512b015a02802bc617b8..0d17285890ad3991155a36c5348aab6463b1f153 100644 --- a/gnu/services/dmd.scm +++ b/gnu/services/dmd.scm @@ -34,7 +34,9 @@ (define (dmd-configuration-file services) "Return the dmd configuration file for SERVICES." (define modules ;; Extra modules visible to dmd.conf. - '((guix build syscalls))) + '((guix build syscalls) + (guix build linux-initrd) + (guix build utils))) (mlet %store-monad ((modules (imported-modules modules)) (compiled (compiled-modules modules))) @@ -46,7 +48,9 @@ (define config (cons #$compiled %load-compiled-path))) (use-modules (ice-9 ftw) - (guix build syscalls)) + (guix build syscalls) + ((guix build linux-initrd) + #:select (check-file-system))) (register-services #$@(map (lambda (service) diff --git a/gnu/system.scm b/gnu/system.scm index 491e0ed7ae98447475f6437aeebff74238b4a816..d76c3670f0645c58e08467a0c2ab599150d48f0b 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -184,15 +184,35 @@ (define builder (gexp->derivation name builder)) +(define (other-file-system-services os) + "Return file system services for the file systems of OS that are not marked +as 'needed-for-boot'." + (define file-systems + (remove (lambda (fs) + (or (file-system-needed-for-boot? fs) + (string=? "/" (file-system-mount-point fs)))) + (operating-system-file-systems os))) + + (sequence %store-monad + (map (match-lambda + (($ <file-system> device target type flags opts #f check?) + (file-system-service device target type + #:check? check? + #:options opts))) + file-systems))) + (define (essential-services os) "Return the list of essential services for OS. These are special services that implement part of what's declared in OS are responsible for low-level bookkeeping." - (mlet %store-monad ((procs (user-processes-service)) - (root-fs (root-file-system-service)) - (host-name (host-name-service - (operating-system-host-name os)))) - (return (list host-name procs root-fs)))) + (mlet* %store-monad ((root-fs (root-file-system-service)) + (other-fs (other-file-system-services os)) + (procs (user-processes-service + (map (compose first service-provision) + other-fs))) + (host-name (host-name-service + (operating-system-host-name os)))) + (return (cons* host-name procs root-fs other-fs)))) (define (operating-system-services os) "Return all the services of OS, including \"internal\" services that do not diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index 83636dfd733e37ea517189829bc64a12ef144939..0c3b2f0d9fb50a43fd74d872032bbf8e49fea1e9 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -30,6 +30,7 @@ (define-module (guix build linux-initrd) linux-command-line make-essential-device-nodes configure-qemu-networking + check-file-system mount-file-system bind-mount load-linux-module*