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.

1 files 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"