From 64370a98dfc17f0531de7397a38362c03a1d89bc Mon Sep 17 00:00:00 2001
From: ulfvonbelow <striness@tilde.club>
Date: Sat, 25 Feb 2023 00:42:41 -0600
Subject: [PATCH 1/3] service: Propagate exceptions while spawning in process
 monitor.

* modules/shepherd/service.scm (unboxed-errors): new procedure.
  (boxed-errors): new syntax.
  (process-monitor): use it to propagate exceptions from fork+exec-command via
  reply channel.
  (spawn-via-monitor): new procedure.
  (spawn-command): use it.
---
 modules/shepherd/service.scm | 47 ++++++++++++++++++++++++++++--------
 1 file changed, 37 insertions(+), 10 deletions(-)

diff --git a/modules/shepherd/service.scm b/modules/shepherd/service.scm
index fd2ef1b..196ee44 100644
--- a/modules/shepherd/service.scm
+++ b/modules/shepherd/service.scm
@@ -1825,6 +1825,24 @@ otherwise by updating its state."
        ;; loop so we don't miss any terminated child process.
        (loop)))))
 
+(define-syntax-rule (boxed-errors exps ...)
+  (catch #t
+    (lambda ()
+      (call-with-values
+          (lambda ()
+            exps ...)
+        (lambda results
+          (list 'success results))))
+    (lambda args
+      (list 'exception args))))
+
+(define unboxed-errors
+  (match-lambda
+    (('success vals)
+     (apply values vals))
+    (('exception args)
+     (apply throw args))))
+
 (define (process-monitor channel)
   "Run a process monitor that handles requests received over @var{channel}."
   (let loop ((waiters vlist-null))
@@ -1860,11 +1878,17 @@ otherwise by updating its state."
                          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))))
+       ;; 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))))
+         (put-message reply result)
+         (match result
+           (('exception . _)
+            (loop waiters))
+           (('success (pid))
+            (loop (vhash-consv pid reply waiters))))))
 
       (('await pid reply)
        ;; Await the termination of PID and send its status on REPLY.
@@ -1900,14 +1924,17 @@ 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)
+  (let ((reply (make-channel)))
+    (put-message (current-process-monitor)
+                 `(spawn ,command ,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)
-      (let ((reply (make-channel)))
-        (put-message (current-process-monitor)
-                     `(spawn ,(cons program arguments)
-                             ,reply))
-        (get-message reply))
+      (spawn-via-monitor (cons program arguments))
       (apply system* program arguments)))
 
 (define default-process-termination-grace-period
-- 
2.38.1