diff options
| -rw-r--r-- | guix-build-coordinator/utils/fibers.scm | 35 |
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))))) |