From 177592ee9d4b7fc6dcc80e545e8ad615a1d6786c Mon Sep 17 00:00:00 2001
From: ulfvonbelow <striness@tilde.club>
Date: Sat, 25 Feb 2023 00:56:57 -0600
Subject: [PATCH 3/3] service: add spawn-shell-command replacement for
 `system'.

We already have a replacement for `system*' that avoids racing, but not for
`system'.

* configure.ac (SHELL): new substitution variable.
* modules/shepherd/system.scm.in (%shell-filename): new variable.
* modules/shepherd/service.scm
  (spawn-shell-command, real-system): new procedures.
* modules/shepherd.scm (main): replace `system' with `spawn-shell-command'.
---
 configure.ac                   |  1 +
 modules/shepherd.scm           |  7 +++++--
 modules/shepherd/service.scm   | 13 +++++++++++++
 modules/shepherd/system.scm.in |  5 ++++-
 4 files changed, 23 insertions(+), 3 deletions(-)

diff --git a/configure.ac b/configure.ac
index 6f681dc..19c177a 100644
--- a/configure.ac
+++ b/configure.ac
@@ -32,6 +32,7 @@ guilemoduledir="${datarootdir}/guile/site/$GUILE_EFFECTIVE_VERSION"
 guileobjectdir="${libdir}/guile/$GUILE_EFFECTIVE_VERSION/site-ccache"
 AC_SUBST([guilemoduledir])
 AC_SUBST([guileobjectdir])
+AC_SUBST([SHELL])
 
 dnl Check for extra dependencies.
 GUILE_MODULE_AVAILABLE([have_fibers], [(fibers)])
diff --git a/modules/shepherd.scm b/modules/shepherd.scm
index cce0507..1f6342e 100644
--- a/modules/shepherd.scm
+++ b/modules/shepherd.scm
@@ -420,8 +420,10 @@ already ~a threads running, disabling 'signalfd' support")
 
                ;; Replace the default 'system*' binding with one that
                ;; cooperates instead of blocking on 'waitpid'.
-               (let ((real-system* system*))
+               (let ((real-system* system*)
+                     (real-system system))
                  (set! system* spawn-command)
+                 (set! system spawn-shell-command)
 
                  ;; Restore 'system*' after fork.
                  (set! primitive-fork
@@ -430,7 +432,8 @@ already ~a threads running, disabling 'signalfd' support")
                            (let ((result (real-fork)))
                              (when (zero? result)
                                (set! primitive-fork real-fork)
-                               (set! system* real-system*))
+                               (set! system* real-system*)
+                               (set! system real-system))
                              result)))))
 
                (run-daemon #:socket-file socket-file
diff --git a/modules/shepherd/service.scm b/modules/shepherd/service.scm
index a36e486..f8df3a9 100644
--- a/modules/shepherd/service.scm
+++ b/modules/shepherd/service.scm
@@ -81,6 +81,7 @@
             handle-SIGCHLD
             with-process-monitor
             spawn-command
+            spawn-shell-command
             %precious-signals
             register-services
             provided-by
@@ -1938,6 +1939,18 @@ context.  The process monitoring fiber is responsible for handling
       (spawn-via-monitor (list (cons program arguments)))
       (apply system* program arguments)))
 
+(define real-system system)
+
+(define* (spawn-shell-command #:optional command)
+  "Like 'system' but do not block while waiting for COMMAND to terminate."
+  (if (current-process-monitor)
+      (if command
+          (spawn-command %shell-filename "-c" command)
+          #t)
+      (if command
+          (real-system command)
+          (real-system))))
+
 (define (fork+exec+wait-command command . arguments)
   "Like 'fork+exec' but also wait for PROGRAM to terminate, giving its exit
 status."
diff --git a/modules/shepherd/system.scm.in b/modules/shepherd/system.scm.in
index 29357aa..4646e81 100644
--- a/modules/shepherd/system.scm.in
+++ b/modules/shepherd/system.scm.in
@@ -41,7 +41,8 @@
             unblock-signals
             set-blocked-signals
             with-blocked-signals
-            without-automatic-finalization))
+            without-automatic-finalization
+            %shell-filename))
 
 ;; The <sys/reboot.h> constants.
 (define RB_AUTOBOOT @RB_AUTOBOOT@)
@@ -328,3 +329,5 @@ Turning finalization off shuts down the finalization thread as a side effect."
         exp ...)
       (lambda ()
         (%set-automatic-finalization-enabled?! enabled?)))))
+
+(define %shell-filename "@SHELL@")
-- 
2.38.1