Deduplicate agent-tags-match-build-tags

1 files changed, 25 insertions, 42 deletions

diff --git a/guix-build-coordinator/build-allocator.scm b/guix-build-coordinator/build-allocator.scm
index 6007708..6c9588a 100644
--- a/guix-build-coordinator/build-allocator.scm
+++ b/guix-build-coordinator/build-allocator.scm
@@ -31,6 +31,27 @@
   #:export (basic-build-allocation-strategy
             derivation-ordered-build-allocation-strategy))
 
+(define (agent-tags-match-build-tags agent-tags tags-for-build
+                                     agent-id 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)
+                    (any
+                     (match-lambda
+                       ((_ . build-value)
+                        (string=? agent-value build-value)))
+                     (vector-fold
+                      (lambda (_ result tag)
+                        (if (string=? (car tag)
+                                      agent-key)
+                            (cons tag result)
+                            result))
+                      '()
+                      build-tags))))
+                 (vector->list agent-tags))))))
+
 (define* (basic-build-allocation-strategy datastore
                                           #:key
                                           (planned-builds-for-agent-limit 512)
@@ -147,26 +168,6 @@
            (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)
-                          (any
-                           (match-lambda
-                             ((_ . build-value)
-                              (string=? agent-value build-value)))
-                           (vector-fold
-                            (lambda (_ result tag)
-                              (if (string=? (car tag)
-                                            agent-key)
-                                  (cons tag result)
-                                  result))
-                            '()
-                            build-tags))))
-                       (vector->list agent-tags))))))
-
       (lambda (build)
         (log "build:" (assq-ref build 'uuid))
         (and
@@ -174,7 +175,8 @@
              (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))
+         (agent-tags-match-build-tags agent-tags tags-for-build
+                                      agent-id (assq-ref build 'uuid))
          (let* ((build-id (assq-ref build 'uuid))
                 (setup-failures-for-build
                  (or (hash-ref setup-failures-hash build-id)
@@ -537,33 +539,14 @@
              (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)
-                            (any
-                             (match-lambda
-                               ((_ . build-value)
-                                (string=? agent-value build-value)))
-                             (vector-fold
-                              (lambda (_ result tag)
-                                (if (string=? (car tag)
-                                              agent-key)
-                                    (cons tag result)
-                                    result))
-                              '()
-                              build-tags))))
-                         (vector->list 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)
+           (agent-tags-match-build-tags agent-tags tags-for-build
+                                        agent-id build-id)
            (let* ((setup-failures-for-build
                    (or (hash-ref setup-failures-hash build-id)
                        '()))