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

155
gnu/services/base.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; 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 Alex Kost <alezost@gmail.com>
;;; Copyright © 2015, 2016 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2015, 2016 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2015 Sou Bunnbu <iyzsong@gmail.com> ;;; Copyright © 2015 Sou Bunnbu <iyzsong@gmail.com>
@ -313,13 +313,26 @@ FILE-SYSTEM."
#:select (mount-file-system)) #:select (mount-file-system))
,@%default-modules))))))) ,@%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 (define file-system-service-type
(service-type (name 'file-systems) (service-type (name 'file-systems)
(extensions (extensions
(list (service-extension shepherd-root-service-type (list (service-extension shepherd-root-service-type
(lambda (file-systems) file-system-shepherd-services)
(filter-map file-system-shepherd-service
file-systems)))
(service-extension fstab-service-type (service-extension fstab-service-type
identity))) identity)))
(compose concatenate) (compose concatenate)
@ -366,93 +379,89 @@ in KNOWN-MOUNT-POINTS when it is stopped."
(define user-processes-service-type (define user-processes-service-type
(shepherd-service-type (shepherd-service-type
'user-processes 'user-processes
(match-lambda (lambda (grace-delay)
((requirements grace-delay) (shepherd-service
(shepherd-service (documentation "When stopped, terminate all user processes.")
(documentation "When stopped, terminate all user processes.") (provision '(user-processes))
(provision '(user-processes)) (requirement '(file-systems))
(requirement (cons* 'root-file-system 'user-file-systems (start #~(const #t))
(map file-system->shepherd-service-name (stop #~(lambda _
requirements))) (define (kill-except omit signal)
(start #~(const #t)) ;; Kill all the processes with SIGNAL except those listed
(stop #~(lambda _ ;; in OMIT and the current process.
(define (kill-except omit signal) (let ((omit (cons (getpid) omit)))
;; Kill all the processes with SIGNAL except those listed (for-each (lambda (pid)
;; in OMIT and the current process. (unless (memv pid omit)
(let ((omit (cons (getpid) omit))) (false-if-exception
(for-each (lambda (pid) (kill pid signal))))
(unless (memv pid omit) (processes))))
(false-if-exception
(kill pid signal))))
(processes))))
(define omitted-pids (define omitted-pids
;; List of PIDs that must not be killed. ;; List of PIDs that must not be killed.
(if (file-exists? #$%do-not-kill-file) (if (file-exists? #$%do-not-kill-file)
(map string->number (map string->number
(call-with-input-file #$%do-not-kill-file (call-with-input-file #$%do-not-kill-file
(compose string-tokenize (compose string-tokenize
(@ (ice-9 rdelim) read-string)))) (@ (ice-9 rdelim) read-string))))
'())) '()))
(define (now) (define (now)
(car (gettimeofday))) (car (gettimeofday)))
(define (sleep* n) (define (sleep* n)
;; Really sleep N seconds. ;; Really sleep N seconds.
;; Work around <http://bugs.gnu.org/19581>. ;; Work around <http://bugs.gnu.org/19581>.
(define start (now)) (define start (now))
(let loop ((elapsed 0)) (let loop ((elapsed 0))
(when (> n elapsed) (when (> n elapsed)
(sleep (- n elapsed)) (sleep (- n elapsed))
(loop (- (now) start))))) (loop (- (now) start)))))
(define lset= (@ (srfi srfi-1) lset=)) (define lset= (@ (srfi srfi-1) lset=))
(display "sending all processes the TERM signal\n") (display "sending all processes the TERM signal\n")
(if (null? omitted-pids) (if (null? omitted-pids)
(begin (begin
;; Easy: terminate all of them. ;; Easy: terminate all of them.
(kill -1 SIGTERM) (kill -1 SIGTERM)
(sleep* #$grace-delay) (sleep* #$grace-delay)
(kill -1 SIGKILL)) (kill -1 SIGKILL))
(begin (begin
;; Kill them all except OMITTED-PIDS. XXX: We would ;; Kill them all except OMITTED-PIDS. XXX: We would
;; like to (kill -1 SIGSTOP) to get a fixed list of ;; like to (kill -1 SIGSTOP) to get a fixed list of
;; processes, like 'killall5' does, but that seems ;; processes, like 'killall5' does, but that seems
;; unreliable. ;; unreliable.
(kill-except omitted-pids SIGTERM) (kill-except omitted-pids SIGTERM)
(sleep* #$grace-delay) (sleep* #$grace-delay)
(kill-except omitted-pids SIGKILL) (kill-except omitted-pids SIGKILL)
(delete-file #$%do-not-kill-file))) (delete-file #$%do-not-kill-file)))
(let wait () (let wait ()
(let ((pids (processes))) (let ((pids (processes)))
(unless (lset= = pids (cons 1 omitted-pids)) (unless (lset= = pids (cons 1 omitted-pids))
(format #t "waiting for process termination\ (format #t "waiting for process termination\
(processes left: ~s)~%" (processes left: ~s)~%"
pids) pids)
(sleep* 2) (sleep* 2)
(wait)))) (wait))))
(display "all processes have been terminated\n") (display "all processes have been terminated\n")
#f)) #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 "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 shepherd The returned service will depend on 'file-systems', meaning that it is
services corresponding to FILE-SYSTEMS. 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 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."
(service user-processes-service-type (service user-processes-service-type grace-delay))
(list (filter file-system-mount? file-systems) grace-delay)))
;;; ;;;

5
gnu/system.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; 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 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com> ;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com>
;;; Copyright © 2016 Chris Marusich <cmmarusich@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)) (other-fs (non-boot-file-system-service os))
(unmount (user-unmount-service known-fs)) (unmount (user-unmount-service known-fs))
(swaps (swap-services os)) (swaps (swap-services os))
(procs (user-processes-service (procs (user-processes-service))
(service-parameters other-fs)))
(host-name (host-name-service (operating-system-host-name os))) (host-name (host-name-service (operating-system-host-name os)))
(entries (operating-system-directory-base-entries (entries (operating-system-directory-base-entries
os #:container? container?))) os #:container? container?)))