aboutsummaryrefslogtreecommitdiff
path: root/guix-build-coordinator/build-allocator.scm
diff options
context:
space:
mode:
Diffstat (limited to 'guix-build-coordinator/build-allocator.scm')
-rw-r--r--guix-build-coordinator/build-allocator.scm97
1 files changed, 44 insertions, 53 deletions
diff --git a/guix-build-coordinator/build-allocator.scm b/guix-build-coordinator/build-allocator.scm
index 588f213..8c08144 100644
--- a/guix-build-coordinator/build-allocator.scm
+++ b/guix-build-coordinator/build-allocator.scm
@@ -492,18 +492,6 @@
(let ((prioritised-builds
(datastore-fetch-prioritised-unprocessed-builds datastore)))
- (define systems-for-builds
- ;; TODO Should be one query
- (let ((table (make-hash-table)))
- (for-each (lambda (build-id)
- (hash-set! table
- build-id
- (datastore-find-build-derivation-system
- datastore
- build-id)))
- prioritised-builds)
- table))
-
(define tags-for-build
(let ((build-tags (make-hash-table)))
(lambda (build-id)
@@ -545,40 +533,41 @@
(else
(error "Unknown setup failure " failure-reason)))))
- (lambda (build-id)
- (log "build:" build-id)
- (and
- (or (null? requested-systems)
- (let ((build-system (hash-ref systems-for-builds build-id)))
- (member build-system requested-systems)))
- (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)
- '()))
- (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)))))
-
- (when metrics-registry
- (let ((counts
- (hash-fold
- (lambda (_ system result)
- `(,@(alist-delete system result)
- (,system . ,(+ 1 (or (assoc-ref result system) 0)))))
- '()
- systems-for-builds)))
- (for-each
- (match-lambda
- ((system . count)
- (metric-set allocator-considered-builds-metric
- count
- #:label-values `((system . ,system)))))
- counts)))
+ (match-lambda
+ (#(build-id build-system)
+ (log "build:" build-id)
+ (and
+ (or (null? requested-systems)
+ (member build-system requested-systems))
+ (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)
+ '()))
+ (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))))))
+
+ ;; TODO Restore this in a more performant way
+ ;; (when metrics-registry
+ ;; (let ((counts
+ ;; (hash-fold
+ ;; (lambda (_ system result)
+ ;; `(,@(alist-delete system result)
+ ;; (,system . ,(+ 1 (or (assoc-ref result system) 0)))))
+ ;; '()
+ ;; systems-for-builds)))
+ ;; (for-each
+ ;; (match-lambda
+ ;; ((system . count)
+ ;; (metric-set allocator-considered-builds-metric
+ ;; count
+ ;; #:label-values `((system . ,system)))))
+ ;; counts)))
(let ((result
(map
@@ -589,21 +578,23 @@
(build-ids
(let loop ((count 0)
(build-ids '())
- (potential-build-ids prioritised-builds))
+ (potential-builds prioritised-builds))
(if (or (and planned-builds-for-agent-limit
(>= count planned-builds-for-agent-limit))
- (null? potential-build-ids))
+ (null? potential-builds))
(reverse build-ids) ;; highest priority last, so
;; reverse
- (let ((potential-build (first potential-build-ids)))
- (if (filter-proc potential-build)
+ (let ((potential-build-details (first potential-builds)))
+ (if (filter-proc potential-build-details)
(loop (+ 1 count)
- (cons potential-build
+ (cons (vector-ref
+ potential-build-details
+ 0)
build-ids)
- (cdr potential-build-ids))
+ (cdr potential-builds))
(loop count
build-ids
- (cdr potential-build-ids))))))))
+ (cdr potential-builds))))))))
(cons agent-id build-ids)))
(map (lambda (agent)
(assq-ref agent 'uuid))