aboutsummaryrefslogtreecommitdiff
path: root/gnu
diff options
context:
space:
mode:
Diffstat (limited to 'gnu')
-rw-r--r--gnu/services/base.scm236
-rw-r--r--gnu/system.scm2
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?)))
generated by cgit