Use suspendable ports for the agent, with timeouts

This seems like a way of making the Guile internals for doing network I/O
reliable. Currently, there are problems where things on the network timeout,
but the Guile code for reading/writing just sits there, hung.

This seems like it might help.

2 files changed, 59 insertions, 45 deletions

diff --git a/guix-build-coordinator/agent-messaging/http.scm b/guix-build-coordinator/agent-messaging/http.scm
index cec0168..deac4cd 100644
--- a/guix-build-coordinator/agent-messaging/http.scm
+++ b/guix-build-coordinator/agent-messaging/http.scm
@@ -201,7 +201,9 @@
            response))))))
 
   (retry-on-error (lambda ()
-                    (with-gc-protection make-request))
+                    (with-port-timeouts
+                     (lambda ()
+                       (with-gc-protection make-request))))
                   #:times 9
                   #:delay 10
                   #:ignore agent-error-from-coordinator?))
diff --git a/guix-build-coordinator/utils.scm b/guix-build-coordinator/utils.scm
index eee2640..9a83358 100644
--- a/guix-build-coordinator/utils.scm
+++ b/guix-build-coordinator/utils.scm
@@ -14,6 +14,8 @@
   #:use-module (ice-9 textual-ports)
   #:use-module (ice-9 rdelim)
   #:use-module (ice-9 binary-ports)
+  #:use-module (ice-9 suspendable-ports)
+  #:use-module ((ice-9 ports internal) #:select (port-poll))
   #:use-module (ice-9 exceptions)
   #:use-module (rnrs bytevectors)
   #:use-module (web uri)
@@ -50,6 +52,8 @@
             use-gc-protection?
             with-gc-protection
 
+            with-port-timeouts
+
             request-query-parameters
 
             call-with-streaming-http-request
@@ -301,6 +305,12 @@ upcoming chunk."
         gc-enable)
       (thunk)))
 
+(define* (with-port-timeouts thunk #:key (timeout (* 120 1000)))
+  (parameterize
+      ((current-read-waiter (lambda (port) (port-poll port "r" timeout)))
+       (current-write-waiter (lambda (port) (port-poll port "w" timeout))))
+    (thunk)))
+
 (define* (make-chunked-output-port* port #:key (keep-alive? #f)
                                     (buffering 1200)
                                     report-bytes-sent)
@@ -351,50 +361,52 @@ upcoming chunk."
                                            #:key (headers '())
                                            (method 'PUT)
                                            report-bytes-sent)
-  (let* ((port (open-socket-for-uri uri))
-         (request
-          (build-request
-           uri
-           #:method method
-           #:version '(1 . 1)
-           #:headers `((connection close)
-                       (Transfer-Encoding . "chunked")
-                       (Content-Type . "application/octet-stream")
-                       ,@headers)
-           #:port port)))
-
-    (set-port-encoding! port "ISO-8859-1")
-    (setvbuf port 'block (expt 2 13))
-    (with-exception-handler
-        (lambda (exp)
-          (simple-format #t "error: PUT ~A: ~A\n" (uri-path uri) exp)
-          (close-port port)
-          (raise-exception exp))
-      (lambda ()
-        (let ((request (write-request request port)))
-          (let* ((chunked-output-port
-                  (make-chunked-output-port*
-                   port
-                   #:buffering (expt 2 12)
-                   #:keep-alive? #t
-                   #:report-bytes-sent report-bytes-sent)))
-
-            ;; A SIGPIPE will kill Guile, so ignore it
-            (sigaction SIGPIPE
-              (lambda (arg)
-                (simple-format (current-error-port) "warning: SIGPIPE\n")))
-
-            (set-port-encoding! chunked-output-port "ISO-8859-1")
-            (callback chunked-output-port)
-            (close-port chunked-output-port)
-
-            (with-gc-protection
-             (lambda ()
-               (let ((response (read-response port)))
-                 (let ((body (read-response-body response)))
-                   (close-port port)
-                   (values response
-                           body)))))))))))
+  (with-port-timeouts
+   (lambda ()
+     (let* ((port (open-socket-for-uri uri))
+            (request
+             (build-request
+              uri
+              #:method method
+              #:version '(1 . 1)
+              #:headers `((connection close)
+                          (Transfer-Encoding . "chunked")
+                          (Content-Type . "application/octet-stream")
+                          ,@headers)
+              #:port port)))
+
+       (set-port-encoding! port "ISO-8859-1")
+       (setvbuf port 'block (expt 2 13))
+       (with-exception-handler
+           (lambda (exp)
+             (simple-format #t "error: PUT ~A: ~A\n" (uri-path uri) exp)
+             (close-port port)
+             (raise-exception exp))
+         (lambda ()
+           (let ((request (write-request request port)))
+             (let* ((chunked-output-port
+                     (make-chunked-output-port*
+                      port
+                      #:buffering (expt 2 12)
+                      #:keep-alive? #t
+                      #:report-bytes-sent report-bytes-sent)))
+
+               ;; A SIGPIPE will kill Guile, so ignore it
+               (sigaction SIGPIPE
+                 (lambda (arg)
+                   (simple-format (current-error-port) "warning: SIGPIPE\n")))
+
+               (set-port-encoding! chunked-output-port "ISO-8859-1")
+               (callback chunked-output-port)
+               (close-port chunked-output-port)
+
+               (with-gc-protection
+                (lambda ()
+                  (let ((response (read-response port)))
+                    (let ((body (read-response-body response)))
+                      (close-port port)
+                      (values response
+                              body)))))))))))))
 
 (define (find-missing-substitutes-for-output store substitute-urls output)
   (if (valid-path? store output)