Add with-timeout to utils

2 files changed, 37 insertions, 1 deletions

diff --git a/.dir-locals.el b/.dir-locals.el
index 1245b17..150e28a 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -8,5 +8,6 @@
   (indent-tabs-mode)
   (eval put 'make-parameter 'scheme-indent-function 1)
   (eval put 'with-db-worker-thread 'scheme-indent-function 1)
+  (eval put 'with-timeout 'scheme-indent-function 1)
   (eval . (put 'call-with-lzip-output-port 'scheme-indent-function 1))
   (eval . (put 'with-store 'scheme-indent-function 1))))
diff --git a/guix-build-coordinator/utils.scm b/guix-build-coordinator/utils.scm
index e72cf94..5c0fffd 100644
--- a/guix-build-coordinator/utils.scm
+++ b/guix-build-coordinator/utils.scm
@@ -54,7 +54,9 @@
 
             with-time-logging
 
-            create-work-queue))
+            create-work-queue
+
+            with-timeout))
 
 
 (define %worker-thread-args
@@ -593,3 +595,36 @@ References: ~a~%"
      (iota thread-count))
 
     (values process-job count-jobs)))
+
+;; copied from (guix scripts substitute)
+(define-syntax-rule (with-timeout duration handler body ...)
+  "Run BODY; when DURATION seconds have expired, call HANDLER, and run BODY
+again."
+  (begin
+    (sigaction SIGALRM
+      (lambda (signum)
+        (sigaction SIGALRM SIG_DFL)
+        handler))
+    (alarm duration)
+    (call-with-values
+        (lambda ()
+          (let try ()
+            (catch 'system-error
+              (lambda ()
+                body ...)
+              (lambda args
+                ;; Before Guile v2.0.9-39-gfe51c7b, the SIGALRM triggers EINTR
+                ;; because of the bug at
+                ;; <http://lists.gnu.org/archive/html/guile-devel/2013-06/msg00050.html>.
+                ;; When that happens, try again.  Note: SA_RESTART cannot be
+                ;; used because of <http://bugs.gnu.org/14640>.
+                (if (= EINTR (system-error-errno args))
+                    (begin
+                      ;; Wait a little to avoid bursts.
+                      (usleep (random 3000000 %random-state))
+                      (try))
+                    (apply throw args))))))
+      (lambda result
+        (alarm 0)
+        (sigaction SIGALRM SIG_DFL)
+        (apply values result)))))