Do less work when fetching builds

Don't necessarily use a transaction if there are no allocation plan builds,
and only run the submit-outputs hook once and store the values, rather than
running it each time for each fetch builds request for every allocated build.

11 files changed, 199 insertions, 101 deletions

diff --git a/guix-build-coordinator/agent-messaging/http/server.scm b/guix-build-coordinator/agent-messaging/http/server.scm
index 5d55f0b..ca1f11b 100644
--- a/guix-build-coordinator/agent-messaging/http/server.scm
+++ b/guix-build-coordinator/agent-messaging/http/server.scm
@@ -707,14 +707,11 @@ INTERVAL (a time-duration object), otherwise does nothing and returns #f."
       (('POST "agent" uuid "fetch-builds")
        (if (authenticated? uuid request)
            (let* ((json-body (json-string->scm (utf8->string body)))
-                  ;; count is deprecated, use target_count instead
-                  (count (assoc-ref json-body "count"))
                   (target-count (assoc-ref json-body "target_count"))
                   (systems (assoc-ref json-body "systems"))
                   (builds (fetch-builds build-coordinator uuid
                                         (vector->list systems)
-                                        target-count
-                                        count)))
+                                        target-count)))
              (render-json
               `((builds . ,(list->vector builds)))))
            (render-json
diff --git a/guix-build-coordinator/coordinator.scm b/guix-build-coordinator/coordinator.scm
index db19f08..f017514 100644
--- a/guix-build-coordinator/coordinator.scm
+++ b/guix-build-coordinator/coordinator.scm
@@ -1333,6 +1333,11 @@
                  (list 'stats reply))
     (get-message reply)))
 
+(define (build-coordinator-count-allocation-plan-builds coordinator agent-id)
+  (or (assoc-ref (build-coordinator-allocation-plan-stats coordinator)
+                 agent-id)
+      0))
+
 (define (build-coordinator-fetch-agent-allocation-plan coordinator agent-id)
   (let ((reply (make-channel)))
     (put-message (build-coordinator-allocator-channel coordinator)
@@ -1736,8 +1741,7 @@
                                               handler)))))
    (build-coordinator-hooks build-coordinator)))
 
-(define (fetch-builds build-coordinator agent systems
-                      max-builds deprecated-requested-count)
+(define (fetch-builds build-coordinator agent systems max-builds)
   (define datastore
     (build-coordinator-datastore build-coordinator))
 
@@ -1746,10 +1750,16 @@
                           build-coordinator agent-id)))
       (if build-details
           (let ((build-id (assq-ref build-details 'uuid)))
-            (datastore-insert-to-allocated-builds datastore agent-id (list build-id))
+            (datastore-insert-to-allocated-builds
+             datastore
+             agent-id
+             build-id
+             ;; This is updated later, outside the transaction
+             'null)
             (build-coordinator-remove-build-from-allocation-plan
              build-coordinator build-id)
-            build-details)
+            `(,@build-details
+              (submit_outputs . null)))
           #f)))
 
   (define (allocate-several-builds agent-id count)
@@ -1773,30 +1783,74 @@
                (datastore-list-agent-builds datastore agent))
               (start-count
                (length initially-allocated-builds))
-              (target-count (or max-builds
-                                (+ start-count
-                                   deprecated-requested-count))))
+              (target-count max-builds))
          (if (< start-count target-count)
              (let ((new-builds
                     (allocate-several-builds agent
                                              (- target-count start-count))))
-               ;; Previously allocate builds just returned newly allocated
-               ;; builds, but if max-builds is provided, return all the
-               ;; builds. This means the agent can handle this in a idempotent
-               ;; manor.
-               (if max-builds
-                   (append initially-allocated-builds
-                           new-builds)
-                   new-builds))
-             ;; Previously allocate builds just returned newly allocated builds,
-             ;; but if max-builds is provided, return all the builds. This means
-             ;; the agent can handle this in a idempotent manor.
-             (if max-builds
-                 initially-allocated-builds
-                 '()))))
+               (if (null? new-builds)
+                   (values initially-allocated-builds
+                           #f)
+                   (values (append initially-allocated-builds
+                                   new-builds)
+                           #t)))
+             (values initially-allocated-builds
+                     #f))))
      #:duration-metric-name "allocate_builds_to_agent"
      #:duration-metric-buckets %command-duration-histogram-buckets))
 
+  (define (send-agent-builds-allocated-event builds)
+    (build-coordinator-send-event
+     build-coordinator
+     "agent-builds-allocated"
+     `((agent_id . ,agent)
+       (builds   . ,(list->vector
+                     (map
+                      (lambda (build)
+                        `(,@build
+                          (tags
+                           . ,(list->vector
+                               (map
+                                (match-lambda
+                                  ((key . value)
+                                   `((key   . ,key)
+                                     (value . ,value))))
+                                (vector->list
+                                 (datastore-fetch-build-tags
+                                  datastore
+                                  (assq-ref build 'uuid))))))))
+                      builds))))))
+
+  (define (submit-outputs? build)
+    (with-exception-handler
+        (lambda (exn)
+          (log-msg (build-coordinator-logger build-coordinator)
+                   'CRITICAL
+                   "build-submit-outputs hook raised exception: "
+                   exn))
+      (lambda ()
+        (with-exception-handler
+            (lambda (exn)
+              (backtrace)
+              (raise-exception exn))
+          (lambda ()
+            (let ((hook-result
+                   (call-with-delay-logging
+                    (lambda ()
+                      (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))))))
+      #:unwind? #t))
+
   (call-with-duration-metric
    (build-coordinator-metrics-registry build-coordinator)
    "coordinator_fetch_builds_duration_seconds"
@@ -1811,65 +1865,31 @@
             (trigger-build-allocation build-coordinator)))
 
         (let ((builds
-               (get-builds)))
+               new-builds-allocated?
+               (if (= 0
+                      (build-coordinator-count-allocation-plan-builds
+                       build-coordinator
+                       agent))
+                   (values
+                    (datastore-list-agent-builds datastore agent)
+                    #f)
+                   (get-builds))))
 
-          (build-coordinator-send-event
-           build-coordinator
-           "agent-builds-allocated"
-           `((agent_id . ,agent)
-             (builds   . ,(list->vector
-                           (map
-                            (lambda (build)
-                              `(,@build
-                                (tags
-                                 . ,(list->vector
-                                     (map
-                                      (match-lambda
-                                        ((key . value)
-                                         `((key   . ,key)
-                                           (value . ,value))))
-                                      (vector->list
-                                       (datastore-fetch-build-tags
-                                        datastore
-                                        (assq-ref build 'uuid))))))))
-                            builds)))))
-
-          (fibers-map
+          (when new-builds-allocated?
+            (send-agent-builds-allocated-event builds))
+
+          (map
            (lambda (build)
-             (define submit-outputs?
-               (with-exception-handler
-                   (lambda (exn)
-                     (log-msg (build-coordinator-logger build-coordinator)
-                              'CRITICAL
-                              "build-submit-outputs hook raised exception: "
-                              exn))
-                 (lambda ()
-                   (with-exception-handler
-                       (lambda (exn)
-                         (backtrace)
-                         (raise-exception exn))
-                     (lambda ()
-                       (let ((hook-result
-                              (call-with-delay-logging
-                               (lambda ()
-                                 (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))))))
-                 #:unwind? #t))
-
-             `(,@build
-               ;; TODO This needs reconsidering when things having been built in
-               ;; the past doesn't necessarily mean they're still available.
-               (submit_outputs . ,submit-outputs?)))
+             (if (eq? 'null (assq-ref build 'submit_outputs))
+                 (let ((submit-outputs? (submit-outputs? build)))
+                   (datastore-update-allocated-build-submit-outputs
+                    (build-coordinator-datastore build-coordinator)
+                    (assq-ref build 'uuid)
+                    submit-outputs?)
+
+                   `(,@(alist-delete 'submit_outputs build)
+                     (submit_outputs . ,submit-outputs?)))
+                 build))
            builds)))))))
 
 (define (agent-details build-coordinator agent-id)
diff --git a/guix-build-coordinator/datastore.scm b/guix-build-coordinator/datastore.scm
index ae65b7d..5768630 100644
--- a/guix-build-coordinator/datastore.scm
+++ b/guix-build-coordinator/datastore.scm
@@ -93,6 +93,7 @@
 (re-export datastore-fetch-build-to-allocate)
 (re-export datastore-check-if-derivation-conflicts?)
 (re-export datastore-insert-to-allocated-builds)
+(re-export datastore-update-allocated-build-submit-outputs)
 (re-export datastore-insert-background-job)
 (re-export datastore-delete-background-job)
 (re-export datastore-select-background-jobs)
diff --git a/guix-build-coordinator/datastore/sqlite.scm b/guix-build-coordinator/datastore/sqlite.scm
index 53c97e0..71570df 100644
--- a/guix-build-coordinator/datastore/sqlite.scm
+++ b/guix-build-coordinator/datastore/sqlite.scm
@@ -106,6 +106,7 @@
             datastore-fetch-build-to-allocate
             datastore-check-if-derivation-conflicts?
             datastore-insert-to-allocated-builds
+            datastore-update-allocated-build-submit-outputs
             datastore-insert-background-job
             datastore-delete-background-job
             datastore-select-background-jobs
@@ -3516,25 +3517,55 @@ WHERE build_derivation_outputs.derivation_id = :derivation_id
 (define-method (datastore-insert-to-allocated-builds
                 (datastore <sqlite-datastore>)
                 agent-id
-                build-uuids)
+                build-uuid
+                submit-outputs?)
   (call-with-writer-thread
    datastore
    (lambda (db)
-     (sqlite-exec
-      db
-      (string-append
-       "
-INSERT INTO allocated_builds (build_id, agent_id) VALUES "
-       (string-join
-        (map (lambda (build-uuid)
-               (simple-format
-                #f
-                "(~A, '~A')"
-                (db-find-build-id db build-uuid)
-                agent-id))
-             build-uuids)
-        ", ")
-       ";")))))
+     (let ((statement
+            (sqlite-prepare
+             db
+             "
+INSERT INTO allocated_builds (build_id, agent_id, submit_outputs)
+  VALUES (:build_id, :agent_id, :submit_outputs)"
+             #:cache? #t)))
+
+       (sqlite-bind-arguments
+        statement
+        #:build_id (db-find-build-id db build-uuid)
+        #:agent_id agent-id
+        #:submit_outputs
+        (cond
+         ((eq? submit-outputs? 'null) "NULL")
+         ((eq? #f submit-outputs?) 0)
+         ((eq? #t submit-outputs?) 1)
+         (else (error "unknown submit-outputs"))))
+
+       (sqlite-step-and-reset statement))))
+  #t)
+
+(define-method (datastore-update-allocated-build-submit-outputs
+                (datastore <sqlite-datastore>)
+                build-uuid
+                submit-outputs?)
+  (call-with-writer-thread
+   datastore
+   (lambda (db)
+     (let ((statement
+            (sqlite-prepare
+             db
+             "
+UPDATE allocated_builds
+SET submit_outputs = :submit_outputs
+WHERE build_id = :build_id"
+             #:cache? #t)))
+       (sqlite-bind-arguments
+        statement
+        #:build_id (db-find-build-id db build-uuid)
+        #:submit_outputs (if submit-outputs? 1 0))
+
+       (sqlite-step-and-reset statement))))
+  #t)
 
 (define-method (datastore-list-allocation-plan-builds
                 (datastore <sqlite-datastore>)
@@ -3615,7 +3646,7 @@ LIMIT :limit"
              "
 SELECT builds.uuid, derivations.name,
        unprocessed_builds_with_derived_priorities.derived_priority,
-       builds.canceled
+       builds.canceled, allocated_builds.submit_outputs
 FROM builds
 INNER JOIN derivations
   ON builds.derivation_id = derivations.id
@@ -3632,11 +3663,17 @@ WHERE allocated_builds.agent_id = :agent_id"
 
        (let ((builds (sqlite-map
                       (match-lambda
-                        (#(uuid derivation_name derived_priority canceled)
+                        (#(uuid derivation_name derived_priority canceled
+                                submit_outputs)
                          `((uuid             . ,uuid)
                            (derivation_name  . ,derivation_name)
                            (derived_priority . ,derived_priority)
-                           (canceled         . ,(= 1 canceled)))))
+                           (canceled         . ,(= 1 canceled))
+                           (submit_outputs   . ,(cond
+                                                 ((not submit_outputs)
+                                                  'null)
+                                                 (else
+                                                  (= 1 submit_outputs)))))))
                       statement)))
          (sqlite-reset statement)
 
diff --git a/sqitch/pg/deploy/allocated_builds_submit_outputs.sql b/sqitch/pg/deploy/allocated_builds_submit_outputs.sql
new file mode 100644
index 0000000..a2ebe1e
--- /dev/null
+++ b/sqitch/pg/deploy/allocated_builds_submit_outputs.sql
@@ -0,0 +1,7 @@
+-- Deploy guix-build-coordinator:allocated_builds_submit_outputs to pg
+
+BEGIN;
+
+-- XXX Add DDLs here.
+
+COMMIT;
diff --git a/sqitch/pg/revert/allocated_builds_submit_outputs.sql b/sqitch/pg/revert/allocated_builds_submit_outputs.sql
new file mode 100644
index 0000000..255efb1
--- /dev/null
+++ b/sqitch/pg/revert/allocated_builds_submit_outputs.sql
@@ -0,0 +1,7 @@
+-- Revert guix-build-coordinator:allocated_builds_submit_outputs from pg
+
+BEGIN;
+
+-- XXX Add DDLs here.
+
+COMMIT;
diff --git a/sqitch/pg/verify/allocated_builds_submit_outputs.sql b/sqitch/pg/verify/allocated_builds_submit_outputs.sql
new file mode 100644
index 0000000..e95a717
--- /dev/null
+++ b/sqitch/pg/verify/allocated_builds_submit_outputs.sql
@@ -0,0 +1,7 @@
+-- Verify guix-build-coordinator:allocated_builds_submit_outputs on pg
+
+BEGIN;
+
+-- XXX Add verifications here.
+
+ROLLBACK;
diff --git a/sqitch/sqitch.plan b/sqitch/sqitch.plan
index ee9dd7a..f4f538b 100644
--- a/sqitch/sqitch.plan
+++ b/sqitch/sqitch.plan
@@ -48,3 +48,4 @@ system_uptime 2023-05-05T18:18:35Z Chris <chris@felis> # Add system uptime
 build_starts_index 2023-11-24T16:30:13Z Chris <chris@felis> # build_starts index
 background-jobs-queue 2025-02-06T10:49:08Z Chris <chris@fang> # Add background_jobs_queue
 builds_replace_unprocessed_index 2025-02-19T11:19:42Z Chris <chris@fang> # Replace builds_unprocessed
+allocated_builds_submit_outputs 2025-03-02T08:22:48Z Chris <chris@fang> # Add allocated_builds.submit_outputs
diff --git a/sqitch/sqlite/deploy/allocated_builds_submit_outputs.sql b/sqitch/sqlite/deploy/allocated_builds_submit_outputs.sql
new file mode 100644
index 0000000..66d6b45
--- /dev/null
+++ b/sqitch/sqlite/deploy/allocated_builds_submit_outputs.sql
@@ -0,0 +1,7 @@
+-- Deploy guix-build-coordinator:allocated_builds_submit_outputs to sqlite
+
+BEGIN;
+
+ALTER TABLE allocated_builds ADD COLUMN submit_outputs BOOLEAN DEFAULT NULL;
+
+COMMIT;
diff --git a/sqitch/sqlite/revert/allocated_builds_submit_outputs.sql b/sqitch/sqlite/revert/allocated_builds_submit_outputs.sql
new file mode 100644
index 0000000..240de22
--- /dev/null
+++ b/sqitch/sqlite/revert/allocated_builds_submit_outputs.sql
@@ -0,0 +1,7 @@
+-- Revert guix-build-coordinator:allocated_builds_submit_outputs from sqlite
+
+BEGIN;
+
+-- XXX Add DDLs here.
+
+COMMIT;
diff --git a/sqitch/sqlite/verify/allocated_builds_submit_outputs.sql b/sqitch/sqlite/verify/allocated_builds_submit_outputs.sql
new file mode 100644
index 0000000..0b1331e
--- /dev/null
+++ b/sqitch/sqlite/verify/allocated_builds_submit_outputs.sql
@@ -0,0 +1,7 @@
+-- Verify guix-build-coordinator:allocated_builds_submit_outputs on sqlite
+
+BEGIN;
+
+-- XXX Add verifications here.
+
+ROLLBACK;