diff options
author | Christopher Baines <mail@cbaines.net> | 2024-06-22 12:16:16 +0100 |
---|---|---|
committer | Christopher Baines <mail@cbaines.net> | 2024-06-22 12:16:16 +0100 |
commit | e1f9a8e475d5d1719ce3c5a90792254b6ae438bc (patch) | |
tree | 0c833162bffedeb119b920a88b13305285838414 /guix-qa-frontpage | |
parent | 16884f2baf9b1c622b5c406fb4fba1c841340f23 (diff) | |
download | qa-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.scm | 350 |
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 |