diff options
-rw-r--r-- | guix-build-coordinator/agent-messaging/http.scm | 94 | ||||
-rw-r--r-- | guix-build-coordinator/agent.scm | 45 |
2 files changed, 74 insertions, 65 deletions
diff --git a/guix-build-coordinator/agent-messaging/http.scm b/guix-build-coordinator/agent-messaging/http.scm index ac45ca3..6f87426 100644 --- a/guix-build-coordinator/agent-messaging/http.scm +++ b/guix-build-coordinator/agent-messaging/http.scm @@ -295,63 +295,45 @@ (string-append "/build/" build-id "/output/" output-name (if resume? "/partial" "")))) - (define path-info - (with-store store - (query-path-info store file))) - (define (perform-upload) - (let* ((directory (or (getenv "TMPDIR") "/tmp")) - (template (string-append directory - "/guix-build-coordinator-file.XXXXXX")) - (out (mkstemp! template))) - (log 'INFO "compressing " file " -> " template " prior to sending") - (call-with-lzip-output-port out - (lambda (port) - (write-file file port)) - #:level 9) - (close-port out) - - (log 'INFO "finished compressing " file ", now sending") - (retry-on-error - (lambda () - (let ((bytes (or (get-partial-upload-bytes) - (get-completed-upload-bytes)))) - ;; Check if the server has all the bytes - (unless (and bytes - (eq? bytes (stat:size (stat template)))) - - ;; Still more to send - (call-with-input-file template - (lambda (file-port) - (when bytes - (seek file-port bytes SEEK_SET) - (log 'INFO "resuming upload from byte " bytes)) - - (let-values (((response body) - (call-with-streaming-http-request - (uri #:resume? (integer? bytes)) - (lambda (port) - (with-time-logging - (simple-format #f "sending ~A" file) - (dump-port file-port port - #:buffer-size 65536))) - #:headers `((Authorization . ,auth-value)) - #:method (if bytes 'POST 'PUT) - #:report-bytes-sent report-bytes-sent))) - (when (>= (response-code response) 400) - (raise-exception - (make-exception-with-message - (coordinator-handle-failed-request - log - 'PUT - (uri-path - (uri #:resume? (integer? bytes))) - response - body)))))))))) - #:times 100 - #:delay (random 15)) - - (delete-file template))) + (retry-on-error + (lambda () + (let ((bytes (or (get-partial-upload-bytes) + (get-completed-upload-bytes)))) + ;; Check if the server has all the bytes + (unless (and bytes + (eq? bytes (stat:size (stat template)))) + + ;; 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-values (((response body) + (call-with-streaming-http-request + (uri #:resume? (integer? bytes)) + (lambda (port) + (with-time-logging + (simple-format #f "sending ~A" file) + (dump-port file-port port + #:buffer-size 65536))) + #:headers `((Authorization . ,auth-value)) + #:method (if bytes 'POST 'PUT) + #:report-bytes-sent report-bytes-sent))) + (when (>= (response-code response) 400) + (raise-exception + (make-exception-with-message + (coordinator-handle-failed-request + log + 'PUT + (uri-path + (uri #:resume? (integer? bytes))) + response + body)))))))))) + #:times 100 + #:delay (random 15))) (unless (get-completed-upload-bytes) (perform-upload))) diff --git a/guix-build-coordinator/agent.scm b/guix-build-coordinator/agent.scm index 1bcbf2f..366666e 100644 --- a/guix-build-coordinator/agent.scm +++ b/guix-build-coordinator/agent.scm @@ -37,9 +37,11 @@ #:use-module (logging logger) #:use-module (logging port-log) #:use-module (prometheus) + #:use-module (lzlib) #:use-module (guix store) #:use-module (guix derivations) #:use-module (guix base32) + #:use-module (guix serialization) #:use-module (guix-build-coordinator utils) #:use-module (guix-build-coordinator agent-messaging) #:use-module (guix-build-coordinator agent-messaging abstract) @@ -756,6 +758,9 @@ but the guix-daemon claims it's unavailable" build-id derivation end-time submit-outputs? with-upload-slot) + (define outputs + (derivation-outputs (read-derivation-from-file derivation))) + (define output-details (map (match-lambda @@ -771,8 +776,27 @@ but the guix-daemon claims it's unavailable" (references . ,(list->vector (map basename (path-info-references path-info)))))))) - - (derivation-outputs (read-derivation-from-file derivation)))) + outputs)) + + (define compressed-outputs + (map (match-lambda + ((output-name . output) + (let* ((file (derivation-output-path output)) + (directory (or (getenv "TMPDIR") "/tmp")) + (template (string-append directory + "/guix-build-coordinator-file.XXXXXX")) + (out (mkstemp! template))) + (log-msg lgr 'INFO "compressing " file " -> " template " prior to sending") + (call-with-lzip-output-port out + (lambda (port) + (write-file file port)) + #:level 9) + (close-port out) + + (log-msg lgr 'INFO "finished compressing " file) + + (cons output-name template)))) + outputs)) (define (attempt-submit-build-result) (with-exception-handler @@ -815,8 +839,7 @@ but the guix-daemon claims it's unavailable" (if (string=? name missing-output-name) output #f))) - (derivation-outputs - (read-derivation-from-file derivation))))) + outputs))) (unless missing-output (raise-exception (make-exception @@ -826,7 +849,9 @@ but the guix-daemon claims it's unavailable" missing-output-name)))) (submit-one-output missing-output-name - missing-output)) + missing-output + (assoc-ref compressed-outputs + missing-output-name))) (attempt-submit-build-result))) (raise-exception @@ -845,7 +870,7 @@ but the guix-daemon claims it's unavailable" #:log (build-log-procedure lgr build-id))) #:unwind? #t)) - (define (submit-one-output output-name output) + (define (submit-one-output output-name output compressed-file) (retry-on-error (lambda () (with-upload-slot @@ -857,7 +882,7 @@ but the guix-daemon claims it's unavailable" (derivation-output-path output)) (submit-output coordinator-interface build-id output-name - (derivation-output-path output) + compressed-file #:log (build-log-procedure lgr build-id) #:report-bytes-sent report-bytes-sent)))) #:times 48 @@ -868,8 +893,10 @@ but the guix-daemon claims it's unavailable" (log-msg lgr 'INFO build-id ": build successful, submitting outputs") (for-each (match-lambda ((output-name . output) - (submit-one-output output-name output))) - (derivation-outputs (read-derivation-from-file derivation))) + (submit-one-output output-name + output + (assoc-ref compressed-outputs output-name)))) + outputs) (log-msg lgr 'INFO build-id ": finished submitting outputs, reporting build success")) (begin |