diff options
author | Christopher Baines <mail@cbaines.net> | 2021-01-31 11:23:21 +0000 |
---|---|---|
committer | Christopher Baines <mail@cbaines.net> | 2021-01-31 11:23:21 +0000 |
commit | 357613387f46e27a4fefa05b3516bbd47cec56d2 (patch) | |
tree | 539e88c6b361f18ca2aef1eb83b757451cebe375 | |
parent | 6133a8c1e194d35a0c0a253b3257487c6036705c (diff) | |
download | build-coordinator-357613387f46e27a4fefa05b3516bbd47cec56d2.tar build-coordinator-357613387f46e27a4fefa05b3516bbd47cec56d2.tar.gz |
Deduplicate agent-tags-match-build-tags
-rw-r--r-- | guix-build-coordinator/build-allocator.scm | 67 |
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) '())) |