[shepherd] 05/15: scratch: Stub out timeout support.

[Juliana Sims]

juli pushed a commit to branch wip-goblinsify
in repository shepherd.

commit f4ddf3ad832951b31c0906e401c9bff4a0602571
Author: Juliana Sims <juli@incana.org>
AuthorDate: Thu Oct 10 09:19:20 2024 -0400

    scratch: Stub out timeout support.
    
    * scratch.scm (^timeout, &timeout-error): New symbol.
    (terminate-process): Use race and ^timeout.
---
 scratch.scm | 22 +++++++++++++++++-----
 1 file changed, 17 insertions(+), 5 deletions(-)

diff --git a/scratch.scm b/scratch.scm
index 79d42d4..2cbbe74 100644
--- a/scratch.scm
+++ b/scratch.scm
@@ -40,6 +40,15 @@ it"
      (define id
        (spawn-named 'id ^pcell val))]))
 
+;; Thanks to David Thompson for this one
+(define (^timeout bcom)
+  (lambda* (#:key (duration (default-process-termination-grace-period))
+            (value 'timeout))
+    (spawn-fibrous-vow
+     (lambda ()
+       (sleep duration)
+       value))))
+
 ;;; extant Shepherd utils
 
 (define (remove pred lst)
@@ -55,6 +64,11 @@ it"
 
 ;;; porting experiments
 
+;; Original exceptions
+
+(define-exception-type &timeout-error &external-error
+  make-timeout-error timeout-error?)
+
 ;; Shepherd uses SRFI-34 and SRFI-35 for exceptions. Let's update those
 
 ;; Service errors.
@@ -775,10 +789,10 @@ which its completion status will be sent."
 group; wait for @var{pid} to terminate and return its exit status.  If
 @var{pid} is still running @var{grace-period} seconds after @var{signal} has
 been sent, send it @code{SIGKILL}."
-  ;; TODO: implement grace-period support
   (assert (current-process-monitor))
   (catch-system-error (kill pid signal))
-  (on (<- (current-process-monitor) 'await (abs pid))
+  (on (race (<- (current-process-monitor) 'await (abs pid))
+            ($ (spawn ^timeout) #:duration grace-period))
       (lambda (status)
         (if status
             status
@@ -812,9 +826,7 @@ process is still running after @var{grace-period} seconds, 
send it
 
 (with-vat shepherd-vat
   (let ((cl (command-line)))
-    (if (> (length cl) 1)
-        (primitive-load* (cadr cl))
-        (primitive-load* (car cl)))
+    (primitive-load* ((if (> (length cl) 1) cadr car) cl))
     (let lp ()
       (on (<- (current-registry) 'service-list)
           (lambda (lst)