nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

system: Introduce 'file-systems' Shepherd service. 

* gnu/services/base.scm (file-system-shepherd-services): New procedure.
(file-system-service-type): Use it as the SHEPHERD-ROOT-SERVICE-TYPE
extension.
(user-processes-service-type): Change to take a single 'grace-delay'
parameter.
(user-processes-service): Remove 'file-systems' parameter.  Pass
GRACE-DELAY as the only value for the service.
* gnu/system.scm (essential-services): Adjust accordingly.
This commit is contained in:
Ludovic Courtès 2017-01-31 22:53:29 +01:00
parent 2fe4ceee18
commit a43aca973e
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
2 changed files with 84 additions and 76 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
gnu/services/base.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com>
;;; Copyright © 2015, 2016 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2015 Sou Bunnbu <iyzsong@gmail.com>
@ -313,13 +313,26 @@ FILE-SYSTEM."
#:select (mount-file-system))
,@%default-modules)))))))
(define (file-system-shepherd-services file-systems)
"Return the list of Shepherd services for FILE-SYSTEMS."
(let* ((file-systems (filter file-system-mount? file-systems)))
(define sink
(shepherd-service
(provision '(file-systems))
(requirement (cons* 'root-file-system 'user-file-systems
(map file-system->shepherd-service-name
file-systems)))
(documentation "Target for all the initially-mounted file systems")
(start #~(const #t))
(stop #~(const #f))))
(cons sink (map file-system-shepherd-service file-systems))))
(define file-system-service-type
(service-type (name 'file-systems)
(extensions
(list (service-extension shepherd-root-service-type
(lambda (file-systems)
(filter-map file-system-shepherd-service
file-systems)))
file-system-shepherd-services)
(service-extension fstab-service-type
identity)))
(compose concatenate)
@ -366,14 +379,11 @@ in KNOWN-MOUNT-POINTS when it is stopped."
(define user-processes-service-type
(shepherd-service-type
'user-processes
(match-lambda
((requirements grace-delay)
(lambda (grace-delay)
(shepherd-service
(documentation "When stopped, terminate all user processes.")
(provision '(user-processes))
(requirement (cons* 'root-file-system 'user-file-systems
(map file-system->shepherd-service-name
requirements)))
(requirement '(file-systems))
(start #~(const #t))
(stop #~(lambda _
(define (kill-except omit signal)
@ -438,21 +448,20 @@ in KNOWN-MOUNT-POINTS when it is stopped."
(display "all processes have been terminated\n")
#f))
(respawn? #f))))))
(respawn? #f)))))
(define* (user-processes-service file-systems #:key (grace-delay 4))
(define* (user-processes-service #:key (grace-delay 4))
"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 shepherd
services corresponding to FILE-SYSTEMS.
The returned service will depend on 'file-systems', meaning that it is
considered started after all the auto-mount file systems have been mounted.
All the services that spawn processes must depend on this one so that they are
stopped before 'kill' is called."
(service user-processes-service-type
(list (filter file-system-mount? file-systems) grace-delay)))
(service user-processes-service-type grace-delay))
;;;

5
gnu/system.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com>
;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
@ -293,8 +293,7 @@ a container or that of a \"bare metal\" system."
(other-fs (non-boot-file-system-service os))
(unmount (user-unmount-service known-fs))
(swaps (swap-services os))
(procs (user-processes-service
(service-parameters other-fs)))
(procs (user-processes-service))
(host-name (host-name-service (operating-system-host-name os)))
(entries (operating-system-directory-base-entries
os #:container? container?)))