Query for outputs when build events arrive

This will keep the substitute information more up to date.

3 files changed, 103 insertions, 3 deletions

diff --git a/guix-data-service/model/build.scm b/guix-data-service/model/build.scm
index 4f347f5..ea4ce65 100644
--- a/guix-data-service/model/build.scm
+++ b/guix-data-service/model/build.scm
@@ -26,6 +26,7 @@
   #:use-module (guix-data-service model derivation)
   #:use-module (guix-data-service model system)
   #:export (select-build-stats
+            select-build-outputs
             select-builds-with-context
             select-builds-with-context-by-derivation-file-name
             select-builds-with-context-by-derivation-output
@@ -121,6 +122,40 @@ ORDER BY status"))
                            ((sql . value) value))
                          (filter pair? criteria))))))
 
+(define (select-build-outputs conn build-id)
+  (match (exec-query
+          conn
+          "
+SELECT derivation_file_name, derivation_output_details_set_id
+FROM builds
+WHERE builds.id = $1"
+          (list (number->string build-id)))
+    (((derivation-file-name output-details-set-id))
+
+     (if output-details-set-id
+         (exec-query
+          conn
+          "
+SELECT derivation_output_details.path
+FROM derivation_output_details
+INNER JOIN derivation_output_details_sets
+  ON ARRAY[derivation_output_details.id] &&
+       derivation_output_details_sets.derivation_output_details_ids
+WHERE derivation_output_details_sets.id = $1"
+          (list output-details-set-id))
+         (exec-query
+          conn
+          "
+SELECT derivation_output_details.path
+FROM derivations
+INNER JOIN derivation_outputs
+  ON derivations.id = derivation_outputs.derivation_id
+INNER JOIN derivation_output_details
+  ON derivation_outputs.derivation_output_details_id
+      = derivation_output_details.id
+WHERE derivations.file_name = $1"
+          (list derivation-file-name))))))
+
 (define* (select-builds-with-context conn build-statuses build-server-ids
                                      #:key revision-commit
                                      system target
diff --git a/guix-data-service/substitutes.scm b/guix-data-service/substitutes.scm
index d0e0a6a..335d3f3 100644
--- a/guix-data-service/substitutes.scm
+++ b/guix-data-service/substitutes.scm
@@ -20,16 +20,21 @@
   #:use-module (srfi srfi-19)
   #:use-module (ice-9 match)
   #:use-module (ice-9 threads)
+  #:use-module (fibers)
+  #:use-module (fibers channels)
   #:use-module (guix substitutes)
   #:use-module (guix narinfo)
   #:use-module (guix-data-service utils)
   #:use-module (guix-data-service database)
+  #:use-module (guix-data-service model build)
   #:use-module (guix-data-service model build-server)
   #:use-module (guix-data-service model git-branch)
   #:use-module (guix-data-service model git-repository)
   #:use-module (guix-data-service model nar)
   #:export (query-build-server-substitutes
-            start-substitute-query-thread))
+            start-substitute-query-threads
+
+            request-query-of-build-server-substitutes))
 
 (define verbose-output?
   (make-parameter #f))
@@ -130,7 +135,63 @@
                 total-requested
                 total-narinfos))))))
 
-(define (start-substitute-query-thread)
+(define %substitute-query-channel #f)
+
+(define (request-query-of-build-server-substitutes build-server-id
+                                                   build-ids)
+  (spawn-fiber
+   (lambda ()
+     (and=> %substitute-query-channel
+            (lambda (channel)
+              (put-message channel (cons build-server-id build-ids)))))))
+
+(define (start-substitute-query-threads)
+  (define channel
+    (make-channel))
+
+  (set! %substitute-query-channel channel)
+
+  (call-with-new-thread
+   (lambda ()
+     (while #t
+       (with-exception-handler
+           (lambda (exn)
+             (simple-format
+              (current-error-port)
+              "exception in request substitute query thread: ~A\n"
+              exn))
+         (lambda ()
+           (with-throw-handler #t
+             (lambda ()
+               (with-postgresql-connection
+                "request-substitute-query-thread"
+                (lambda (conn)
+                  (while #t
+                    (match (get-message channel)
+                      ((build-server-id . build-ids)
+
+                       (let ((outputs
+                              (delete-duplicates!
+                               (append-map!
+                                (lambda (build-id)
+                                  (select-build-outputs conn build-id))
+                                build-ids))))
+
+                         (simple-format
+                          (current-output-port)
+                          "querying for ~A outputs from build server ~A\n"
+                          (length outputs)
+                          build-server-id)
+
+                         (query-build-server-substitutes
+                          conn
+                          (list build-server-id)
+                          #f
+                          outputs))))))))
+             (lambda _
+               (backtrace))))
+         #:unwind? #t))))
+
   (call-with-new-thread
    (lambda ()
      (while #t
diff --git a/guix-data-service/web/build-server/controller.scm b/guix-data-service/web/build-server/controller.scm
index babf59d..7c31cf1 100644
--- a/guix-data-service/web/build-server/controller.scm
+++ b/guix-data-service/web/build-server/controller.scm
@@ -23,6 +23,7 @@
   #:use-module (fibers)
   #:use-module (guix-data-service utils)
   #:use-module (guix-data-service database)
+  #:use-module (guix-data-service substitutes)
   #:use-module (guix-data-service web render)
   #:use-module (guix-data-service web query-parameters)
   #:use-module (guix-data-service jobs load-new-guix-revision)
@@ -233,7 +234,10 @@
        (lambda (ids)
          (call-via-thread-pool-channel
           (lambda (conn)
-            (handle-removing-blocking-build-entries-for-successful-builds conn ids)))))
+            (handle-removing-blocking-build-entries-for-successful-builds conn ids)))
+
+         (request-query-of-build-server-substitutes build-server-id
+                                                    ids)))
 
       (with-build-ids-for-status
        items