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:
Ludovic Courtès 2014-05-10 23:33:52 +02:00
parent 23ed63a12d
commit 023f391c78
4 changed files with 60 additions and 9 deletions

View File

@ -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

View File

@ -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)

View File

@ -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

View File

@ -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*