services: 'user-processes-service-type' can now be extended.
* gnu/services/base.scm (user-processes-shepherd-service): New procedure, taken from former 'user-processes-service-type'. Add REQUIREMENTS argument; remove GRACE-DELAY argument. (user-processes-service-type): Redefine in terms of 'service-type'. (user-processes-service): Remove. (file-system-service-type): Extend USER-PROCESSES-SERVICE-TYPE. * gnu/system.scm (essential-services): Use USER-PROCESSES-SERVICE-TYPE directly.
This commit is contained in:
Ludovic Courtès
parent
8785bd7759
commit
206a28d84a
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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?)))
|
||||
|
|
|
|||
Loading…
Reference in New Issue