Compress outputs outside of the upload slot

So that the only thing taking place in the upload slot, is the actual upload,
which should improve throughput.

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