02/10: services: 'user-processes-service-type' can now be extended.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 206a28d84ad6d2a5c96bcb23fb7beedc4585b79d
Author: Ludovic Courtès <address@hidden>
Date:   Wed Dec 20 11:05:11 2017 +0100

    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.
---
 gnu/services/base.scm | 236 +++++++++++++++++++++++++++-----------------------
 gnu/system.scm        |   2 +-
 2 files changed, 130 insertions(+), 108 deletions(-)

diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index a3654fd..85c442b 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
address@hidden")))
+
 
 ;;;
 ;;; 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 7466ed7..df89ca0 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?)))