Improve listing agent build allocation plans

2 files changed, 57 insertions, 30 deletions

diff --git a/guix-build-coordinator/client-communication.scm b/guix-build-coordinator/client-communication.scm
index 9c13e76..aa5d9f0 100644
--- a/guix-build-coordinator/client-communication.scm
+++ b/guix-build-coordinator/client-communication.scm
@@ -50,6 +50,7 @@
             request-builds-list
             request-output-details
             request-agent-details
+            request-agent-build-allocation-plan
             request-agents-list
             request-failed-builds-with-blocking-count-list
             send-create-agent-request
@@ -253,12 +254,15 @@
             (allocated_builds      . ,(list->vector
                                        (datastore-list-agent-builds
                                         datastore
-                                        agent-id)))
-            (build_allocation_plan . ,(list->vector
-                                       (datastore-list-allocation-plan-builds
-                                        datastore
-                                        agent-id
-                                        2048))))))) ; TODO Do something with this
+                                        agent-id)))))))
+      (('GET "agent" agent-id "build_allocation_plan")
+       (let ((agent-details (datastore-find-agent datastore agent-id)))
+         (render-json
+          `((build_allocation_plan
+             . ,(list->vector
+                 (datastore-list-allocation-plan-builds
+                  datastore
+                  agent-id)))))))
       (('POST "agent" agent-id "passwords")
        (let ((password (new-agent-password
                         datastore
@@ -682,6 +686,11 @@
                 'GET
                 (string-append "/agent/" agent-id)))
 
+(define (request-agent-build-allocation-plan coordinator-uri agent-id)
+  (send-request coordinator-uri
+                'GET
+                (string-append "/agent/" agent-id "/build_allocation_plan")))
+
 (define (request-agents-list coordinator-uri)
   (send-request coordinator-uri
                 'GET
diff --git a/guix-build-coordinator/datastore/sqlite.scm b/guix-build-coordinator/datastore/sqlite.scm
index 5bdbc6f..ff30c0b 100644
--- a/guix-build-coordinator/datastore/sqlite.scm
+++ b/guix-build-coordinator/datastore/sqlite.scm
@@ -2,6 +2,7 @@
   #:use-module (oop goops)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-19)
+  #:use-module (srfi srfi-43)
   #:use-module (srfi srfi-71)
   #:use-module (ice-9 match)
   #:use-module (ice-9 format)
@@ -3256,16 +3257,18 @@ WHERE agent_id = :agent_id"
 
 (define-method (datastore-list-allocation-plan-builds
                 (datastore <sqlite-datastore>)
-                agent-id
-                limit)
-  (call-with-worker-thread
-   (slot-ref datastore 'worker-reader-thread-channel)
-   (lambda (db)
-     (let ((statement
-            (sqlite-prepare
-             db
-             ;; This needs to guard against the plan being out of date
-             "
+                .
+                rest)
+  (apply
+   (lambda* (agent-id #:key limit)
+     (call-with-worker-thread
+      (slot-ref datastore 'worker-reader-thread-channel)
+      (lambda (db)
+        (let ((statement
+               (sqlite-prepare
+                db
+                (string-append
+                 "
 SELECT builds.uuid, derivations.name
 FROM builds
 INNER JOIN derivations
@@ -3275,24 +3278,39 @@ INNER JOIN build_allocation_plan
 WHERE build_allocation_plan.agent_id = :agent_id
   AND builds.processed = 0
   AND builds.id NOT IN (SELECT build_id FROM allocated_builds)
-ORDER BY build_allocation_plan.ordering ASC
+ORDER BY build_allocation_plan.ordering ASC"
+                 (if limit
+                     "
 LIMIT :limit"
-             #:cache? #t)))
+                     ""))
+                #:cache? #t)))
 
-       (sqlite-bind-arguments
-        statement
-        #:agent_id agent-id
-        #:limit limit)
+          (apply sqlite-bind-arguments
+                 statement
+                 #:agent_id agent-id
+                 (if limit
+                     (list #:limit limit)
+                     '()))
 
-       (let ((builds (sqlite-map
-                      (match-lambda
-                        (#(uuid derivation_name)
-                         `((uuid            . ,uuid)
-                           (derivation-name . ,derivation_name))))
-                      statement)))
-         (sqlite-reset statement)
+          (let ((builds (sqlite-map
+                         (match-lambda
+                           (#(uuid derivation_name)
+                            `((uuid            . ,uuid)
+                              (derivation-name . ,derivation_name)
+                              (tags . ,(vector-map
+                                        (lambda (_ tag)
+                                          (match tag
+                                            ((key . value)
+                                             `((key   . ,key)
+                                               (value . ,value)))))
+                                        (datastore-fetch-build-tags
+                                         datastore
+                                         uuid))))))
+                         statement)))
+            (sqlite-reset statement)
 
-         builds)))))
+            builds)))))
+   rest))
 
 (define-method (datastore-list-agent-builds
                 (datastore <sqlite-datastore>)