1 files changed, 81 insertions, 0 deletions
diff --git a/guix-build-coordinator/utils/timeout.scm b/guix-build-coordinator/utils/timeout.scm
new file mode 100644
index 0000000..bb133d7
--- /dev/null
+++ b/guix-build-coordinator/utils/timeout.scm
@@ -0,0 +1,81 @@
+(define-module (guix-build-coordinator utils timeout)
+  #:use-module (ice-9 exceptions)
+  #:use-module (ice-9 suspendable-ports)
+  #:use-module ((ice-9 ports internal) #:select (port-poll))
+  #:export (&port-timeout
+            &port-read-timeout
+            &port-write-timeout
+
+            port-timeout-error?
+            port-read-timeout-error?
+            port-write-timeout-error?
+
+            with-port-timeouts))
+
+(define &port-timeout
+  (make-exception-type '&port-timeout
+                       &external-error
+                       '(port)))
+
+(define make-port-timeout-error
+  (record-constructor &port-timeout))
+
+(define port-timeout-error?
+  (record-predicate &port-timeout))
+
+(define &port-read-timeout
+  (make-exception-type '&port-read-timeout
+                       &port-timeout
+                       '()))
+
+(define make-port-read-timeout-error
+  (record-constructor &port-read-timeout))
+
+(define port-read-timeout-error?
+  (record-predicate &port-read-timeout))
+
+(define &port-write-timeout
+  (make-exception-type '&port-write-timeout
+                       &port-timeout
+                       '()))
+
+(define make-port-write-timeout-error
+  (record-constructor &port-write-timeout))
+
+(define port-write-timeout-error?
+  (record-predicate &port-write-timeout))
+
+(define* (with-port-timeouts thunk #:key timeout)
+
+  ;; When the GC runs, it restarts the poll syscall, but the timeout remains
+  ;; unchanged! When the timeout is longer than the time between the syscall
+  ;; restarting, I think this renders the timeout useless. Therefore, this
+  ;; code uses a short timeout, and repeatedly calls poll while watching the
+  ;; clock to see if it has timed out overall.
+  (define poll-timeout-ms 200)
+
+  (define (wait port mode)
+    (let ((timeout-internal
+           (+ (get-internal-real-time)
+              (* internal-time-units-per-second timeout))))
+      (let loop ((poll-value
+                  (port-poll port mode poll-timeout-ms)))
+        (if (= poll-value 0)
+            (if (> (get-internal-real-time)
+                   timeout-internal)
+                (raise-exception
+                 (if (string=? mode "r")
+                     (make-port-read-timeout-error port)
+                     (make-port-write-timeout-error port)))
+                (loop (port-poll port mode poll-timeout-ms)))
+            poll-value))))
+
+  (parameterize
+      ((current-read-waiter
+        (lambda (port)
+          (wait port "r")))
+       (current-write-waiter
+        (lambda (port)
+          (wait port "w"))))
+    (thunk)))
+