[shepherd] 02/02: service: Provide a non-blocking replacement of 'system*'.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository shepherd.

commit 975b0aa0d6f0a184f712c935cd1ad284cd39deaf
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Sun Nov 13 22:34:26 2022 +0100

    service: Provide a non-blocking replacement of 'system*'.
    
    Fixes <https://issues.guix.gnu.org/56674>.
    
    * modules/shepherd/service.scm (process-monitor): Thread 'waiters'
    through 'loop'.  In 'handle-process-termination', notify the relevant
    subset of WAITERS.  Add 'spawn' operation.
    (spawn-command): New procedure.
    * modules/shepherd.scm (main): Set 'system*' to 'spawn-command'.
    * tests/system-star.sh: New file.
    * Makefile.am (TESTS): Add it.
---
 Makefile.am                  |  1 +
 modules/shepherd.scm         |  5 +++
 modules/shepherd/service.scm | 32 +++++++++++++++--
 tests/system-star.sh         | 85 ++++++++++++++++++++++++++++++++++++++++++++
 4 files changed, 121 insertions(+), 2 deletions(-)

diff --git a/Makefile.am b/Makefile.am
index 81fb04d..fe071fb 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -246,6 +246,7 @@ TESTS =                                             \
   tests/inetd.sh                               \
   tests/systemd.sh                             \
   tests/signals.sh                             \
+  tests/system-star.sh                         \
   tests/close-on-exec.sh
 
 TEST_EXTENSIONS = .sh
diff --git a/modules/shepherd.scm b/modules/shepherd.scm
index 2fa7f31..dfa18f6 100644
--- a/modules/shepherd.scm
+++ b/modules/shepherd.scm
@@ -416,6 +416,11 @@ already ~a threads running, disabling 'signalfd' support")
          (catch 'quit
            (lambda ()
              (with-process-monitor
+
+               ;; Replace the default 'system*' binding with one that
+               ;; cooperates instead of blocking on 'waitpid'.
+               (set! system* spawn-command)
+
                (run-daemon #:socket-file socket-file
                            #:config-file config-file
                            #:pid-file pid-file
diff --git a/modules/shepherd/service.scm b/modules/shepherd/service.scm
index 144edef..441966f 100644
--- a/modules/shepherd/service.scm
+++ b/modules/shepherd/service.scm
@@ -38,6 +38,7 @@
   #:use-module ((ice-9 control) #:select (call/ec))
   #:use-module (ice-9 match)
   #:use-module (ice-9 format)
+  #:use-module (ice-9 vlist)
   #:autoload   (ice-9 ports internal) (port-read-wait-fd)
   #:autoload   (ice-9 pretty-print) (truncated-print)
   #:use-module (shepherd support)
@@ -77,6 +78,7 @@
             respawn-service
             handle-SIGCHLD
             with-process-monitor
+            spawn-command
             %precious-signals
             register-services
             provided-by
@@ -1796,7 +1798,7 @@ otherwise by updating its state."
 
 (define (process-monitor channel)
   "Run a process monitor that handles requests received over @var{channel}."
-  (let loop ()
+  (let loop ((waiters vlist-null))
     (match (get-message channel)
       (('handle-process-termination pid status)
        ;; Handle the termination of PID.
@@ -1812,7 +1814,23 @@ otherwise by updating its state."
           #f)
          ((? service? service)
           (handle-service-termination service status)))
-       (loop)))))
+
+       ;; Notify any waiters.
+       (match (vhash-assv pid waiters)
+         (#f #f)
+         ((_ . waiter)
+          (put-message waiter status)))
+
+       ;; XXX: The call below is linear in the size of WAITERS, but WAITERS is
+       ;; usually empty or small.
+       (loop (vhash-delv pid waiters)))
+
+      (('spawn command reply)
+       ;; Spawn COMMAND; send its exit status to REPLY when it terminates.
+       ;; This operation is atomic: the WAITERS table is updated before
+       ;; termination of PID can possibly be handled.
+       (let ((pid (fork+exec-command command)))
+         (loop (vhash-consv pid reply waiters)))))))
 
 (define (spawn-process-monitor)
   "Spawn a process monitoring fiber and return a channel to communicate with
@@ -1840,6 +1858,16 @@ context.  The process monitoring fiber is responsible 
for handling
 @code{SIGCHLD} and generally dealing with process creation and termination."
   (call-with-process-monitor (lambda () exp ...)))
 
+(define (spawn-command program . arguments)
+  "Like 'system*' but do not block while waiting for PROGRAM to terminate."
+  (if (current-process-monitor)
+      (let ((reply (make-channel)))
+        (put-message (current-process-monitor)
+                     `(spawn ,(cons program arguments)
+                             ,reply))
+        (get-message reply))
+      (apply system* program arguments)))
+
 (define (handle-service-termination service status)
   "Handle the termination of the process associated with @var{service}, whose
 PID is in its @code{running} slot; @var{status} is the process's exit status
diff --git a/tests/system-star.sh b/tests/system-star.sh
new file mode 100755
index 0000000..c3bb17a
--- /dev/null
+++ b/tests/system-star.sh
@@ -0,0 +1,85 @@
+# GNU Shepherd --- Test whether 'system*' is blocking.
+# Copyright © 2022 Ludovic Courtès <ludo@gnu.org>
+#
+# This file is part of the GNU Shepherd.
+#
+# The GNU Shepherd is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 3 of the License, or (at
+# your option) any later version.
+#
+# The GNU Shepherd is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with the GNU Shepherd.  If not, see <http://www.gnu.org/licenses/>.
+
+shepherd --version
+herd --version
+
+socket="t-socket-$$"
+conf="t-conf-$$"
+log="t-log-$$"
+stamp="t-stamp-$$"
+pid="t-pid-$$"
+
+herd="herd -s $socket"
+
+trap "cat $log || true; rm -f $socket $conf $stamp $log;
+      test -f $pid && kill \`cat $pid\` || true; rm -f $pid" EXIT
+
+script="while [ ! -f $PWD/$stamp ] ; do sleep 0.1 ; done ; exit \$(cat 
$PWD/$stamp)"
+
+cat > "$conf" <<EOF
+(register-services
+ (make <service>
+   #:provides '(test)
+   #:start (lambda _
+             (list 'exit-code
+                   (status:exit-val
+                    (system* "$SHELL" "-c" "$script"))))
+   #:stop  (lambda _
+             (delete-file "$stamp"))
+   #:respawn? #f))
+EOF
+
+rm -f "$pid"
+shepherd -I -s "$socket" -c "$conf" -l "$log" --pid="$pid" &
+
+# Wait till it's ready.
+while ! test -f "$pid" ; do sleep 0.3 ; done
+
+shepherd_pid="`cat $pid`"
+
+kill -0 $shepherd_pid
+
+# 'herd start' will block until the script exits...
+$herd start test &
+
+# ... so at this point the service is stopped.
+$herd status test | grep "stopped"
+
+# Touch $stamp.  The shell script passed to 'system*' should complete shortly
+# after that.
+echo 123 > "$stamp"
+
+n=0
+while [ $n -lt 20 ]
+do
+    if $herd status test | grep "started"
+    then
+       break
+    else
+       n=$(expr $n + 1)
+       sleep 1
+    fi
+done
+$herd status test | grep "started"
+$herd status test | grep "exit-code 123"
+
+$herd stop test
+! test -f "$stamp"
+
+$herd stop root