diff options
Diffstat (limited to 'guix-build-coordinator')
-rw-r--r-- | guix-build-coordinator/agent-messaging/http.scm | 4 | ||||
-rw-r--r-- | guix-build-coordinator/utils.scm | 100 |
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) |