diff options
| -rw-r--r-- | guix-build-coordinator/agent-messaging/http.scm | 136 |
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 |