Change submit-output to not spend so much time waiting

Make use of the coordinator trying to avoid the connection timing out. This
should improve things when the coordinator is restarted or crashes.

1 files changed, 58 insertions, 78 deletions

diff --git a/guix-build-coordinator/agent-messaging/http.scm b/guix-build-coordinator/agent-messaging/http.scm
index 2703c91..96c67ec 100644
--- a/guix-build-coordinator/agent-messaging/http.scm
+++ b/guix-build-coordinator/agent-messaging/http.scm
@@ -329,85 +329,65 @@
               (bytes (if %force-full-upload
                          #f
                          (or partial-upload-bytes
-                             completed-upload-bytes))))
+                             completed-upload-bytes)))
+              (upload-uri
+               (coordinator-uri-for-path
+                (slot-ref interface 'coordinator-uri)
+                (string-append "/build/" build-id "/output/" output-name
+                               (if (integer? bytes)
+                                   "/partial"
+                                   "")))))
+
          ;; Check if the server has all the bytes
          (if (and bytes (= bytes file-size))
-             (begin
-               (log 'DEBUG "perform upload: server has all the bytes"
-                    " (partial-upload-bytes: " partial-upload-bytes
-                    ",completed-upload-bytes: " completed-upload-bytes ")")
-
-               (unless completed-upload-bytes
-                 (let loop ((retry 1))
-                   (sleep 30)
-
-                   (if (get-completed-upload-bytes)
-                       (log 'DEBUG "upload completed")
-                       (if (< retry 30)
-                           (begin
-                             (log 'DEBUG "upload not yet completed, "
-                                  "rechecking in 30 seconds")
-
-                             (loop (+ 1 retry)))
-                           (begin
-                             (log 'DEBUG "upload not yet completed, giving up waiting")
-
-                             (raise-exception
-                              (make-exception-with-message "upload not completed"))))))))
-
-             (begin
-               (if bytes
-                   (log 'DEBUG "still more to send (bytes: " file-size
-                        ", partial upload bytes: " bytes ")")
-                   (begin
-                     (log 'DEBUG "starting sending file from start")
-                     (set! %force-full-upload #f)
-                     (progress-reporter-report! reporter 'reset)))
-
-               ;; Still more to send
-               (call-with-input-file file
-                 (lambda (file-port)
-                   (when bytes
-                     (seek file-port bytes SEEK_SET)
-                     (log 'INFO "resuming upload from byte " bytes))
-
-                   (let* ((upload-uri
-                           (coordinator-uri-for-path
-                            (slot-ref interface 'coordinator-uri)
-                            (string-append "/build/" build-id "/output/" output-name
-                                           (if (integer? bytes)
-                                               "/partial"
-                                               ""))))
-                          (bytes-to-send
-                           (if bytes
-                               (- file-size bytes)
-                               file-size))
-                          (response
-                           body
-                           (call-with-streaming-http-request
-                            upload-uri
-                            bytes-to-send
-                            (lambda (port)
-                              (with-time-logging
-                                  (simple-format #f "sending ~A" file)
-                                (dump-port* file-port port
-                                            #:reporter reporter)))
-                            #:headers `((Authorization . ,auth-value))
-                            #:method (if bytes 'POST 'PUT))))
-
-                     (log 'DEBUG "perform upload " file ", response code: "
-                          (response-code response))
-
-                     (when (>= (response-code response) 400)
-                       (raise-exception
-                        (make-exception-with-message
-                         (coordinator-handle-failed-request
-                          log
-                          'PUT
-                          (uri-path upload-uri)
-                          response
-                          body))))))
-                 #:binary #t)))))
+             (log 'DEBUG "perform upload: server has all the bytes"
+                  " (partial-upload-bytes: " partial-upload-bytes
+                  ",completed-upload-bytes: " completed-upload-bytes ")")
+             (if bytes
+                 (log 'DEBUG "still more to send (bytes: " file-size
+                      ", partial upload bytes: " bytes ")")
+                 (begin
+                   (log 'DEBUG "starting sending file from start")
+                   (set! %force-full-upload #f)
+                   (progress-reporter-report! reporter 'reset))))
+
+         (let* ((bytes-to-send
+                 (if bytes
+                     (- file-size bytes)
+                     file-size))
+                (response
+                 body
+                 (call-with-streaming-http-request
+                  upload-uri
+                  bytes-to-send
+                  (lambda (port)
+                    (when (> bytes-to-send 0)
+                      (call-with-input-file file
+                        (lambda (file-port)
+                          (when bytes
+                            (seek file-port bytes SEEK_SET)
+                            (log 'INFO "resuming upload from byte " bytes))
+
+                          (with-time-logging
+                              (simple-format #f "sending ~A" file)
+                            (dump-port* file-port port
+                                        #:reporter reporter)))
+                        #:binary #t)))
+                  #:headers `((Authorization . ,auth-value))
+                  #:method (if bytes 'POST 'PUT))))
+
+           (log 'DEBUG "perform upload " file ", response code: "
+                (response-code response))
+
+           (when (>= (response-code response) 400)
+             (raise-exception
+              (make-exception-with-message
+               (coordinator-handle-failed-request
+                log
+                'PUT
+                (uri-path upload-uri)
+                response
+                body)))))))
 
      (unless (and=>
               (get-completed-upload-bytes)
@@ -415,7 +395,7 @@
                 (= uploaded-bytes file-size)))
        (retry-on-error perform-upload
                        #:times 100
-                       #:delay 15
+                       #:delay 60
                        #:error-hook
                        (lambda _
                          (log 'DEBUG