diff options
| -rw-r--r-- | gnu/services/base.scm | 236 | ||||
| -rw-r--r-- | gnu/system.scm | 2 |
2 files changed, 130 insertions, 108 deletions
diff --git a/gnu/services/base.scm b/gnu/services/base.scm index a3654fd4d3..85c442b385 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -57,7 +57,7 @@ file-system-service-type user-unmount-service swap-service - user-processes-service + user-processes-service-type host-name-service console-keymap-service %default-console-font @@ -162,6 +162,129 @@ ;;; ;;; Code: + + +;;; +;;; User processes. +;;; + +(define %do-not-kill-file + ;; Name of the file listing PIDs of processes that must survive when halting + ;; the system. Typical example is user-space file systems. + "/etc/shepherd/do-not-kill") + +(define (user-processes-shepherd-service requirements) + "Return the 'user-processes' Shepherd service with dependencies on +REQUIREMENTS (a list of service names). + +This is a synchronization point used to make sure user processes and daemons +get started only after crucial initial services have been started---file +system mounts, etc. This is similar to the 'sysvinit' target in systemd." + (define grace-delay + ;; Delay after sending SIGTERM and before sending SIGKILL. + 4) + + (list (shepherd-service + (documentation "When stopped, terminate all user processes.") + (provision '(user-processes)) + (requirement requirements) + (start #~(const #t)) + (stop #~(lambda _ + (define (kill-except omit signal) + ;; Kill all the processes with SIGNAL except those listed + ;; in OMIT and the current process. + (let ((omit (cons (getpid) omit))) + (for-each (lambda (pid) + (unless (memv pid omit) + (false-if-exception + (kill pid signal)))) + (processes)))) + + (define omitted-pids + ;; List of PIDs that must not be killed. + (if (file-exists? #$%do-not-kill-file) + (map string->number + (call-with-input-file #$%do-not-kill-file + (compose string-tokenize + (@ (ice-9 rdelim) read-string)))) + '())) + + (define (now) + (car (gettimeofday))) + + (define (sleep* n) + ;; Really sleep N seconds. + ;; Work around <http://bugs.gnu.org/19581>. + (define start (now)) + (let loop ((elapsed 0)) + (when (> n elapsed) + (sleep (- n elapsed)) + (loop (- (now) start))))) + + (define lset= (@ (srfi srfi-1) lset=)) + + (display "sending all processes the TERM signal\n") + + (if (null? omitted-pids) + (begin + ;; Easy: terminate all of them. + (kill -1 SIGTERM) + (sleep* #$grace-delay) + (kill -1 SIGKILL)) + (begin + ;; Kill them all except OMITTED-PIDS. XXX: We would + ;; like to (kill -1 SIGSTOP) to get a fixed list of + ;; processes, like 'killall5' does, but that seems + ;; unreliable. + (kill-except omitted-pids SIGTERM) + (sleep* #$grace-delay) + (kill-except omitted-pids SIGKILL) + (delete-file #$%do-not-kill-file))) + + (let wait () + ;; Reap children, if any, so that we don't end up with + ;; zombies and enter an infinite loop. + (let reap-children () + (define result + (false-if-exception + (waitpid WAIT_ANY (if (null? omitted-pids) + 0 + WNOHANG)))) + + (when (and (pair? result) + (not (zero? (car result)))) + (reap-children))) + + (let ((pids (processes))) + (unless (lset= = pids (cons 1 omitted-pids)) + (format #t "waiting for process termination\ + (processes left: ~s)~%" + pids) + (sleep* 2) + (wait)))) + + (display "all processes have been terminated\n") + #f)) + (respawn? #f)))) + +(define user-processes-service-type + (service-type + (name 'user-processes) + (extensions (list (service-extension shepherd-root-service-type + user-processes-shepherd-service))) + (compose concatenate) + (extend append) + + ;; The value is the list of Shepherd services 'user-processes' depends on. + ;; Extensions can add new services to this list. + (default-value '()) + + (description "The @code{user-processes} service 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 after a few +seconds after @code{SIGTERM} has been sent are terminated with +@code{SIGKILL}."))) + ;;; ;;; File systems. @@ -349,7 +472,11 @@ FILE-SYSTEM." (list (service-extension shepherd-root-service-type file-system-shepherd-services) (service-extension fstab-service-type - identity))) + identity) + + ;; Have 'user-processes' depend on 'file-systems'. + (service-extension user-processes-service-type + (const '(file-systems))))) (compose concatenate) (extend append) (description @@ -389,111 +516,6 @@ file systems, as well as corresponding @file{/etc/fstab} entries."))) in KNOWN-MOUNT-POINTS when it is stopped." (service user-unmount-service-type known-mount-points)) -(define %do-not-kill-file - ;; Name of the file listing PIDs of processes that must survive when halting - ;; the system. Typical example is user-space file systems. - "/etc/shepherd/do-not-kill") - -(define user-processes-service-type - (shepherd-service-type - 'user-processes - (lambda (grace-delay) - (shepherd-service - (documentation "When stopped, terminate all user processes.") - (provision '(user-processes)) - (requirement '(file-systems)) - (start #~(const #t)) - (stop #~(lambda _ - (define (kill-except omit signal) - ;; Kill all the processes with SIGNAL except those listed - ;; in OMIT and the current process. - (let ((omit (cons (getpid) omit))) - (for-each (lambda (pid) - (unless (memv pid omit) - (false-if-exception - (kill pid signal)))) - (processes)))) - - (define omitted-pids - ;; List of PIDs that must not be killed. - (if (file-exists? #$%do-not-kill-file) - (map string->number - (call-with-input-file #$%do-not-kill-file - (compose string-tokenize - (@ (ice-9 rdelim) read-string)))) - '())) - - (define (now) - (car (gettimeofday))) - - (define (sleep* n) - ;; Really sleep N seconds. - ;; Work around <http://bugs.gnu.org/19581>. - (define start (now)) - (let loop ((elapsed 0)) - (when (> n elapsed) - (sleep (- n elapsed)) - (loop (- (now) start))))) - - (define lset= (@ (srfi srfi-1) lset=)) - - (display "sending all processes the TERM signal\n") - - (if (null? omitted-pids) - (begin - ;; Easy: terminate all of them. - (kill -1 SIGTERM) - (sleep* #$grace-delay) - (kill -1 SIGKILL)) - (begin - ;; Kill them all except OMITTED-PIDS. XXX: We would - ;; like to (kill -1 SIGSTOP) to get a fixed list of - ;; processes, like 'killall5' does, but that seems - ;; unreliable. - (kill-except omitted-pids SIGTERM) - (sleep* #$grace-delay) - (kill-except omitted-pids SIGKILL) - (delete-file #$%do-not-kill-file))) - - (let wait () - ;; Reap children, if any, so that we don't end up with - ;; zombies and enter an infinite loop. - (let reap-children () - (define result - (false-if-exception - (waitpid WAIT_ANY (if (null? omitted-pids) - 0 - WNOHANG)))) - - (when (and (pair? result) - (not (zero? (car result)))) - (reap-children))) - - (let ((pids (processes))) - (unless (lset= = pids (cons 1 omitted-pids)) - (format #t "waiting for process termination\ - (processes left: ~s)~%" - pids) - (sleep* 2) - (wait)))) - - (display "all processes have been terminated\n") - #f)) - (respawn? #f))))) - -(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 '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 grace-delay)) - ;;; ;;; Preserve entropy to seed /dev/urandom on boot. diff --git a/gnu/system.scm b/gnu/system.scm index 7466ed780d..df89ca06da 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -449,7 +449,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)) + (procs (service user-processes-service-type)) (host-name (host-name-service (operating-system-host-name os))) (entries (operating-system-directory-base-entries os #:container? container?))) |