diff options
Diffstat (limited to 'guix-qa-frontpage/manage-builds.scm')
| -rw-r--r-- | guix-qa-frontpage/manage-builds.scm | 495 |
1 files changed, 282 insertions, 213 deletions
diff --git a/guix-qa-frontpage/manage-builds.scm b/guix-qa-frontpage/manage-builds.scm index 1d9a512..82e2675 100644 --- a/guix-qa-frontpage/manage-builds.scm +++ b/guix-qa-frontpage/manage-builds.scm @@ -7,6 +7,9 @@ #:use-module (ice-9 threads) #:use-module (ice-9 exceptions) #:use-module (fibers) + #:use-module (knots parallelism) + #:use-module (knots non-blocking) + #:use-module (knots timeout) #:use-module (prometheus) #:use-module (guix sets) #:use-module ((guix build syscalls) @@ -33,8 +36,11 @@ default-branch-priority-for-change submit-builds-for-branch + submit-build + %fiberized-submit-build + start-submit-patch-builds-fiber - start-submit-branch-builds-thread + start-submit-branch-builds-fiber start-submit-master-branch-system-tests-thread)) (define %systems-to-submit-builds-for @@ -42,11 +48,18 @@ "i686-linux" "aarch64-linux" "armhf-linux" - "powerpc64le-linux" - "i586-gnu")) + "riscv64-linux" + ;; Don't submit powerpc64le-linux builds as the single build machine + ;; available isn't running enough at the moment + ;; "powerpc64le-linux" + ;; Builds for the hurd can't be reliably done at the moment, so skip + ;; submitting them + ;; "i586-gnu" + )) (define %systems-with-expected-low-substitute-availability - '("i586-gnu" + '("armhf-linux" + "i586-gnu" "riscv64-linux" "powerpc64le-linux")) @@ -54,6 +67,9 @@ (* (length %systems-to-submit-builds-for) 600)) +(define %fiberized-submit-build + (make-parameter #f)) + (define* (submit-builds-for-issue database build-coordinator @@ -83,8 +99,10 @@ (current-error-port) "failed fetching derivation changes for issue ~A: ~A\n" issue-number - exn) - + (if (and (guix-data-service-error? exn) + (= (guix-data-service-error-response-code exn) 200)) + (guix-data-service-error-summary exn) + exn)) #f) (lambda () (with-sqlite-cache @@ -185,7 +203,7 @@ issues-with-builds-to-cancel)) (simple-format #t "submitting patch builds\n") - (for-each + (fibers-batch-for-each (lambda (issue-number) (submit-builds-for-issue database @@ -194,6 +212,7 @@ issue-number #:priority priority-for-change #:build-limit %patches-builds-limit)) + 2 first-n-series-issue-numbers))) (spawn-fiber @@ -203,7 +222,7 @@ (lambda (exn) (simple-format (current-error-port) - "exception in submit patch builds thread: ~A\n" + "exception in submit patch builds fiber: ~A\n" exn)) (lambda () (with-throw-handler #t @@ -233,6 +252,12 @@ (sleep 300))))) +(define (shuffle-derivations-and-priorities! derivations-and-priorities) + (sort! + derivations-and-priorities + (lambda (a b) ; less + (string<? (first a) (first b))))) + (define* (submit-builds-for-branch database build-coordinator guix-data-service @@ -248,114 +273,123 @@ (get-commit (string-append "origin/" branch))) (merge-base - (get-git-merge-base - (get-commit "origin/master") - branch-commit)) + (non-blocking + (lambda () + (get-git-merge-base + (get-commit "origin/master") + branch-commit)))) (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 - #:threads 4))) - (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) + (retry-on-error + (lambda () + (let ((data + (branch-derivation-changes-data revisions system))) + (if (assq-ref data 'exception) + (raise-exception + (guix-data-service-error-sexp->error data)) + (assoc-ref data "derivation_changes")))) + #:no-retry guix-data-service-error-invalid-query? + #:times 2 + #:delay 15)) + %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 + #:skip-updating-derived-priorities? #t))) + (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) - (vector-fold-right - (lambda (_ result derivation) - (cons - (list - (assoc-ref derivation "derivation") - (if (number? priority) - priority - (priority derivation))) - result)) - result - (assoc-ref - (guix-data-service-request - (package-derivations-url - branch-commit - #:system system - #:target "" - #:no-build-from-build-server "2")) - "derivations"))) - '() - %systems-to-submit-builds-for))) - (submit-builds-for-category build-coordinator - guix-data-service - 'branch - branch - derivations-and-priorities - (set) - branch-commit - #:threads 4))))) - (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 + #:skip-updating-derived-priorities? #t))))))) (define (take* lst n) (if (< (length lst) n) lst (take lst n))) -(define (start-submit-branch-builds-thread database - build-coordinator - guix-data-service - metrics-registry) +(define (start-submit-branch-builds-fiber database + build-coordinator + guix-data-service + metrics-registry) (define (cancel-branch-builds branches) (for-each (lambda (branch) @@ -409,7 +443,9 @@ ((name . details) (->bool (assoc-ref details "issue_number")))) all-branches) - 2)) + ;; TODO The builds for the first branch should be mostly + ;; complete before submitting builds for any others + 1)) (branch-names (map car branches))) @@ -440,19 +476,14 @@ (current-error-port) "waiting for master branch substitutes before submitting branch builds\n"))))))) - (call-with-new-thread + (spawn-fiber (lambda () - (catch 'system-error - (lambda () - (set-thread-name "branch builds")) - (const #t)) - (while #t (with-exception-handler (lambda (exn) (simple-format (current-error-port) - "exception in submit branch builds thread: ~A\n" + "exception in submit branch builds fiber: ~A\n" exn)) (lambda () (with-throw-handler #t @@ -470,11 +501,12 @@ (sleep 3600))))) (define* (submit-build build-coordinator guix-data-service derivation - #:key (priority 0) (tags '())) + #:key (priority 0) (tags '()) + skip-updating-derived-priorities?) (retry-on-error (lambda () (let ((response - (with-fibers-port-timeouts + (with-port-timeouts (lambda () (send-submit-build-request build-coordinator @@ -485,8 +517,10 @@ #t #t #t - tags)) - #:timeout 60))) + tags + #:skip-updating-derived-priorities? + skip-updating-derived-priorities?)) + #:timeout 240))) (let ((no-build-submitted-response (assoc-ref response "no-build-submitted"))) (if no-build-submitted-response @@ -522,7 +556,7 @@ "canceling builds for ~A ~A\n" category-name category-value) - (with-fibers-port-timeouts + (with-port-timeouts (lambda () (let loop ((uuids-batch (fetch-build-uuids))) (for-each @@ -550,7 +584,7 @@ (unless (null? uuids-batch) (loop (fetch-build-uuids))))) - #:timeout 60) + #:timeout 120) (simple-format (current-error-port) "finshed canceling builds for ~A ~A\n" category-name @@ -584,7 +618,7 @@ category-name category-value revision) - (with-fibers-port-timeouts + (with-port-timeouts (lambda () (let loop ((uuids-batch (fetch-build-uuids))) (let ((builds-to-cancel @@ -614,7 +648,7 @@ (unless (null? builds-to-cancel) (loop (fetch-build-uuids)))))) - #:timeout 60) + #:timeout 120) (simple-format (current-error-port) "finished canceling builds for ~A ~A and not revision ~A\n" category-name @@ -643,71 +677,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 all-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 all-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+ change-target-index) + builds-to-submit-details + build-ids-to-keep-set)))))))))))) (define* (submit-builds-for-category build-coordinator guix-data-service @@ -718,32 +784,30 @@ target-commit #:key build-limit (build-count-priority-penalty (const 0)) - (threads 1)) + skip-updating-derived-priorities?) (define (submit-builds build-details build-ids-to-keep-set) + (define submit-build/fiberized + (%fiberized-submit-build)) + (define submit-single (match-lambda ((derivation priority) - (submit-build build-coordinator - guix-data-service - derivation - #:priority priority - #:tags - `(((key . category) - (value . package)) - ((key . ,category-name) - (value . ,category-value)) - ((key . revision) - (value . ,target-commit))))))) - - (if (= threads 1) - (for-each - submit-single - build-details) - (n-par-for-each - threads - submit-single - build-details))) + (submit-build/fiberized build-coordinator + guix-data-service + derivation + #:priority priority + #:tags + `(((key . category) + (value . package)) + ((key . ,category-name) + (value . ,category-value)) + ((key . revision) + (value . ,target-commit))) + #:skip-updating-derived-priorities? + skip-updating-derived-priorities?)))) + + (fibers-for-each submit-single build-details)) (let ((builds-to-submit-count (length derivations-and-priorities))) @@ -752,14 +816,18 @@ category-name category-value) - ;; Cancel builds first, as some of the builds we want to submit might be - ;; for the same outputs as ones we're going to cancel. - (cancel-builds-not-for-revision - build-coordinator - category-name - category-value - target-commit - build-ids-to-keep-set) + (retry-on-error + (lambda () + ;; Cancel builds first, as some of the builds we want to submit might be + ;; for the same outputs as ones we're going to cancel. + (cancel-builds-not-for-revision + build-coordinator + category-name + category-value + target-commit + build-ids-to-keep-set)) + #:times 3 + #:delay 2) (if (or (not build-limit) (< builds-to-submit-count @@ -822,7 +890,8 @@ (assoc-ref revision-details "commit-hash") #f)) (branch-revisions - (branch-revisions-url 2 "master")))) + (branch-revisions-url %data-service-guix-repository-id + "master")))) (recent-processed-revision-commits (if (> (length processed-revision-commits) 5) |