aboutsummaryrefslogtreecommitdiff
path: root/guix-build-coordinator
diff options
context:
space:
mode:
authorChristopher Baines <mail@cbaines.net>2024-03-02 09:23:30 +0000
committerChristopher Baines <mail@cbaines.net>2024-03-02 09:23:30 +0000
commit1c80525d21f183ed2556def6fcd021f6ea9a88a4 (patch)
tree5671dc0b1aa468729aaee218d62a0bf1f833c6bd /guix-build-coordinator
parent9f1545b15269523eac109b54e1a62f4c0cda837e (diff)
downloadbuild-coordinator-1c80525d21f183ed2556def6fcd021f6ea9a88a4.tar
build-coordinator-1c80525d21f183ed2556def6fcd021f6ea9a88a4.tar.gz
Actually use non-blocking ports for network requests
In most places at least.
Diffstat (limited to 'guix-build-coordinator')
-rw-r--r--guix-build-coordinator/agent-messaging/http.scm108
-rw-r--r--guix-build-coordinator/client-communication.scm4
-rw-r--r--guix-build-coordinator/utils.scm21
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