Make client requests mostly suspendable

2 files changed, 108 insertions, 69 deletions

diff --git a/guix-build-coordinator/client-communication.scm b/guix-build-coordinator/client-communication.scm
index d7877b3..66f0a9c 100644
--- a/guix-build-coordinator/client-communication.scm
+++ b/guix-build-coordinator/client-communication.scm
@@ -23,6 +23,7 @@
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-43)
+  #:use-module (srfi srfi-71)
   #:use-module (ice-9 format)
   #:use-module (ice-9 match)
   #:use-module (ice-9 streams)
@@ -65,27 +66,24 @@
                                      port
                                      build-coordinator
                                      substitutes-channel)
-  (call-with-error-handling
-   (lambda ()
-     (run-server/patched
-      (lambda (request body)
-        (log-msg (build-coordinator-logger build-coordinator)
-                 'INFO
-                 (format #f "~4a ~a\n"
-                         (request-method request)
-                         (uri-path (request-uri request))))
-        (apply values
-               (controller request
-                           (cons (request-method request)
-                                 (split-and-decode-uri-path
-                                  (uri-path (request-uri request))))
-                           body
-                           secret-key-base
-                           build-coordinator
-                           substitutes-channel)))
-      #:host host
-      #:port port))
-   #:on-error 'backtrace))
+  (run-server/patched
+   (lambda (request body)
+     (log-msg (build-coordinator-logger build-coordinator)
+              'INFO
+              (format #f "~4a ~a\n"
+                      (request-method request)
+                      (uri-path (request-uri request))))
+     (apply values
+            (controller request
+                        (cons (request-method request)
+                              (split-and-decode-uri-path
+                               (uri-path (request-uri request))))
+                        body
+                        secret-key-base
+                        build-coordinator
+                        substitutes-channel)))
+   #:host host
+   #:port port))
 
 (define (controller request
                     method-and-path-components
@@ -664,54 +662,63 @@
                        path
                        #:optional
                        request-body)
-  (let-values (((response body)
-                (http-request (string->uri
-                               (string-append coordinator-uri path))
-                              #:method method
-                              #:body (and=> request-body scm->json-string)
-                              #:decode-body? #f
-                              #:streaming? #t)))
-    (if (>= (response-code response) 400)
-        (begin
-          (simple-format
-           (current-error-port)
-           "error: coordinator-http-request: ~A ~A: ~A\n"
-           method path (response-code response))
-          (let ((body
-                 (catch #t
-                   (lambda ()
-                     (if (equal? '(application/json (charset . "utf-8"))
-                                 (response-content-type response))
-                         (json-string->scm
-                          (utf8->string
-                           (read-response-body response)))
-                         (utf8->string
-                          (read-response-body response))))
-                   (lambda (key . args)
-                     (simple-format
-                      (current-error-port)
-                      "error decoding body ~A ~A\n"
-                      key args)
-                     #f))))
-            (raise-exception
-             (make-exception-with-message
-              body))))
-
-        (begin
-          (set-port-encoding! body "UTF-8")
-
-          (values
-           (if (equal? '(application/json-seq)
-                       (response-content-type response))
-               (json-seq->scm
-                body
-                ;; TODO I would like to use 'throw, but it always raises an
-                ;; exception, so this needs fixing upstream first
-                #:handle-truncate 'replace)
-               (json-string->scm
-                (utf8->string
-                 (read-response-body response))))
-           response)))))
+  (let* ((uri
+          (string->uri
+           (string-append coordinator-uri path)))
+         (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
+           (http-request
+            uri
+            #:port port
+            #:method method
+            #:body (and=> request-body scm->json-string)
+            #:decode-body? #f
+            #:streaming? #t)))
+      (if (>= (response-code response) 400)
+          (begin
+            (simple-format
+             (current-error-port)
+             "error: coordinator-http-request: ~A ~A: ~A\n"
+             method path (response-code response))
+            (let ((body
+                   (catch #t
+                     (lambda ()
+                       (if (equal? '(application/json (charset . "utf-8"))
+                                   (response-content-type response))
+                           (json->scm body)
+                           (utf8->string
+                            (read-response-body response))))
+                     (lambda (key . args)
+                       (simple-format
+                        (current-error-port)
+                        "error decoding body ~A ~A\n"
+                        key args)
+                       #f))))
+              (raise-exception
+               (make-exception-with-message
+                body))))
+
+          (begin
+            (set-port-encoding! body "UTF-8")
+
+            (values
+             (if (equal? '(application/json-seq)
+                         (response-content-type response))
+                 (json-seq->scm
+                  body
+                  ;; TODO I would like to use 'throw, but it always raises an
+                  ;; exception, so this needs fixing upstream first
+                  #:handle-truncate 'replace)
+                 (json->scm body))
+             response))))))
 
 (define* (send-submit-build-request
           coordinator-uri
diff --git a/guix-build-coordinator/utils.scm b/guix-build-coordinator/utils.scm
index a98121b..06c22c6 100644
--- a/guix-build-coordinator/utils.scm
+++ b/guix-build-coordinator/utils.scm
@@ -98,6 +98,8 @@
             get-port-metrics-updater
             get-guix-memory-metrics-updater
 
+            open-socket-for-uri*
+
             check-locale!
 
             core-guile-sleep))
@@ -1339,6 +1341,36 @@ again."
                                         proc)))))
      %memoization-tables)))
 
+;; Returns the port as well as the raw socket
+(define* (open-socket-for-uri* uri
+                               #:key (verify-certificate? #t)
+                               (non-blocking? #t))
+  (define tls-wrap
+    (@@ (web client) tls-wrap))
+
+  (define https?
+    (eq? 'https (uri-scheme uri)))
+
+  (define plain-uri
+    (if https?
+        (build-uri
+         'http
+         #:userinfo (uri-userinfo uri)
+         #:host (uri-host uri)
+         #:port (or (uri-port uri) 443)
+         #:path (uri-path uri)
+         #:query (uri-query uri)
+         #: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)))
+
 (define (check-locale!)
   (with-exception-handler
       (lambda (exn)