Add a with-fibers-timeout utility

1 files changed, 34 insertions, 1 deletions

diff --git a/guix-build-coordinator/utils/fibers.scm b/guix-build-coordinator/utils/fibers.scm
index c9a04fb..3dc612c 100644
--- a/guix-build-coordinator/utils/fibers.scm
+++ b/guix-build-coordinator/utils/fibers.scm
@@ -17,7 +17,9 @@
 
             run-server/patched
 
-            letpar&))
+            letpar&
+
+            with-fibers-timeout))
 
 (define %worker-thread-args
   (make-parameter #f))
@@ -331,3 +333,34 @@ If already in the worker thread, call PROC immediately."
       (lambda () (parallel-via-fibers e ...))
     (lambda (v ...)
       b0 b1 ...)))
+
+(define* (with-fibers-timeout thunk #:key timeout on-timeout)
+  (let ((channel (make-channel)))
+    (spawn-fiber
+     (lambda ()
+       (with-exception-handler
+           (lambda (exn)
+             (perform-operation
+              (choice-operation
+               (put-operation channel (cons 'exception exn))
+               (sleep-operation timeout))))
+         (lambda ()
+           (call-with-values thunk
+             (lambda vals
+               (perform-operation
+                (choice-operation
+                 (put-operation channel vals)
+                 (sleep-operation timeout))))))
+         #:unwind? #t)))
+
+    (match (perform-operation
+            (choice-operation
+             (get-operation channel)
+             (wrap-operation (sleep-operation timeout)
+                             (const 'timeout))))
+      ('timeout
+       (on-timeout))
+      (('exception . exn)
+       (raise-exception exn))
+      (vals
+       (apply values vals)))))