From e091f673fc3a2ff7dd814e436e78af31a7051ec3 Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Fri, 13 Nov 2020 21:24:12 +0000
Subject: 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.
---
 guix-build-coordinator/build-allocator.scm | 49 +++++++++++++++++++++++-------
 1 file 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)
-- 
cgit v1.2.3