Enable recompressing nars in the publish hook

The implementation is intended to be generic, but the new default behaviour
either keeps the lzip compressed nar, or if the compressed nar isn't much
smaller than the compressed one, decompresses it.

This also changes the API for the post-publish-hook and
combined-post-publish-hook, since they now get called with a list of narinfos,
rather than a list of narinfos and files.

1 files changed, 108 insertions, 27 deletions

diff --git a/guix-build-coordinator/hooks.scm b/guix-build-coordinator/hooks.scm
index bc055c2..50c2445 100644
--- a/guix-build-coordinator/hooks.scm
+++ b/guix-build-coordinator/hooks.scm
@@ -32,7 +32,8 @@
   #:use-module (guix config)
   #:use-module (guix derivations)
   #:use-module (guix serialization)
-  #:use-module ((guix utils) #:select (default-keyword-arguments))
+  #:use-module ((guix utils) #:select (default-keyword-arguments
+                                        call-with-decompressed-port))
   #:use-module (guix build utils)
   #:use-module (guix-build-coordinator config)
   #:use-module (guix-build-coordinator utils)
@@ -81,6 +82,20 @@
                     build-id agent-id)
      (current-error-port))))
 
+(define* (default-nar-compressions #:key output-filename nar-size
+           source-compression source-size)
+  (define MiB (* (expt 2 20) 1.))
+
+  (if (eq? 'none source-compression)
+      ;; If the agent didn't compress the nar, don't change that here
+      (list 'none)
+      (let* ((compression-proportion
+              (/ source-size nar-size)))
+    (if (or (> compression-proportion 0.95)
+            (< nar-size (* 0.5 MiB)))
+        '(none)
+        (list source-compression)))))
+
 (define* (build-success-publish-hook
           publish-directory
           #:key
@@ -94,7 +109,8 @@
           post-publish-hook
           combined-post-publish-hook
           (publish-referenced-derivation-source-files? #t)
-          derivation-substitute-urls)
+          derivation-substitute-urls
+          (nar-compressions-proc default-nar-compressions))
   (mkdir-p (string-append publish-directory "/nar/lzip"))
 
   (lambda (build-coordinator build-id)
@@ -218,8 +234,7 @@
                                                     nar-filename))
                                #:unwind? #t))
 
-                           (cons narinfo-filename
-                                 nar-filename)))))
+                           narinfo-filename))))
                  referenced-source-files))))))
 
     (define (process-output drv-name output)
@@ -230,12 +245,6 @@
              (nar-location
               (build-output-file-location datastore build-id
                                           output-name))
-             (nar-filename
-              (string-append "nar/lzip/"
-                             (basename output-filename)))
-             (nar-destination
-              (string-append publish-directory "/"
-                             nar-filename))
              (narinfo-filename
               (string-append (string-take (basename output-filename) 32)
                              ".narinfo"))
@@ -246,8 +255,72 @@
 
         (if (skip-publishing-proc narinfo-filename narinfo-directory)
             #f
-            (begin
-              (copy-file nar-location nar-destination)
+            (let ((compressions
+                   (nar-compressions-proc
+                    #:output-filename output-filename
+                    #:nar-size (assq-ref output 'size)
+                    ;; TODO Don't hardcode this
+                    #:source-compression 'lzip
+                    #:source-size (stat:size (stat nar-location #f)))))
+
+              (for-each
+               (lambda (compression)
+                 (if (or (and (pair? compression)
+                              (eq? (car compression) 'lzip))
+                         (eq? compression 'lzip))
+                     ;; TODO If the agents start uploading uncompressed files
+                     ;; or files compressed differently, this might not be
+                     ;; right
+                     (let ((nar-destination
+                            (string-append publish-directory "/"
+                                           "nar/lzip/"
+                                           (basename output-filename))))
+                       (copy-file nar-location nar-destination))
+                     (let* ((target-compression
+                             (if (pair? compression)
+                                 (car compression)
+                                 compression))
+                            (nar-destination
+                             (string-append
+                              publish-directory "/"
+                              "nar/" (symbol->string target-compression) "/"
+                              (basename output-filename)))
+                            (temporary-destination
+                             (string-append nar-destination ".tmp")))
+                       (mkdir-p (dirname temporary-destination))
+                       (call-with-input-file nar-location
+                         (lambda (source-port)
+                           (call-with-decompressed-port
+                               ;; TODO Don't assume the source compression
+                               'lzip
+                               source-port
+                             (lambda (decompressed-source-port)
+                               (let ((call-with-compressed-output-port*
+                                      (match target-compression
+                                        ('gzip
+                                         (@ (zlib) call-with-gzip-output-port))
+                                        ('lzip
+                                         (@ (lzlib) call-with-lzip-output-port))
+                                        ('zstd
+                                         (@ (zstd) call-with-zstd-output-port))
+                                        ('none
+                                         (lambda (port proc)
+                                           (proc port))))))
+                                 (when (file-exists? temporary-destination)
+                                   (delete-file temporary-destination))
+                                 (apply
+                                  call-with-compressed-output-port*
+                                  (open-output-file temporary-destination
+                                                    #:binary #t)
+                                  (lambda (compressed-port)
+                                    (dump-port decompressed-source-port
+                                               compressed-port))
+                                  (if (pair? compression)
+                                      (cdr compression)
+                                      '())))))))
+                       (rename-file temporary-destination
+                                    nar-destination))))
+               compressions)
 
               (call-with-output-file narinfo-location
                 (lambda (port)
@@ -257,7 +330,18 @@
                             (assq-ref output 'size)
                             (vector->list
                              (assq-ref output 'references))
-                            `((lzip ,(stat:size (stat nar-location #f))))
+                            (map
+                             (lambda (compression-details)
+                               (let* ((compression
+                                      (if (pair? compression-details)
+                                          (car compression-details)
+                                          compression-details))
+                                      (file (string-append
+                                             publish-directory "/"
+                                             "nar/" (symbol->string compression) "/"
+                                             (basename output-filename))))
+                                 (list compression (stat:size (stat file #f)))))
+                             compressions)
                             #:system (datastore-find-derivation-system
                                       datastore
                                       drv-name)
@@ -276,18 +360,16 @@
                       (raise-exception exn))
                   (lambda ()
                     (post-publish-hook publish-directory
-                                       narinfo-filename
-                                       nar-filename))
+                                       narinfo-filename))
                   #:unwind? #t))
 
-              (cons narinfo-filename
-                    nar-filename)))))
+              narinfo-filename))))
 
     (let* ((build-details
             (datastore-find-build datastore build-id))
            (drv-name
             (assq-ref build-details 'derivation-name))
-           (narinfos-and-nars
+           (narinfos
             (append
              (if publish-referenced-derivation-source-files?
                  (process-referenced-derivation-source-files drv-name)
@@ -297,23 +379,22 @@
                 (process-output drv-name output))
               (datastore-list-build-outputs datastore build-id)))))
       (when (and combined-post-publish-hook
-                 (not (null? narinfos-and-nars)))
+                 (not (null? narinfos)))
         (with-exception-handler
             (lambda (exn)
               ;; Rollback narinfo creation, to make this more
               ;; transactional
               (for-each
-               (match-lambda
-                 ((narinfo-filename . _)
-                  (delete-file
-                   (string-append
-                    narinfo-directory "/" narinfo-filename))))
-               narinfos-and-nars)
+               (lambda
+                 (narinfo-filename)
+                 (delete-file
+                  (string-append
+                   narinfo-directory "/" narinfo-filename)))
+               narinfos)
 
               (raise-exception exn))
           (lambda ()
-            (combined-post-publish-hook publish-directory
-                                        narinfos-and-nars))
+            (combined-post-publish-hook publish-directory narinfos))
           #:unwind? #t)))))
 
 (define* (build-success-s3-publish-hook