[shepherd] 02/02: service: 'spawn-command' takes keyword parameters.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository shepherd.

commit 0f3276a9c3dafbef41b0aab88ba5dda1bb78dc99
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Sat Mar 4 21:51:30 2023 +0100

    service: 'spawn-command' takes keyword parameters.
    
    Fixes <https://issues.guix.gnu.org/60106>.
    
    * modules/shepherd/service.scm (process-monitor): 'spawn' message now
    expects an argument list, passes it to 'fork+exec-command'.
    (spawn-via-monitor): Rename 'command' to 'arguments'.
    (spawn-command): Change to accept #:user, #:group,
     #:environment-variables, #:directory, and #:resource-limits.
    * modules/shepherd.scm (main): Adjust 'system*' replacement
    accordingly.
---
 modules/shepherd.scm         |  5 ++--
 modules/shepherd/service.scm | 61 ++++++++++++++++++++++++++++++++++----------
 2 files changed, 51 insertions(+), 15 deletions(-)

diff --git a/modules/shepherd.scm b/modules/shepherd.scm
index 1d51db1..2e4e8e5 100644
--- a/modules/shepherd.scm
+++ b/modules/shepherd.scm
@@ -1,5 +1,5 @@
 ;; shepherd.scm -- The daemon shepherd.
-;; Copyright (C) 2013-2014, 2016, 2018-2020, 2022 Ludovic Courtès 
<ludo@gnu.org>
+;; Copyright (C) 2013-2014, 2016, 2018-2020, 2022-2023 Ludovic Courtès 
<ludo@gnu.org>
 ;; Copyright (C) 2002, 2003 Wolfgang Jährling <wolfgang@pro-linux.de>
 ;; Copyright (C) 2018 Carlo Zancanaro <carlo@zancanaro.id.au>
 ;; Copyright (C) 2018 Danny Milosavljevic <dannym@scratchpost.org>
@@ -405,7 +405,8 @@ 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*))
-                  (set! system* spawn-command)
+                  (set! system* (lambda command
+                                  (spawn-command command)))
 
                   ;; Restore 'system*' after fork.
                   (set! primitive-fork
diff --git a/modules/shepherd/service.scm b/modules/shepherd/service.scm
index 353c1bd..2e7371e 100644
--- a/modules/shepherd/service.scm
+++ b/modules/shepherd/service.scm
@@ -2139,12 +2139,13 @@ otherwise by updating its state."
                          vlist-null
                          waiters)))
 
-      (('spawn command reply)
-       ;; Spawn COMMAND; send the spawn result (PID or exception) to REPLY;
-       ;; 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 ((result (boxed-errors (fork+exec-command command))))
+      (('spawn arguments reply)
+       ;; Spawn the command as specified by ARGUMENTS; send the spawn result
+       ;; (PID or exception) to REPLY; 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 ((result (boxed-errors
+                      (apply fork+exec-command arguments))))
          (put-message reply result)
          (match result
            (('exception . _)
@@ -2186,18 +2187,52 @@ 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-via-monitor command)
+(define (spawn-via-monitor arguments)
   (let ((reply (make-channel)))
     (put-message (current-process-monitor)
-                 `(spawn ,command ,reply))
+                 `(spawn ,arguments ,reply))
     (unboxed-errors (get-message reply))
     (get-message reply)))
 
-(define (spawn-command program . arguments)
-  "Like 'system*' but do not block while waiting for PROGRAM to terminate."
-  (if (current-process-monitor)
-      (spawn-via-monitor (cons program arguments))
-      (apply system* program arguments)))
+(define spawn-command
+  (let ((warn-deprecated-form
+         ;; In 0.9.3, this procedure took a rest list.
+         (lambda ()
+           (issue-deprecation-warning
+            "This 'spawn-command' form is deprecated; use\
+ (spawn-command '(\"PROGRAM\" \"ARGS\"...))."))))
+    (case-lambda*
+     ((command #:key
+               (user #f)
+               (group #f)
+               (environment-variables (default-environment-variables))
+               (directory (default-service-directory))
+               (resource-limits '()))
+      "Like @code{system*}, spawn @var{command} (a list of strings) but do not 
block
+while waiting for @var{program} to terminate."
+      (let ((command (if (string? command)
+                         (begin
+                           (warn-deprecated-form)
+                           (list command))
+                         command)))
+        (if (current-process-monitor)
+            (spawn-via-monitor
+             (list command
+                   #:user user #:group group
+                   #:environment-variables environment-variables
+                   #:directory directory
+                   #:resource-limits resource-limits))
+            (let ((pid (fork+exec-command
+                        command
+                        #:user user #:group group
+                        #:environment-variables environment-variables
+                        #:directory directory
+                        #:resource-limits resource-limits)))
+              (match (waitpid pid)
+                ((_ . status) status))))))
+     ((program . arguments)
+      ;; The old form, which appeared in 0.9.3.
+      (spawn-command (cons program arguments))))))
 
 (define default-process-termination-grace-period
   ;; Default process termination "grace period" before we send SIGKILL.