Add with-port-timeouts helper

From the Guix Build Coordinator.

1 files changed, 30 insertions, 1 deletions

diff --git a/nar-herder/utils.scm b/nar-herder/utils.scm
index f4c39f8..ab42a4a 100644
--- a/nar-herder/utils.scm
+++ b/nar-herder/utils.scm
@@ -32,6 +32,8 @@
   #:use-module (ice-9 binary-ports)
   #:use-module (ice-9 exceptions)
   #:use-module (rnrs bytevectors)
+  #:use-module (ice-9 suspendable-ports)
+  #:use-module ((ice-9 ports internal) #:select (port-poll))
   #:use-module (web uri)
   #:use-module (web http)
   #:use-module (web client)
@@ -66,7 +68,9 @@
 
             create-work-queue
 
-            check-locale!))
+            check-locale!
+
+            with-port-timeouts))
 
 ;; Chunked Responses
 (define (read-chunk-header port)
@@ -661,3 +665,28 @@ If already in the worker thread, call PROC immediately."
              (when duration-logger
                (duration-logger duration))
              (apply values result)))))))
+
+(define &port-timeout
+  (make-exception-type '&port-timeout
+                       &external-error
+                       '()))
+
+(define make-port-timeout-error
+  (record-constructor &port-timeout))
+
+(define port-timeout-error?
+  (record-predicate &port-timeout))
+
+(define* (with-port-timeouts thunk #:key (timeout (* 120 1000)))
+  (parameterize
+      ((current-read-waiter
+        (lambda (port)
+          (when (= (port-poll port "r" timeout) 0)
+            (raise-exception
+             (make-port-timeout-error)))))
+       (current-write-waiter
+        (lambda (port)
+          (when (= (port-poll port "w" timeout) 0)
+            (raise-exception
+             (make-port-timeout-error))))))
+    (thunk)))