From 1c80525d21f183ed2556def6fcd021f6ea9a88a4 Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Sat, 2 Mar 2024 09:23:30 +0000
Subject: Actually use non-blocking ports for network requests

In most places at least.
---
 guix-build-coordinator/agent-messaging/http.scm | 108 +++++++++++++-----------
 guix-build-coordinator/client-communication.scm |   4 -
 guix-build-coordinator/utils.scm                |  21 +++--
 3 files changed, 71 insertions(+), 62 deletions(-)

diff --git a/guix-build-coordinator/agent-messaging/http.scm b/guix-build-coordinator/agent-messaging/http.scm
index 66045b4..0baa75b 100644
--- a/guix-build-coordinator/agent-messaging/http.scm
+++ b/guix-build-coordinator/agent-messaging/http.scm
@@ -144,56 +144,64 @@
   (define first-request-failed? #f)
 
   (define (make-request)
-    (let-values (((response body)
-                  (http-request uri
-                                #:method method
-                                #:body (scm->json-string body)
-                                #:decode-body? #f
-                                #:headers
-                                `((Authorization . ,auth-value)
-                                  ,@headers))))
-      (let ((code (response-code response)))
-        (cond
-         ((= code 400)
-          (and=> (coordinator-handle-failed-request log
-                                                    method
-                                                    path
-                                                    response
-                                                    body)
-                 (lambda (error)
-                   (raise-exception
-                    (make-agent-error-from-coordinator
-                     (assoc-ref error "error"))))))
-
-         ((= code 404)
-          (values
-           (and body (json-string->scm (utf8->string body)))
-           response))
-
-         ((>= (response-code response) 400)
-          (let ((body
-                 (coordinator-handle-failed-request log
-                                                    method
-                                                    path
-                                                    response
-                                                    body)))
-            (if (and first-request-failed?
-                     succeed-on-access-denied-retry?
-                     (equal? body
-                             '(("error" . "access denied"))))
-                (begin
-                  (log 'WARN
-                       "treating access denied response as success")
-                  (values body response))
-                (begin
-                  (set! first-request-failed? #t)
-                  (raise-exception
-                   (make-exception-with-message
-                    body))))))
-         (else
-          (values
-           (and body (json-string->scm (utf8->string body)))
-           response))))))
+    (let* ((port
+            socket
+            (open-socket-for-uri* uri))
+
+           (response
+            body
+            (http-request uri
+                          #:port port
+                          #:method method
+                          #:body (scm->json-string body)
+                          #:decode-body? #f
+                          #:headers
+                          `((Authorization . ,auth-value)
+                            ,@headers)))
+
+           (code (response-code response)))
+
+      (cond
+       ((= code 400)
+        (and=> (coordinator-handle-failed-request log
+                                                  method
+                                                  path
+                                                  response
+                                                  body)
+               (lambda (error)
+                 (raise-exception
+                  (make-agent-error-from-coordinator
+                   (assoc-ref error "error"))))))
+
+       ((= code 404)
+        (values
+         (and body (json-string->scm (utf8->string body)))
+         response))
+
+       ((>= (response-code response) 400)
+        (let ((body
+               (coordinator-handle-failed-request log
+                                                  method
+                                                  path
+                                                  response
+                                                  body)))
+          (if (and first-request-failed?
+                   succeed-on-access-denied-retry?
+                   (equal? body
+                           '(("error" . "access denied"))))
+              (begin
+                (log 'WARN
+                     "treating access denied response as success")
+                (values body response))
+              (begin
+                (set! first-request-failed? #t)
+                (raise-exception
+                 (make-exception-with-message
+                  body))))))
+       (else
+        (values
+         (and body (json-string->scm (utf8->string body)))
+         response)))))
 
   (retry-on-error (lambda ()
                     (with-port-timeouts make-request))
diff --git a/guix-build-coordinator/client-communication.scm b/guix-build-coordinator/client-communication.scm
index 5a66cdd..c0118aa 100644
--- a/guix-build-coordinator/client-communication.scm
+++ b/guix-build-coordinator/client-communication.scm
@@ -683,10 +683,6 @@
          (port
           socket
           (open-socket-for-uri* uri)))
-    ;; Guile/guile-gnutls don't handle the handshake happening on a non
-    ;; blocking socket, so change the behavior here.
-    (let ((flags (fcntl socket F_GETFL)))
-      (fcntl socket F_SETFL (logior O_NONBLOCK flags)))
 
     (let ((response
            body
diff --git a/guix-build-coordinator/utils.scm b/guix-build-coordinator/utils.scm
index 6139835..a9d7edf 100644
--- a/guix-build-coordinator/utils.scm
+++ b/guix-build-coordinator/utils.scm
@@ -268,7 +268,7 @@
                                            streaming?)
   (with-port-timeouts
    (lambda ()
-     (let* ((port (open-socket-for-uri uri))
+     (let* ((port (open-socket-for-uri* uri))
             (request
              (build-request
               uri
@@ -1436,13 +1436,18 @@ again."
          #:fragment (uri-fragment uri))
         uri))
 
-  (let ((s (open-socket-for-uri plain-uri)))
-    (values
-     (if https?
-         (tls-wrap s (uri-host uri)
-                   #:verify-certificate? verify-certificate?)
-         s)
-     s)))
+  (let* ((s (open-socket-for-uri plain-uri))
+         (port
+          (if https?
+              (tls-wrap s (uri-host uri)
+                        #:verify-certificate? verify-certificate?)
+              s)))
+    (values port
+            (if non-blocking?
+                ;; Guile/guile-gnutls don't handle the handshake happening on
+                ;; a non blocking socket, so change the behavior here.
+                (non-blocking-port s)
+                s))))
 
 (define (check-locale!)
   (with-exception-handler
-- 
cgit v1.2.3