Separate read and write timeout exceptions

So it's clearer what has occurred.

1 files changed, 34 insertions, 2 deletions

diff --git a/guix-build-coordinator/utils.scm b/guix-build-coordinator/utils.scm
index 71a9540..00774c8 100644
--- a/guix-build-coordinator/utils.scm
+++ b/guix-build-coordinator/utils.scm
@@ -49,6 +49,14 @@
 
             make-base64-output-port
 
+            &port-timeout
+            &port-read-timeout
+            &port-write-timeout
+
+            port-timeout-error?
+            port-read-timeout-error?
+            port-write-timeout-error?
+
             with-port-timeouts
 
             set-store-connection-timeout
@@ -225,7 +233,7 @@
 (define &port-timeout
   (make-exception-type '&port-timeout
                        &external-error
-                       '()))
+                       '(port)))
 
 (define make-port-timeout-error
   (record-constructor &port-timeout))
@@ -233,6 +241,28 @@
 (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 (* 120 1000)))
 
   ;; When the GC runs, it restarts the poll syscall, but the timeout remains
@@ -253,7 +283,9 @@
             (if (> (get-internal-real-time)
                    timeout-internal)
                 (raise-exception
-                 (make-port-timeout-error))
+                 (if (string=? mode "r")
+                     (make-port-read-timeout-error)
+                     (make-port-write-timeout-error)))
                 (loop (port-poll port mode poll-timeout-ms)))
             poll-value))))