From 41ae60bbb755591526953d15e2cf7519bf42b4d4 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Sun, 15 Oct 2023 10:26:29 +0100 Subject: Refactor submit-builds-for-category Pull out the handling of the derivation-changes data, so that submit-builds-for-category can be used when you're not dealing with data service comparisons. --- guix-qa-frontpage/manage-builds.scm | 201 +++++++++++++++++++----------------- 1 file changed, 107 insertions(+), 94 deletions(-) diff --git a/guix-qa-frontpage/manage-builds.scm b/guix-qa-frontpage/manage-builds.scm index 7f93e47..7408e7d 100644 --- a/guix-qa-frontpage/manage-builds.scm +++ b/guix-qa-frontpage/manage-builds.scm @@ -100,21 +100,26 @@ (insert-into-builds-to-cancel-later database "issue" issue-number) - (submit-builds-for-category build-coordinator - guix-data-service - 'issue - issue-number - derivation-changes-data - target-commit - #:build-limit build-limit - #:priority priority - #:build-count-priority-penalty - (lambda (build-count) - (cond - ((< build-count 10) 0) - ((< build-count 100) 50) - ((< build-count 300) 100) - (else 150)))) + (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 + 'issue + issue-number + derivations-and-priorities + build-ids-to-keep-set + target-commit + #:build-limit build-limit + #:build-count-priority-penalty + (lambda (build-count) + (cond + ((< build-count 10) 0) + ((< build-count 100) 50) + ((< build-count 300) 100) + (else 150))))) (simple-format #t "finished submitting builds for issue ~A\n" @@ -283,14 +288,19 @@ (insert-into-builds-to-cancel-later database "branch" branch) - (submit-builds-for-category build-coordinator - guix-data-service - 'branch - branch - derivation-changes-data - target-commit - #:priority priority - #:threads 4)))) + (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))))) (simple-format #t "no derivation changes url for branch ~A\n" branch)))) @@ -556,43 +566,8 @@ '() derivation-changes))) - -(define* (submit-builds-for-category build-coordinator - guix-data-service - category-name - category-value - derivation-changes - target-commit - #:key build-limit - priority - (build-count-priority-penalty (const 0)) - (threads 1)) - (define (submit-builds build-details - build-ids-to-keep-set) - (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))) - +(define (derivation-changes->builds-to-keep-and-submit derivation-changes + priority) (let loop ((changes (vector-fold (lambda (_ result package) @@ -605,40 +580,8 @@ (build-ids-to-keep-set (set))) (if (null? changes) - (let ((builds-to-submit-count - (length builds-to-submit-details))) - (simple-format #t "~A target derivations for ~A ~A\n" - builds-to-submit-count - category-name - category-value) - - (if (or (not build-limit) - (< builds-to-submit-count - build-limit)) - (submit-builds (let ((priority-penalty - (build-count-priority-penalty - builds-to-submit-count))) - (if (= 0 priority-penalty) - builds-to-submit-details - (map - (match-lambda - ((derivation priority) - (list derivation - (- priority priority-penalty)))) - builds-to-submit-details))) - build-ids-to-keep-set) - (simple-format #t "skipping ~A ~A as too many target derivations (~A)\n" - category-name - category-value - builds-to-submit-count)) - - (cancel-builds-not-for-revision - build-coordinator - category-name - category-value - target-commit - build-ids-to-keep-set)) - + (values builds-to-submit-details + build-ids-to-keep-set) (let ((change (first changes))) (if (and (string=? (assoc-ref change "target") "") @@ -672,6 +615,76 @@ builds-to-submit-details build-ids-to-keep-set)))))) +(define* (submit-builds-for-category build-coordinator + guix-data-service + category-name + category-value + derivations-and-priorities + build-ids-to-keep-set + target-commit + #:key build-limit + (build-count-priority-penalty (const 0)) + (threads 1)) + (define (submit-builds build-details + build-ids-to-keep-set) + (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))) + + (let ((builds-to-submit-count + (length derivations-and-priorities))) + (simple-format #t "~A target derivations for ~A ~A\n" + builds-to-submit-count + category-name + category-value) + + (if (or (not build-limit) + (< builds-to-submit-count + build-limit)) + (submit-builds (let ((priority-penalty + (build-count-priority-penalty + builds-to-submit-count))) + (if (= 0 priority-penalty) + derivations-and-priorities + (map + (match-lambda + ((derivation priority) + (list derivation + (- priority priority-penalty)))) + derivations-and-priorities))) + build-ids-to-keep-set) + (simple-format #t "skipping ~A ~A as too many target derivations (~A)\n" + category-name + category-value + builds-to-submit-count)) + + (cancel-builds-not-for-revision + build-coordinator + category-name + category-value + target-commit + build-ids-to-keep-set))) + (define %system-tests-that-change-every-revision '("btrfs-raid10-root-os" "btrfs-raid10-root-os-degraded" -- cgit v1.2.3