Handle agent requested systems in the basic allocation strategy

Previously, the derivation system was ignored, but this now takes it in to
account. The implementation is copied from the derivation ordered allocator.

1 files changed, 38 insertions, 11 deletions

diff --git a/guix-build-coordinator/build-allocator.scm b/guix-build-coordinator/build-allocator.scm
index 8e7dcd8..e89c719 100644
--- a/guix-build-coordinator/build-allocator.scm
+++ b/guix-build-coordinator/build-allocator.scm
@@ -55,6 +55,14 @@
       (datastore-list-builds-for-output datastore output)))
 
   (let* ((agents (datastore-list-agents datastore))
+         (requested-systems-by-agent
+          (map (lambda (agent-details)
+                 (let ((agent-id (assq-ref agent-details 'uuid)))
+                   (cons agent-id
+                         (datastore-agent-requested-systems
+                          datastore
+                          agent-id))))
+               agents))
          (builds (datastore-list-unprocessed-builds datastore))
          (setup-failures-hash
           (datastore-fetch-setup-failures datastore))
@@ -74,7 +82,21 @@
          (build-ordering-hints-hash
           (make-hash-table)))
 
+    (define systems-for-builds
+      ;; TODO Should be one query
+      (map (lambda (build)
+             (let ((build-id (assq-ref build 'uuid)))
+               (cons build-id
+                     (datastore-find-build-derivation-system
+                      datastore
+                      build-id))))
+           builds))
+
     (define (filter-builds-for-agent agent-id)
+      (define requested-systems
+        (assoc-ref requested-systems-by-agent
+                   agent-id))
+
       (define (relevant-setup-failure? setup-failure)
         (log "setup failure:" setup-failure)
         (let ((failure-reason
@@ -99,17 +121,22 @@
 
       (lambda (build)
         (log "build:" (assq-ref build 'uuid))
-        (let* ((build-id (assq-ref build 'uuid))
-               (setup-failures-for-build
-                (or (hash-ref setup-failures-hash build-id)
-                    '()))
-               (relevant-setup-failures
-                (filter relevant-setup-failure?
-                        setup-failures-for-build)))
-          (log "relevant setup failures:" relevant-setup-failures)
-          (if (null? relevant-setup-failures)
-              #t
-              #f))))
+        (and
+         (or (null? requested-systems)
+             (let ((build-system (assoc-ref systems-for-builds
+                                            (assq-ref build 'uuid))))
+               (member build-system requested-systems)))
+         (let* ((build-id (assq-ref build 'uuid))
+                (setup-failures-for-build
+                 (or (hash-ref setup-failures-hash build-id)
+                     '()))
+                (relevant-setup-failures
+                 (filter relevant-setup-failure?
+                         setup-failures-for-build)))
+           (log "relevant setup failures:" relevant-setup-failures)
+           (if (null? relevant-setup-failures)
+               #t
+               #f)))))
 
     (define (build-sorting-function-for-agent agent-id)
       (lambda (a b)