diff options
| -rw-r--r-- | guix-qa-frontpage/manage-builds.scm | 148 |
1 files changed, 59 insertions, 89 deletions
diff --git a/guix-qa-frontpage/manage-builds.scm b/guix-qa-frontpage/manage-builds.scm index 82e2675..0048300 100644 --- a/guix-qa-frontpage/manage-builds.scm +++ b/guix-qa-frontpage/manage-builds.scm @@ -193,8 +193,7 @@ (for-each (lambda (issue-number) (cancel-builds build-coordinator - "issue" - issue-number + #:tags `(("issue" . ,issue-number)) #:relationship 'unset) (delete-from-builds-to-cancel-later database @@ -394,8 +393,7 @@ (for-each (lambda (branch) (cancel-builds build-coordinator - "branch" - branch + #:tags `(("branch" . ,branch)) #:relationship 'unset) (delete-from-builds-to-cancel-later database @@ -534,9 +532,10 @@ #:delay 30)) (define* (cancel-builds build-coordinator - category-name - category-value - #:key (relationship 'no-dependent-builds)) + #:key build-ids-to-keep-set + (tags '()) + (not-tags '()) + (relationship 'no-dependent-builds)) (define (fetch-build-uuids) (fold-builds build-coordinator @@ -544,88 +543,58 @@ (cons (assoc-ref build-details "uuid") result)) '() #:tags - `(((key . category) - (value . package)) - ((key . ,category-name) - (value . ,category-value))) + (map (match-lambda + ((key . val) + `((key . ,key) + (value . ,val)))) + tags) + #:not-tags + (map (match-lambda + ((key . val) + `((key . ,key) + (value . ,val)))) + not-tags) #:canceled #f #:processed #f #:relationship relationship)) - (simple-format (current-error-port) - "canceling builds for ~A ~A\n" - category-name - category-value) - (with-port-timeouts - (lambda () - (let loop ((uuids-batch (fetch-build-uuids))) - (for-each - (lambda (uuid) - (retry-on-error - (lambda () - (send-cancel-build-request build-coordinator - uuid - #:skip-updating-derived-priorities? #t - #:ignore-if-build-required-by-another? - (if (eq? relationship 'unset) - #f - #t))) - #:times 6 - #:delay 15 - #:ignore (lambda (exn) - ;; TODO Improve the coordinator exceptions - (and (exception-with-message? exn) - (string=? - (assoc-ref (exception-message exn) "error") - "build-already-processed")))) - (simple-format (current-error-port) - "canceled ~A\n" uuid)) - uuids-batch) - - (unless (null? uuids-batch) - (loop (fetch-build-uuids))))) - #:timeout 120) - (simple-format (current-error-port) - "finshed canceling builds for ~A ~A\n" - category-name - category-value)) - -(define (cancel-builds-not-for-revision build-coordinator - category-name - category-value - revision - build-ids-to-keep-set) - (define (fetch-build-uuids) - (fold-builds - build-coordinator - (lambda (build-details result) - (cons (assoc-ref build-details "uuid") result)) - '() - #:tags - `(((key . category) - (value . package)) - ((key . ,category-name) - (value . ,category-value))) - #:not-tags - `(((key . revision) - (value . ,revision))) - #:canceled #f - #:processed #f - #:relationship 'no-dependent-builds)) + (define log-description + (string-append + (if (null? tags) + "" + (string-append + "tags: " + (string-join + (map (match-lambda + ((key . val) + (simple-format #f "~A=~A" key val))) + tags) + ", "))) + (if (null? not-tags) + " " + (string-append + " not tags: " + (string-join + (map (match-lambda + ((key . val) + (simple-format #f "~A=~A" key val))) + not-tags) + ", "))) + (string-append + " relationship: " (symbol->string relationship)))) (simple-format (current-error-port) - "canceling builds for ~A ~A and not revision ~A\n" - category-name - category-value - revision) + "canceling builds (~A)" log-description) (with-port-timeouts (lambda () (let loop ((uuids-batch (fetch-build-uuids))) (let ((builds-to-cancel - (remove! - (lambda (uuid) - (set-contains? build-ids-to-keep-set uuid)) - uuids-batch))) + (if build-ids-to-keep-set + (remove! + (lambda (uuid) + (set-contains? build-ids-to-keep-set uuid)) + uuids-batch) + uuids-batch))) (for-each (lambda (uuid) @@ -633,7 +602,11 @@ (lambda () (send-cancel-build-request build-coordinator uuid - #:skip-updating-derived-priorities? #t)) + #:skip-updating-derived-priorities? #t + #:ignore-if-build-required-by-another? + (if (eq? relationship 'unset) + #f + #t))) #:times 6 #:delay 15 #:ignore (lambda (exn) @@ -650,10 +623,8 @@ (loop (fetch-build-uuids)))))) #:timeout 120) (simple-format (current-error-port) - "finished canceling builds for ~A ~A and not revision ~A\n" - category-name - category-value - revision)) + "finished canceling builds (~A)\n" + log-description)) (define (builds-missing-for-derivation-changes? derivation-changes) (any @@ -820,12 +791,11 @@ (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 + (cancel-builds build-coordinator - category-name - category-value - target-commit - build-ids-to-keep-set)) + #:tags `((,category-name . ,category-value)) + #:not-tags `(("revision" . ,target-commit)) + #:build-ids-to-keep-set build-ids-to-keep-set)) #:times 3 #:delay 2) |