Archived
1
0
Fork 0

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

View file

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

View file

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

View file

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