juli pushed a commit to branch wip-goblinsify
in repository shepherd.
commit bb723d208661474e24062e1b9c0e3257dccf96ae
Author: Juliana Sims <[email protected]>
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)
