From 9f97641466d6abb5898ef2fc7d584e8ba5d0496a Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Fri, 3 Jul 2020 09:18:52 +0100
Subject: Factor in which systems agents fetch in the allocation process

---
 guix-build-coordinator/build-allocator.scm | 82 +++++++++++++++++++-----------
 1 file changed, 53 insertions(+), 29 deletions(-)

diff --git a/guix-build-coordinator/build-allocator.scm b/guix-build-coordinator/build-allocator.scm
index 58ae6ef..94cfd03 100644
--- a/guix-build-coordinator/build-allocator.scm
+++ b/guix-build-coordinator/build-allocator.scm
@@ -298,38 +298,17 @@
                                   " "))))
 
   (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))
          (setup-failures-hash
           (datastore-fetch-setup-failures datastore)))
 
-    (define (filter-builds-for-agent agent-id)
-      (define (relevant-setup-failure? setup-failure)
-        (log "setup failure:" setup-failure)
-        (let ((failure-reason
-               (assq-ref setup-failure 'failure-reason)))
-          (cond
-           ((string=? failure-reason "missing_inputs")
-            #f)
-           ((string=? failure-reason "could_not_delete_outputs")
-            ;; This problem might go away, but just don't try the same agent
-            ;; again for now.
-            (string=? (assq-ref setup-failure 'agent-id)
-                      agent-id))
-           (else
-            (error "Unknown setup failure " failure-reason)))))
-
-      (lambda (build-id)
-        (log "build:" build-id)
-        (let* ((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 (limit-planned-builds build-ids)
       (if planned-builds-for-agent-limit
           (if (> (length build-ids) planned-builds-for-agent-limit)
@@ -348,6 +327,51 @@
               (datastore-list-unprocessed-builds-with-built-inputs datastore)))
            #:readonly? #t)))
 
+      (define systems-for-builds
+        (map (lambda (build-id)
+               (cons build-id
+                     (datastore-find-build-derivation-system
+                      datastore
+                      build-id)))
+             build-ids-for-unprocessed-builds-with-built-inputs))
+
+      (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
+                 (assq-ref setup-failure 'failure-reason)))
+            (cond
+             ((string=? failure-reason "missing_inputs")
+              #f)
+             ((string=? failure-reason "could_not_delete_outputs")
+              ;; This problem might go away, but just don't try the same agent
+              ;; again for now.
+              (string=? (assq-ref setup-failure 'agent-id)
+                        agent-id))
+             (else
+              (error "Unknown setup failure " failure-reason)))))
+
+        (lambda (build-id)
+          (log "build:" build-id)
+          (and
+           (or (null? requested-systems)
+               (let ((build-system (assoc-ref systems-for-builds build-id)))
+                 (member build-system requested-systems)))
+           (let* ((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)
           (let ((a-priority (hash-ref derived-build-priorities-hash a))
-- 
cgit v1.2.3