[shepherd] 04/06: service: 'make-kill-destructor' kills the process group.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository shepherd.

commit 1e7a91d21f1cc5d02697680e19e3878ff8565710
Author: Ludovic Courtès <address@hidden>
AuthorDate: Sat Apr 18 16:33:01 2020 +0200

    service: 'make-kill-destructor' kills the process group.
    
    * modules/shepherd/service.scm (make-kill-destructor): Change the
    argument of 'kill' to (getpgid (- pid)).  Use 'define*' instead of
    'lambda*' and add a docstring.
    * doc/shepherd.texi (Service De- and Constructors): Adjust accordingly.
    * tests/pid-file.sh: Change '%command' to a shell script.
    Define '%daemon-command-successful' and use it for 'test-works'.
---
 doc/shepherd.texi            |  6 ++++--
 modules/shepherd/service.scm | 17 ++++++++++-------
 tests/pid-file.sh            | 19 ++++++++++++++-----
 3 files changed, 28 insertions(+), 14 deletions(-)

diff --git a/doc/shepherd.texi b/doc/shepherd.texi
index 3e61f5d..2394f95 100644
--- a/doc/shepherd.texi
+++ b/doc/shepherd.texi
@@ -919,8 +919,10 @@ created if it does not exist, otherwise it is appended to.
 @end deffn
 
 @deffn {procedure} make-kill-destructor [@var{signal}]
-Returns a procedure that sends @var{signal} to the pid which it takes
-as argument.  This @emph{does} work together with respawning services,
+Return a procedure that sends @var{signal} to the process group of the
+PID given as argument, where @var{signal} defaults to @code{SIGTERM}.
+
+This @emph{does} work together with respawning services,
 because in that case the @code{stop} method of the @code{<service>}
 class sets the @code{running} slot to @code{#f} before actually
 calling the destructor; if it would not do that, killing the process
diff --git a/modules/shepherd/service.scm b/modules/shepherd/service.scm
index 9088811..79c4e9f 100644
--- a/modules/shepherd/service.scm
+++ b/modules/shepherd/service.scm
@@ -963,13 +963,16 @@ start."
       (warn-deprecated-form)
       (make-forkexec-constructor (cons program program-args))))))
 
-;; Produce a destructor that sends SIGNAL to the process with the pid
-;; given as argument, where SIGNAL defaults to `SIGTERM'.
-(define make-kill-destructor
-  (lambda* (#:optional (signal SIGTERM))
-    (lambda (pid . args)
-      (kill pid signal)
-      #f)))
+(define* (make-kill-destructor #:optional (signal SIGTERM))
+  "Return a procedure that sends SIGNAL to the process group of the PID given
+as argument, where SIGNAL defaults to `SIGTERM'."
+  (lambda (pid . args)
+    ;; Kill the whole process group PID belongs to.  Don't assume that PID
+    ;; is a process group ID: that's not the case when using #:pid-file,
+    ;; where the process group ID is the PID of the process that
+    ;; "daemonized".
+    (kill (- (getpgid pid)) signal)
+    #f))
 
 ;; Produce a constructor that executes a command.
 (define (make-system-constructor . command)
diff --git a/tests/pid-file.sh b/tests/pid-file.sh
index b4b3129..db11abd 100644
--- a/tests/pid-file.sh
+++ b/tests/pid-file.sh
@@ -34,18 +34,27 @@ cat > "$conf"<<EOF
 (use-modules (ice-9 match))
 
 (define %command
+  '("$SHELL" "-c" "echo \$\$ > $PWD/$service_pid ; exec sleep 600"))
+
+(define %daemon-command
+  ;; Emulate a daemon by forking and exiting right away.
+  (quasiquote ("guile" "-c"
+    ,(object->string '(when (zero? (primitive-fork))
+                        (call-with-output-file "$PWD/$service_pid"
+                          (lambda (port)
+                            (display (getpid) port)))
+                        (sleep 100))))))
+
+(define %daemon-command-successful
   ;; Purposefully introduce a delay between the time the PID file
   ;; is created and the time it actually contains a valid PID.  This
   ;; simulates PID files not created atomically, as is the case with
   ;; wpa_supplicant 2.7 for instance.
-  '("$SHELL" "-c" "echo > $PWD/$service_pid ; sleep 1.5; echo \$\$ > 
$PWD/$service_pid ; exec sleep 600"))
-
-(define %daemon-command
-  ;; Emulate a daemon by forking and exiting right away.
   (quasiquote ("guile" "-c"
     ,(object->string '(when (zero? (primitive-fork))
                         (call-with-output-file "$PWD/$service_pid"
                           (lambda (port)
+                            (usleep 1500000)
                             (display (getpid) port)))
                         (sleep 100))))))
 
@@ -68,7 +77,7 @@ cat > "$conf"<<EOF
  (make <service>
    ;; Same one, but actually produces the PID file.
    #:provides '(test-works)
-   #:start (make-forkexec-constructor %command
+   #:start (make-forkexec-constructor %daemon-command-successful
                                       #:pid-file "$PWD/$service_pid"
                                       #:pid-file-timeout 6)
    #:stop  (make-kill-destructor)