aboutsummaryrefslogtreecommitdiff
path: root/guix-qa-frontpage
diff options
context:
space:
mode:
authorChristopher Baines <mail@cbaines.net>2024-06-22 12:16:16 +0100
committerChristopher Baines <mail@cbaines.net>2024-06-22 12:16:16 +0100
commite1f9a8e475d5d1719ce3c5a90792254b6ae438bc (patch)
tree0c833162bffedeb119b920a88b13305285838414 /guix-qa-frontpage
parent16884f2baf9b1c622b5c406fb4fba1c841340f23 (diff)
downloadqa-frontpage-e1f9a8e475d5d1719ce3c5a90792254b6ae438bc.tar
qa-frontpage-e1f9a8e475d5d1719ce3c5a90792254b6ae438bc.tar.gz
Rework submitting builds for branches
Request the builds for each system separately as this reduces the load on the data service, and shuffle the builds before submitting to help ensure some builds for each system get submitted quickly.
Diffstat (limited to 'guix-qa-frontpage')
-rw-r--r--guix-qa-frontpage/manage-builds.scm350
1 files changed, 190 insertions, 160 deletions
diff --git a/guix-qa-frontpage/manage-builds.scm b/guix-qa-frontpage/manage-builds.scm
index e16eb23..350c7d9 100644
--- a/guix-qa-frontpage/manage-builds.scm
+++ b/guix-qa-frontpage/manage-builds.scm
@@ -243,6 +243,16 @@
(sleep 300)))))
+(define (shuffle-derivations-and-priorities! derivations-and-priorities)
+ (sort!
+ derivations-and-priorities
+ (lambda (a b) ; less
+ (let ((a-priority (second a))
+ (b-priority (second b)))
+ (if (= a-priority b-priority)
+ (string<? (first a) (first b))
+ (> a-priority b-priority))))))
+
(define* (submit-builds-for-branch database
build-coordinator
guix-data-service
@@ -266,106 +276,94 @@
(revisions
`((base . ,merge-base)
- (target . ,branch-commit)))
-
- (derivation-changes-url
- (compare-package-derivations-url
- revisions
- #:systems %systems-to-submit-builds-for)))
-
- (if derivation-changes-url
- (let ((derivation-changes-data
- (with-exception-handler
- (lambda (exn)
- (simple-format
- (current-error-port)
- "failed fetching derivation changes for branch ~A: ~A\n"
- branch
- exn)
-
- #f)
- (lambda ()
- (with-sqlite-cache
- database
- 'branch-derivation-changes
- compare-package-derivations
- #:args
- (list derivation-changes-url)
- #:ttl 0))
- #:unwind? #t)))
-
- (if derivation-changes-data
- (let ((target-commit
- (assoc-ref
- (assoc-ref
- (assoc-ref derivation-changes-data
- "revisions")
- "target")
- "commit")))
-
- (insert-into-builds-to-cancel-later database
- "branch"
- branch)
- (let ((derivations-and-priorities
- build-ids-to-keep-set
- (derivation-changes->builds-to-keep-and-submit
- derivation-changes-data
- priority)))
- (submit-builds-for-category build-coordinator
- guix-data-service
- 'branch
- branch
- derivations-and-priorities
- build-ids-to-keep-set
- target-commit)))
- (begin
- (simple-format
- (current-error-port)
- "attempting to submit builds for all derivations for branch ~A\n"
- branch)
+ (target . ,branch-commit))))
+
+ (let ((derivation-changes-vectors
+ (with-exception-handler
+ (lambda (exn)
+ (simple-format
+ (current-error-port)
+ "failed fetching derivation changes for branch ~A: ~A\n"
+ branch
+ exn)
+
+ #f)
+ (lambda ()
+ (map (lambda (system)
+ (assoc-ref (branch-derivation-changes-data revisions system)
+ "derivation_changes"))
+ %systems-to-submit-builds-for))
+ #:unwind? #t)))
+
+ (if derivation-changes-vectors
+ (begin
+ (insert-into-builds-to-cancel-later database
+ "branch"
+ branch)
+ (let ((derivations-and-priorities
+ build-ids-to-keep-set
+ (derivation-changes-vectors->builds-to-keep-and-submit
+ derivation-changes-vectors
+ priority)))
+ (submit-builds-for-category build-coordinator
+ guix-data-service
+ 'branch
+ branch
+ (shuffle-derivations-and-priorities!
+ derivations-and-priorities)
+ build-ids-to-keep-set
+ branch-commit)))
+ (begin
+ (simple-format
+ (current-error-port)
+ "attempting to submit builds for all derivations for branch ~A\n"
+ branch)
+
+ (let ((derivations-and-priorities
+ (shuffle-derivations-and-priorities!
+ (fold
+ (lambda (system result)
+ (let ((package-derivations
+ ;; This can be #f for unprcessed revisions as
+ ;; the data service gives a 404
+ (guix-data-service-request
+ (package-derivations-url
+ branch-commit
+ #:system system
+ #:target ""
+ #:no-build-from-build-server "2"))))
+ (if (eq? package-derivations #f)
+ (begin
+ (simple-format
+ (current-error-port)
+ "missing package derivation data for ~A\n"
+ branch)
+ '())
+ (vector-fold-right
+ (lambda (_ result derivation)
+ (cons
+ (list
+ (assoc-ref derivation "derivation")
+ (if (number? priority)
+ priority
+ (priority derivation)))
+ result))
+ result
+ (assoc-ref package-derivations
+ "derivations")))))
+ '()
+ %systems-to-submit-builds-for))))
+ (insert-into-builds-to-cancel-later database
+ "branch"
+ branch)
- (let ((derivations-and-priorities
- (fold
- (lambda (system result)
- (let ((package-derivations
- ;; This can be #f for unprcessed revisions as
- ;; the data service gives a 404
- (guix-data-service-request
- (package-derivations-url
- branch-commit
- #:system system
- #:target ""
- #:no-build-from-build-server "2"))))
- (if (eq? package-derivations #f)
- (begin
- (simple-format
- (current-error-port)
- "missing package derivation data for ~A\n"
- branch)
- '())
- (vector-fold-right
- (lambda (_ result derivation)
- (cons
- (list
- (assoc-ref derivation "derivation")
- (if (number? priority)
- priority
- (priority derivation)))
- result))
- result
- (assoc-ref package-derivations
- "derivations")))))
- '()
- %systems-to-submit-builds-for)))
- (submit-builds-for-category build-coordinator
- guix-data-service
- 'branch
- branch
- derivations-and-priorities
- (set)
- branch-commit)))))
- (simple-format #t "no derivation changes url for branch ~A\n"
- branch))))
+ (submit-builds-for-category build-coordinator
+ guix-data-service
+ 'branch
+ branch
+ derivations-and-priorities
+ (set)
+ branch-commit)))))))
(define (take* lst n)
(if (< (length lst) n)
@@ -660,71 +658,103 @@
'()
derivation-changes)))
+
(define (derivation-changes->builds-to-keep-and-submit derivation-changes
priority)
- (let loop ((changes
- (vector-fold
- (lambda (_ result package)
- (append! result
- (vector->list
- (assoc-ref package "target"))))
- '()
- (assoc-ref derivation-changes "derivation_changes")))
- (builds-to-submit-details '())
- (build-ids-to-keep-set (set)))
-
- (if (null? changes)
+ (derivation-changes-vectors->builds-to-keep-and-submit
+ (list (assoc-ref derivation-changes "derivation_changes"))
+ priority))
+
+(define (derivation-changes-vectors->builds-to-keep-and-submit derivation-changes-vectors
+ priority)
+ (define (process-change? change)
+ (and (string=? (assoc-ref change "target")
+ "")
+ (member (assoc-ref change "system")
+ %systems-to-submit-builds-for)))
+
+ (define (skip-submitting-build? change)
+ (vector-any
+ (lambda (build)
+ (let ((build-status
+ (assoc-ref build "status")))
+ (if (string=? build-status "scheduled")
+ (not (assoc-ref
+ build
+ "build_for_equivalent_derivation"))
+ (member build-status
+ '("started" "succeeded" "failed")))))
+ (assoc-ref change "builds")))
+
+ ;; So bad, but hopefully keeps memory usage down compared to converting to
+ ;; lists and flattening
+ (let loop1 ((derivation-changes-vectors derivation-changes-vectors)
+ (builds-to-submit-details '())
+ (build-ids-to-keep-set (set)))
+ (if (null? derivation-changes-vectors)
(values builds-to-submit-details
build-ids-to-keep-set)
- (let ((change (first changes)))
- (if (and (string=? (assoc-ref change "target")
- "")
- (member (assoc-ref change "system")
- %systems-to-submit-builds-for))
- (loop (cdr changes)
- (if (vector-any
- (lambda (build)
- (let ((build-status
- (assoc-ref build "status")))
- (if (string=? build-status "scheduled")
- (not (assoc-ref
- build
- "build_for_equivalent_derivation"))
- (member build-status
- '("started" "succeeded" "failed")))))
- (assoc-ref change "builds"))
- builds-to-submit-details ; build exists
- (cons
- (list (assoc-ref change "derivation-file-name")
- (if (number? priority)
- priority
- (priority change)))
- builds-to-submit-details))
- (fold (lambda (build result)
- (let ((build-status
- (assoc-ref build "status")))
- (if (or (string=? build-status "started")
- (and (string=? build-status "scheduled")
- ;; Cancel and replace builds for
- ;; equivalent derivations, since
- ;; the derivation might be removed
- ;; from the data service preventing
- ;; the build from starting.
- (not
- (assoc-ref
- build
- "build_for_equivalent_derivation"))))
- (set-insert
- (assoc-ref build "build_server_build_id")
- result)
- result)))
- build-ids-to-keep-set
- (vector->list
- (assoc-ref change "builds"))))
-
- (loop (cdr changes)
- builds-to-submit-details
- build-ids-to-keep-set))))))
+ (let* ((changes-vector
+ (car derivation-changes-vectors))
+ (changes-vector-length
+ (vector-length changes-vector)))
+ (let loop2 ((changes-index 0)
+ (builds-to-submit-details builds-to-submit-details)
+ (build-ids-to-keep-set build-ids-to-keep-set))
+ (if (= changes-index changes-vector-length)
+ (loop1 (cdr derivation-changes-vectors)
+ builds-to-submit-details
+ build-ids-to-keep-set)
+ (let* ((change-target-vector
+ (assoc-ref (vector-ref changes-vector changes-index)
+ "target"))
+ (change-target-vector-length
+ (vector-length change-target-vector)))
+ (let loop3 ((change-target-index 0)
+ (builds-to-submit-details builds-to-submit-details)
+ (build-ids-to-keep-set build-ids-to-keep-set))
+ (if (= change-target-index change-target-vector-length)
+ (loop2 (1+ changes-index)
+ builds-to-submit-details
+ build-ids-to-keep-set)
+ (let ((change
+ (vector-ref change-target-vector
+ change-target-index)))
+ (if (process-change? change)
+ (loop3 (1+ change-target-index)
+ (if (skip-submitting-build? change)
+ builds-to-submit-details ; build exists
+ (cons
+ (list (assoc-ref change "derivation-file-name")
+ (if (number? priority)
+ priority
+ (priority change)))
+ builds-to-submit-details))
+ (fold (lambda (build result)
+ (let ((build-status
+ (assoc-ref build "status")))
+ (if (or (string=? build-status "started")
+ (and (string=? build-status "scheduled")
+ ;; Cancel and replace builds for
+ ;; equivalent derivations, since
+ ;; the derivation might be removed
+ ;; from the data service preventing
+ ;; the build from starting.
+ (not
+ (assoc-ref
+ build
+ "build_for_equivalent_derivation"))))
+ (set-insert
+ (assoc-ref build "build_server_build_id")
+ result)
+ result)))
+ build-ids-to-keep-set
+ (vector->list
+ (assoc-ref change "builds"))))
+
+ (loop3 (1+ changes-index)
+ builds-to-submit-details
+ build-ids-to-keep-set))))))))))))
(define* (submit-builds-for-category build-coordinator
guix-data-service