diff options
Diffstat (limited to 'guix-build-coordinator/build-allocator.scm')
| -rw-r--r-- | guix-build-coordinator/build-allocator.scm | 64 |
1 files changed, 64 insertions, 0 deletions
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) '())) |