Implement agent/build tag matching

If the agent and build tags have overlapping keys, compare the tag value, and
only match the build to the agent if the value matches.

There's a potential issue with some of the code here in that it doesn't cope
well with tags with matching keys but differing values, but this is just a
first implementation.

2 files changed, 64 insertions, 6 deletions

diff --git a/README.org b/README.org
index 8d12aa2..973c45e 100644
--- a/README.org
+++ b/README.org
@@ -123,9 +123,3 @@ future.
 With the HTTP transport for coordinator <-> agent communication, this should
 happen over TLS for security if the network isn't secure. Each agent uses
 basic authentication to connect to the coordinator.
-
-Unimplemented but planned features include:
-
- - Build/agent tags. Agents and builds should have key=value tags, a build
-   will only be allocated to an agent if all the key=value tags it has matches
-   the agent.
diff --git a/guix-build-coordinator/build-allocator.scm b/guix-build-coordinator/build-allocator.scm
index ef3665f..2bd69a6 100644
--- a/guix-build-coordinator/build-allocator.scm
+++ b/guix-build-coordinator/build-allocator.scm
@@ -55,6 +55,12 @@
       (datastore-list-builds-for-output datastore output)))
 
   (let* ((agents (datastore-list-agents datastore))
+         (agent-tags (map (lambda (agent-details)
+                            (let ((agent-id (assq-ref agent-details 'uuid)))
+                              (cons agent-id
+                                    (datastore-fetch-agent-tags datastore
+                                                                agent-id))))
+                          agents))
          (requested-systems-by-agent
           (map (lambda (agent-details)
                  (let ((agent-id (assq-ref agent-details 'uuid)))
@@ -100,6 +106,19 @@
                   builds)
         table))
 
+    (define tags-for-build
+      (let ((build-tags (make-hash-table)))
+        (lambda (build-id)
+          (let ((tags (hash-ref build-tags build-id)))
+            (if (eq? #f tags)
+                (let ((tags (datastore-fetch-build-tags datastore
+                                                        build-id)))
+                  (hash-set! build-tags
+                             build-id
+                             tags)
+                  tags)
+                tags)))))
+
     (define (filter-builds-for-agent agent-id)
       (define requested-systems
         (assoc-ref requested-systems-by-agent
@@ -127,6 +146,18 @@
            (else
             (error "Unknown setup failure " failure-reason)))))
 
+      (define (agent-tags-match-build-tags build-id)
+        (let ((agent-tags (assoc-ref agent-tags agent-id)))
+          (or (null? agent-tags)
+              (let ((build-tags (tags-for-build build-id)))
+                (every (match-lambda
+                         ((agent-key . agent-value)
+                          (match (assoc-ref build-tags agent-key)
+                            ((_ . build-value)
+                             (string=? agent-value build-value))
+                            (#f #t))))
+                       agent-tags)))))
+
       (lambda (build)
         (log "build:" (assq-ref build 'uuid))
         (and
@@ -134,6 +165,7 @@
              (let ((build-system (hash-ref systems-for-builds
                                            (assq-ref build 'uuid))))
                (member build-system requested-systems)))
+         (agent-tags-match-build-tags (assq-ref build 'uuid))
          (let* ((build-id (assq-ref build 'uuid))
                 (setup-failures-for-build
                  (or (hash-ref setup-failures-hash build-id)
@@ -410,6 +442,12 @@
                                name)))))
 
   (let* ((agents (datastore-list-agents datastore))
+         (agent-tags (map (lambda (agent-details)
+                            (let ((agent-id (assq-ref agent-details 'uuid)))
+                              (cons agent-id
+                                    (datastore-fetch-agent-tags datastore
+                                                                agent-id))))
+                          agents))
          (requested-systems-by-agent
           (map (lambda (agent-details)
                  (let ((agent-id (assq-ref agent-details 'uuid)))
@@ -445,6 +483,19 @@
                       build-id)))
              build-ids-for-unprocessed-builds-with-built-inputs))
 
+      (define tags-for-build
+        (let ((build-tags (make-hash-table)))
+          (lambda (build-id)
+            (let ((tags (hash-ref build-tags build-id)))
+              (if (eq? #f tags)
+                  (let ((tags (datastore-fetch-build-tags datastore
+                                                          build-id)))
+                    (hash-set! build-tags
+                               build-id
+                               tags)
+                    tags)
+                  tags)))))
+
       (define (filter-builds-for-agent agent-id)
         (define requested-systems
           (assoc-ref requested-systems-by-agent
@@ -470,12 +521,25 @@
              (else
               (error "Unknown setup failure " failure-reason)))))
 
+        (define (agent-tags-match-build-tags build-id)
+          (let ((agent-tags (assoc-ref agent-tags agent-id)))
+            (or (null? agent-tags)
+                (let ((build-tags (tags-for-build build-id)))
+                  (every (match-lambda
+                           ((agent-key . agent-value)
+                            (match (assoc-ref build-tags agent-key)
+                              ((_ . build-value)
+                               (string=? agent-value build-value))
+                              (#f #t))))
+                         agent-tags)))))
+
         (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)))
+           (agent-tags-match-build-tags build-id)
            (let* ((setup-failures-for-build
                    (or (hash-ref setup-failures-hash build-id)
                        '()))