Try to make starting hashing outputs more reliable

Even if the connection to the agent has dropped when the upload has completed.

1 files changed, 102 insertions, 77 deletions

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))))