From c72d2a172fafa591da3b73274ed70723d5fbf360 Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Wed, 17 Feb 2021 09:12:50 +0000
Subject: Add a hook for determining whether agents should submit outputs

This should make it possible to check properly whether the outputs are needed,
instead of just assuming they are not if there's been a successful build.
---
 guix-build-coordinator/coordinator.scm | 29 ++++++++++++++++++++---------
 guix-build-coordinator/hooks.scm       | 14 +++++++++++++-
 2 files changed, 33 insertions(+), 10 deletions(-)

(limited to 'guix-build-coordinator')

diff --git a/guix-build-coordinator/coordinator.scm b/guix-build-coordinator/coordinator.scm
index c66b9fe..2768a1a 100644
--- a/guix-build-coordinator/coordinator.scm
+++ b/guix-build-coordinator/coordinator.scm
@@ -58,6 +58,8 @@
             build-coordinator-allocation-strategy
             build-coordinator-logger
 
+            %known-hooks
+
             %default-agent-uri
             %default-client-uri
             perform-coordinator-service-startup
@@ -105,7 +107,8 @@
     build-success
     build-failure
     build-canceled
-    build-missing-inputs))
+    build-missing-inputs
+    build-submit-outputs))
 
 (define* (make-build-coordinator #:key datastore hooks
                                  (metrics-registry (make-metrics-registry
@@ -635,6 +638,10 @@
                 (loop (cons build-details builds))
                 builds)))))
 
+  (define build-submit-outputs-hook
+    (assq-ref (build-coordinator-hooks build-coordinator)
+              'build-submit-outputs))
+
   (define builds
     (call-with-duration-metric
      (build-coordinator-metrics-registry build-coordinator)
@@ -692,18 +699,22 @@
         #:duration-metric-name "allocate_builds_to_agent"))))
 
   (map (lambda (build)
-         (define unbuilt-outputs
-           (datastore-list-unbuilt-derivation-outputs
-            datastore
-            (assq-ref build 'derivation-name)))
-
-         (define any-unbuilt-outputs?
-           (not (null? unbuilt-outputs)))
+         (define submit-outputs?
+           (let ((hook-result (build-submit-outputs-hook build-coordinator
+                                                         (assq-ref build 'uuid))))
+             (if (boolean? hook-result)
+                 hook-result
+                 (begin
+                   (log-msg (build-coordinator-logger build-coordinator)
+                            'CRITICAL
+                            "build-submit-outputs hook returned non boolean: "
+                            hook-result)
+                   #t))))
 
          `(,@build
            ;; TODO This needs reconsidering when things having been built in
            ;; the past doesn't necessarily mean they're still available.
-           (submit_outputs . ,any-unbuilt-outputs?)))
+           (submit_outputs . ,submit-outputs?)))
        builds))
 
 (define (agent-details datastore agent-id)
diff --git a/guix-build-coordinator/hooks.scm b/guix-build-coordinator/hooks.scm
index a31b804..263d783 100644
--- a/guix-build-coordinator/hooks.scm
+++ b/guix-build-coordinator/hooks.scm
@@ -43,6 +43,7 @@
             build-failure-retry-hook
             build-recompress-log-file-hook
             default-build-missing-inputs-hook
+            default-build-submit-outputs-hook
 
             %default-hooks
 
@@ -416,13 +417,24 @@
                                        missing-input)))))
               missing-inputs)))
 
+(define (default-build-submit-outputs-hook build-coordinator build-id)
+  (define datastore
+    (build-coordinator-datastore build-coordinator))
+
+  (let* ((build (datastore-find-build datastore build-id))
+         (unbuilt-outputs (datastore-list-unbuilt-derivation-outputs
+                           datastore
+                           (assq-ref build 'derivation-name))))
+    (not (null? unbuilt-outputs))))
+
 (define %default-hooks
   `((build-submitted      . ,default-build-submitted-hook)
     (build-started        . ,default-build-started-hook)
     (build-success        . ,default-build-success-hook)
     (build-failure        . ,default-build-failure-hook)
     (build-canceled       . ,default-build-canceled-hook)
-    (build-missing-inputs . ,default-build-missing-inputs-hook)))
+    (build-missing-inputs . ,default-build-missing-inputs-hook)
+    (build-submit-outputs . ,default-build-submit-outputs-hook)))
 
 (define (build-submitted-send-event-to-guix-data-service-hook target-url)
   (lambda (build-coordinator build-id)
-- 
cgit v1.2.3