Support publishing referenced source files

Build outputs can reference derivation source files. This change to the
publish hook enables publishing these referenced source files.

1 files changed, 95 insertions, 1 deletions

diff --git a/guix-build-coordinator/hooks.scm b/guix-build-coordinator/hooks.scm
index 5163a5d..a9a6850 100644
--- a/guix-build-coordinator/hooks.scm
+++ b/guix-build-coordinator/hooks.scm
@@ -25,8 +25,13 @@
   #:use-module (ice-9 exceptions)
   #:use-module (gcrypt pk-crypto)
   #:use-module (zlib)
+  #:use-module (lzlib)
   #:use-module (guix pki)
+  #:use-module (guix store)
+  #:use-module (guix base32)
   #:use-module (guix config)
+  #:use-module (guix derivations)
+  #:use-module (guix serialization)
   #:use-module ((guix utils) #:select (default-keyword-arguments))
   #:use-module (guix build utils)
   #:use-module (guix-build-coordinator config)
@@ -86,7 +91,9 @@
            (lambda (narinfo-filename narinfo-directory)
              (file-exists? (string-append
                             narinfo-directory "/" narinfo-filename))))
-          post-publish-hook)
+          post-publish-hook
+          (publish-referenced-derivation-source-files? #t)
+          derivation-substitute-urls)
   (mkdir-p (string-append publish-directory "/nar/lzip"))
 
   (lambda (build-coordinator build-id)
@@ -97,6 +104,93 @@
             (datastore-find-build datastore build-id))
            (derivation-name
             (assq-ref build-details 'derivation-name)))
+      (when publish-referenced-derivation-source-files?
+        (with-store store
+          (unless (valid-path? store derivation-name)
+            (substitute-derivation derivation-name
+                                   #:substitute-urls
+                                   derivation-substitute-urls))
+
+          (let* ((drv (read-derivation-from-file derivation-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)
+                                 '())))
+
+                        (filter
+                         (lambda (source)
+                           (member (basename source) refs))
+                         drv-sources)))
+                    (datastore-list-build-outputs datastore build-id)))))
+
+            (for-each
+             (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)))
+
+                 (unless (skip-publishing-proc narinfo-filename narinfo-directory)
+                   (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 source-filename #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)))))
+             referenced-source-files))))
+
       (for-each
        (lambda (output)
          (let* ((output-name