From c147a184a7602f5f7f8dbd7075f1818109dc660c Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Fri, 12 May 2023 10:14:43 +0100 Subject: Try to make starting hashing outputs more reliable Even if the connection to the agent has dropped when the upload has completed. --- .../agent-messaging/http/server.scm | 179 ++++++++++++--------- 1 file changed, 102 insertions(+), 77 deletions(-) (limited to 'guix-build-coordinator/agent-messaging') diff --git a/guix-build-coordinator/agent-messaging/http/server.scm b/guix-build-coordinator/agent-messaging/http/server.scm index c867d0c..d7c2b39 100644 --- a/guix-build-coordinator/agent-messaging/http/server.scm +++ b/guix-build-coordinator/agent-messaging/http/server.scm @@ -460,57 +460,62 @@ port. Also, the port used can be changed by passing the --port option.\n" #:unwind? #t)))) channel)) -(define (compute-output-hash-via-channel output-hash-channel - request - response-port - build-uuid - tmp-output-file-name - output-file-name) +(define (start-computing-output-hash-via-channel output-hash-channel + request + response-port + build-uuid + tmp-output-file-name + output-file-name) (let ((channel (make-channel))) - (define (write-to-response-port response) - (display response response-port) - (force-output response-port) - ;; TODO because the chunked output port - ;; doesn't call force-output on the - ;; underlying port, do that here. We - ;; want this event to be sent now, - ;; rather than when some buffer fills - ;; up. - (force-output (request-port request))) - - (define (get-message* channel) - (perform-operation - (choice-operation - (get-operation channel) - (wrap-operation - (sleep-operation 20) - (const 'timeout))))) - (put-message output-hash-channel (list 'request build-uuid tmp-output-file-name output-file-name channel)) - (let loop ((previous-bytes-processed 0) - (message (get-message* channel))) - (match message - (('result result) result) - ('timeout - (write-to-response-port - (simple-format #f "~A\n" previous-bytes-processed)) - (loop previous-bytes-processed - (get-message* channel))) - (bytes-processed - (if (> bytes-processed previous-bytes-processed) - (begin - (write-to-response-port - (simple-format #f "~A\n" bytes-processed)) - (loop bytes-processed - (get-message* channel))) - (begin - ;; Still write to keep the connection open - (write-to-response-port - (simple-format #f "~A\n" previous-bytes-processed)) - (loop previous-bytes-processed - (get-message* channel))))))))) + channel)) + +(define (report-progress-computing-hash channel + request + response-port) + (define (write-to-response-port response) + (display response response-port) + (force-output response-port) + ;; TODO because the chunked output port + ;; doesn't call force-output on the + ;; underlying port, do that here. We + ;; want this event to be sent now, + ;; rather than when some buffer fills + ;; up. + (force-output (request-port request))) + + (define (get-message* channel) + (perform-operation + (choice-operation + (get-operation channel) + (wrap-operation + (sleep-operation 20) + (const 'timeout))))) + + (let loop ((previous-bytes-processed 0) + (message (get-message* channel))) + (match message + (('result result) result) + ('timeout + (write-to-response-port + (simple-format #f "~A\n" previous-bytes-processed)) + (loop previous-bytes-processed + (get-message* channel))) + (bytes-processed + (if (> bytes-processed previous-bytes-processed) + (begin + (write-to-response-port + (simple-format #f "~A\n" bytes-processed)) + (loop bytes-processed + (get-message* channel))) + (begin + ;; Still write to keep the connection open + (write-to-response-port + (simple-format #f "~A\n" previous-bytes-processed)) + (loop previous-bytes-processed + (get-message* channel)))))))) (define* (receive-file body length @@ -833,21 +838,31 @@ port. Also, the port used can be changed by passing the --port option.\n" content-length tmp-output-file-name)))) - (list - (build-response - #:code 200 - #:headers '((content-type . (text/plain)))) - (lambda (response-port) - ;; Make sure NGinx gets the response headers - (force-output (request-port request)) - - (compute-output-hash-via-channel - output-hash-channel - request - response-port - uuid - tmp-output-file-name - output-file-name)))) + (let ((channel + (start-computing-output-hash-via-channel + output-hash-channel + request + response-port + uuid + tmp-output-file-name + output-file-name))) + + (log-msg logger + 'DEBUG + "PUT /build/" uuid "/output/" output-name ": " + "finished receiving " tmp-output-file-name) + + (list + (build-response + #:code 200 + #:headers '((content-type . (text/plain)))) + (lambda (response-port) + ;; Make sure NGinx gets the response headers + (force-output (request-port request)) + + (report-progress-computing-hash channel + request + response-port))))) (render-json '(("error" . "access denied")) #:code 403)))) @@ -902,21 +917,31 @@ port. Also, the port used can be changed by passing the --port option.\n" tmp-output-file-name #:append? #t)) - (list - (build-response - #:code 200 - #:headers '((content-type . (text/plain)))) - (lambda (response-port) - ;; Make sure NGinx gets the response headers - (force-output (request-port request)) - - (compute-output-hash-via-channel - output-hash-channel - request - response-port - uuid - tmp-output-file-name - output-file-name)))) + (let ((channel + (start-computing-output-hash-via-channel + output-hash-channel + request + response-port + uuid + tmp-output-file-name + output-file-name))) + + (log-msg logger + 'DEBUG + "POST /build/" uuid "/output/" output-name "/partial: " + "finished receiving " tmp-output-file-name) + + (list + (build-response + #:code 200 + #:headers '((content-type . (text/plain)))) + (lambda (response-port) + ;; Make sure NGinx gets the response headers + (force-output (request-port request)) + + (report-progress-computing-hash channel + request + response-port))))) (render-json '(("error" . "access denied")) #:code 403)))) -- cgit v1.2.3