From 0e23d9116342bcf6f5c361a2ef0991b8a4edd509 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Fri, 7 Jul 2023 09:39:16 +0100 Subject: Improve the build-success-publish-hook for referenced source files Previously it would always connect to the store and substitute the derivation if necessary. Now it checks first to see if there are some references from the outputs that aren't from the inputs, and if that's the case, it goes on to check if these are source files that need publishing. --- guix-build-coordinator/hooks.scm | 197 +++++++++++++++++++++------------------ 1 file changed, 107 insertions(+), 90 deletions(-) diff --git a/guix-build-coordinator/hooks.scm b/guix-build-coordinator/hooks.scm index 6ba0c20..ae5fd62 100644 --- a/guix-build-coordinator/hooks.scm +++ b/guix-build-coordinator/hooks.scm @@ -102,99 +102,116 @@ (build-coordinator-datastore build-coordinator)) (define (process-referenced-derivation-source-files drv-name) - (with-store store - (unless (valid-path? store drv-name) - (set-store-connection-timeout store) - - ;; TODO This isn't ideal as it can be blocked by GC - (substitute-derivation drv-name - #:substitute-urls - derivation-substitute-urls)) - - (let* ((drv (read-derivation-from-file drv-name)) - (drv-sources - (derivation-sources drv)) - (referenced-source-files - (delete-duplicates - (append-map - (lambda (output) - (let ((refs - (or (and=> (assq-ref output 'references) - vector->list) - '()))) - + (let* ((build-outputs + (datastore-list-build-outputs datastore build-id)) + (derivation-inputs + (datastore-find-derivation-inputs datastore drv-name)) + (potential-referenced-source-files + ;; Just subtract the inputs from the output references + (lset-difference + string=? + (delete-duplicates + (append-map (lambda (output) + ;; References don't include the store path + (or (and=> (assq-ref output 'references) + vector->list) + '())) + build-outputs) + string=?) + (map (lambda (input) + (basename (assq-ref input 'output))) + derivation-inputs)))) + + (if (null? potential-referenced-source-files) + '() + (with-store store + (unless (valid-path? store drv-name) + (set-store-connection-timeout store #:timeout 20) + + ;; TODO This isn't ideal as it can be blocked by GC + (substitute-derivation drv-name + #:substitute-urls + derivation-substitute-urls) + (add-temp-root store drv-name)) + + (let* ((drv (read-derivation-from-file drv-name)) + (drv-sources + (derivation-sources drv)) + (referenced-source-files (filter (lambda (source) - (member (basename source) refs)) + (if (member (basename source) + potential-referenced-source-files) + source + #f)) drv-sources))) - (datastore-list-build-outputs datastore build-id))))) - - (filter-map - (lambda (source-filename) - (let* ((nar-filename - (string-append "nar/lzip/" - (basename source-filename))) - (nar-destination - (string-append publish-directory "/" - nar-filename)) - (tmp-nar-destination - (string-append publish-directory "/" - nar-filename - ".tmp")) - (narinfo-filename - (string-append (string-take (basename source-filename) 32) - ".narinfo")) - - (narinfo-location - (string-append narinfo-directory "/" - narinfo-filename)) - (path-info - (query-path-info store source-filename))) - - (if (skip-publishing-proc narinfo-filename narinfo-directory) - #f - (begin - (call-with-output-file tmp-nar-destination - (lambda (out) - (call-with-lzip-output-port out - (lambda (port) - (write-file source-filename port)) - #:level 9))) - - (rename-file tmp-nar-destination nar-destination) - - (call-with-output-file narinfo-location - (lambda (port) - (display (narinfo-string - source-filename - (bytevector->nix-base32-string - (path-info-hash path-info)) - (path-info-nar-size path-info) - (map basename - (path-info-references - path-info)) - `((lzip ,(stat:size (stat nar-destination #f)))) - #:public-key public-key - #:private-key private-key) - port))) - - (when post-publish-hook - (with-exception-handler - (lambda (exn) - ;; Rollback narinfo creation, to make this more - ;; transactional - (delete-file narinfo-location) - - (raise-exception exn)) - (lambda () - (post-publish-hook publish-directory - narinfo-filename - nar-filename)) - #:unwind? #t)) - - (cons narinfo-filename - nar-filename))))) - referenced-source-files)))) + + (filter-map + (lambda (source-filename) + (let* ((nar-filename + (string-append "nar/lzip/" + (basename source-filename))) + (nar-destination + (string-append publish-directory "/" + nar-filename)) + (tmp-nar-destination + (string-append publish-directory "/" + nar-filename + ".tmp")) + (narinfo-filename + (string-append (string-take (basename source-filename) 32) + ".narinfo")) + + (narinfo-location + (string-append narinfo-directory "/" + narinfo-filename)) + (path-info + (query-path-info store source-filename))) + + (if (skip-publishing-proc narinfo-filename narinfo-directory) + #f + (begin + (call-with-output-file tmp-nar-destination + (lambda (out) + (call-with-lzip-output-port out + (lambda (port) + (write-file source-filename port)) + #:level 9))) + + (rename-file tmp-nar-destination nar-destination) + + (call-with-output-file narinfo-location + (lambda (port) + (display (narinfo-string + source-filename + (bytevector->nix-base32-string + (path-info-hash path-info)) + (path-info-nar-size path-info) + (map basename + (path-info-references + path-info)) + `((lzip ,(stat:size (stat nar-destination #f)))) + #:public-key public-key + #:private-key private-key) + port))) + + (when post-publish-hook + (with-exception-handler + (lambda (exn) + ;; Rollback narinfo creation, to make this more + ;; transactional + (delete-file narinfo-location) + + (raise-exception exn)) + (lambda () + (post-publish-hook publish-directory + narinfo-filename + nar-filename)) + #:unwind? #t)) + + (cons narinfo-filename + nar-filename))))) + referenced-source-files)))))) (define (process-output drv-name output) (let* ((output-name -- cgit v1.2.3