Avoid issue with accessing the Git repo from fibers

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)))))