aboutsummaryrefslogtreecommitdiff
path: root/guix-build-coordinator
diff options
context:
space:
mode:
authorChristopher Baines <mail@cbaines.net>2024-05-18 15:32:44 +0100
committerChristopher Baines <mail@cbaines.net>2024-05-19 10:14:43 +0100
commit1ecad692a75402872b7b366859f364a421727925 (patch)
treed28e9ee6f43a9cb90f44220034b76f7ad8856086 /guix-build-coordinator
parentfff0017c42ceb01dd1f53f8e514bab969579b642 (diff)
downloadbuild-coordinator-1ecad692a75402872b7b366859f364a421727925.tar
build-coordinator-1ecad692a75402872b7b366859f364a421727925.tar.gz
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.
Diffstat (limited to 'guix-build-coordinator')
-rw-r--r--guix-build-coordinator/hooks.scm135
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