diff options
Diffstat (limited to 'guix-qa-frontpage/utils.scm')
| -rw-r--r-- | guix-qa-frontpage/utils.scm | 32 |
1 files changed, 31 insertions, 1 deletions
diff --git a/guix-qa-frontpage/utils.scm b/guix-qa-frontpage/utils.scm index ba27c87..f0b47a9 100644 --- a/guix-qa-frontpage/utils.scm +++ b/guix-qa-frontpage/utils.scm @@ -20,13 +20,16 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-71) #:use-module (ice-9 match) + #:use-module (ice-9 threads) #:use-module (fibers) #:use-module (fibers channels) + #:use-module ((guix-build-coordinator utils) #:select (with-port-timeouts)) #:use-module (guix-build-coordinator utils fibers) #:export (fiberize fibers-map fibers-batch-for-each - fibers-for-each) + fibers-for-each + non-blocking) #:re-export (with-fibers-port-timeouts)) (define* (fiberize proc #:key (parallelism 1)) @@ -128,3 +131,30 @@ (define (fibers-for-each proc . lists) (apply fibers-batch-for-each proc 20 lists)) + +(define (non-blocking thunk) + (let ((channel (make-channel))) + (call-with-new-thread + (lambda () + (with-exception-handler + (lambda (exn) + (put-message channel `(exception ,exn))) + (lambda () + (with-throw-handler #t + (lambda () + (call-with-values + (lambda () + ;; This is mostly to set non fibers IO waiters + (with-port-timeouts thunk + #:timeout (* 300 1000))) + (lambda values + (put-message channel `(values ,@values))))) + (lambda args + (display (backtrace) (current-error-port)) + (newline (current-error-port))))) + #:unwind? #t))) + (match (get-message channel) + (('values . results) + (apply values results)) + (('exception . exn) + (raise-exception exn))))) |