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.

1 files 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