services: Add 'file-system-service'.
* gnu/services/base.scm (file-system-service): New procedure. (user-processes-service): Add 'requirements' parameter. * gnu/services/dmd.scm (dmd-configuration-file): Use (guix build linux-initrd). * guix/build/linux-initrd.scm (guix): Export 'check-file-system'. * gnu/system.scm (file-union): New procedure. (essential-services): Use it. Add that to the returned list.
This commit is contained in:
parent
23ed63a12d
commit
023f391c78
|
@ -30,6 +30,7 @@
|
|||
#: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 @@ This service must be the root of the service dependency graph so that its
|
|||
#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
|
||||
|
|
|
@ -34,7 +34,9 @@
|
|||
"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 @@
|
|||
(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)
|
||||
|
|
|
@ -184,15 +184,35 @@ file."
|
|||
|
||||
(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
|
||||
|
|
|
@ -30,6 +30,7 @@
|
|||
linux-command-line
|
||||
make-essential-device-nodes
|
||||
configure-qemu-networking
|
||||
check-file-system
|
||||
mount-file-system
|
||||
bind-mount
|
||||
load-linux-module*
|
||||
|
|
Loading…
Reference in New Issue