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
4 changed files with 60 additions and 9 deletions
|
@ -30,6 +30,7 @@
|
||||||
#:use-module (srfi srfi-26)
|
#:use-module (srfi srfi-26)
|
||||||
#:use-module (ice-9 format)
|
#:use-module (ice-9 format)
|
||||||
#:export (root-file-system-service
|
#:export (root-file-system-service
|
||||||
|
file-system-service
|
||||||
user-processes-service
|
user-processes-service
|
||||||
host-name-service
|
host-name-service
|
||||||
mingetty-service
|
mingetty-service
|
||||||
|
@ -87,19 +88,44 @@ This service must be the root of the service dependency graph so that its
|
||||||
#f)))))
|
#f)))))
|
||||||
(respawn? #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
|
"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
|
that the root file system can be re-mounted read-only, just before
|
||||||
rebooting/halting. Processes still running GRACE-DELAY seconds after SIGTERM
|
rebooting/halting. Processes still running GRACE-DELAY seconds after SIGTERM
|
||||||
has been sent are terminated with SIGKILL.
|
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
|
All the services that spawn processes must depend on this one so that they are
|
||||||
stopped before 'kill' is called."
|
stopped before 'kill' is called."
|
||||||
(with-monad %store-monad
|
(with-monad %store-monad
|
||||||
(return (service
|
(return (service
|
||||||
(documentation "When stopped, terminate all user processes.")
|
(documentation "When stopped, terminate all user processes.")
|
||||||
(provision '(user-processes))
|
(provision '(user-processes))
|
||||||
(requirement '(root-file-system))
|
(requirement (cons 'root-file-system requirements))
|
||||||
(start #~(const #t))
|
(start #~(const #t))
|
||||||
(stop #~(lambda _
|
(stop #~(lambda _
|
||||||
;; When this happens, all the processes have been
|
;; When this happens, all the processes have been
|
||||||
|
|
|
@ -34,7 +34,9 @@
|
||||||
"Return the dmd configuration file for SERVICES."
|
"Return the dmd configuration file for SERVICES."
|
||||||
(define modules
|
(define modules
|
||||||
;; Extra modules visible to dmd.conf.
|
;; 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))
|
(mlet %store-monad ((modules (imported-modules modules))
|
||||||
(compiled (compiled-modules modules)))
|
(compiled (compiled-modules modules)))
|
||||||
|
@ -46,7 +48,9 @@
|
||||||
(cons #$compiled %load-compiled-path)))
|
(cons #$compiled %load-compiled-path)))
|
||||||
|
|
||||||
(use-modules (ice-9 ftw)
|
(use-modules (ice-9 ftw)
|
||||||
(guix build syscalls))
|
(guix build syscalls)
|
||||||
|
((guix build linux-initrd)
|
||||||
|
#:select (check-file-system)))
|
||||||
|
|
||||||
(register-services
|
(register-services
|
||||||
#$@(map (lambda (service)
|
#$@(map (lambda (service)
|
||||||
|
|
|
@ -184,15 +184,35 @@ file."
|
||||||
|
|
||||||
(gexp->derivation name 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)
|
(define (essential-services os)
|
||||||
"Return the list of essential services for OS. These are special services
|
"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
|
that implement part of what's declared in OS are responsible for low-level
|
||||||
bookkeeping."
|
bookkeeping."
|
||||||
(mlet %store-monad ((procs (user-processes-service))
|
(mlet* %store-monad ((root-fs (root-file-system-service))
|
||||||
(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
|
(host-name (host-name-service
|
||||||
(operating-system-host-name os))))
|
(operating-system-host-name os))))
|
||||||
(return (list host-name procs root-fs))))
|
(return (cons* host-name procs root-fs other-fs))))
|
||||||
|
|
||||||
(define (operating-system-services os)
|
(define (operating-system-services os)
|
||||||
"Return all the services of OS, including \"internal\" services that do not
|
"Return all the services of OS, including \"internal\" services that do not
|
||||||
|
|
|
@ -30,6 +30,7 @@
|
||||||
linux-command-line
|
linux-command-line
|
||||||
make-essential-device-nodes
|
make-essential-device-nodes
|
||||||
configure-qemu-networking
|
configure-qemu-networking
|
||||||
|
check-file-system
|
||||||
mount-file-system
|
mount-file-system
|
||||||
bind-mount
|
bind-mount
|
||||||
load-linux-module*
|
load-linux-module*
|
||||||
|
|
Reference in a new issue