Refactor submitting builds

Consolidate the code for branches and issues, and improve build cancellation
to use build IDs rather than derivation names.

1 files changed, 103 insertions, 117 deletions

diff --git a/guix-qa-frontpage/manage-builds.scm b/guix-qa-frontpage/manage-builds.scm
index 069ec69..943cff9 100644
--- a/guix-qa-frontpage/manage-builds.scm
+++ b/guix-qa-frontpage/manage-builds.scm
@@ -61,11 +61,12 @@
                              "target")
                             "commit")))
 
-                      (submit-builds-for-issue build-coordinator
-                                               guix-data-service
-                                               issue-number
-                                               derivation-changes
-                                               target-commit))))
+                      (submit-builds-for-category build-coordinator
+                                                  guix-data-service
+                                                  'issue
+                                                  issue-number
+                                                  derivation-changes
+                                                  target-commit))))
                 (simple-format #t "no derivation changes url for issue ~A\n"
                                issue-number)))))
        (take series 50))))
@@ -124,11 +125,12 @@
                             "target")
                            "commit")))
 
-                     (submit-builds-for-branch build-coordinator
-                                               guix-data-service
-                                               branch
-                                               derivation-changes
-                                               target-commit))))
+                     (submit-builds-for-category build-coordinator
+                                                 guix-data-service
+                                                 'branch
+                                                 branch
+                                                 derivation-changes
+                                                 target-commit))))
                (simple-format #t "no derivation changes url for branch ~A\n"
                               branch))))
        branches)))
@@ -200,10 +202,7 @@
                                         category-name
                                         category-value
                                         revision
-                                        derivations)
-  (define derivations-set
-    (list->set derivations))
-
+                                        build-ids-to-keep-set)
   (simple-format (current-error-port)
                  "canceling builds for ~A ~A and not revision ~A\n"
                  category-name
@@ -213,8 +212,8 @@
    build-coordinator
    (lambda (build-details)
      (unless (set-contains?
-              derivations-set
-              (assoc-ref build-details "derivation-name"))
+              build-ids-to-keep-set
+              (assoc-ref build-details "uuid"))
        (retry-on-error
         (lambda ()
           (send-cancel-build-request build-coordinator
@@ -235,110 +234,97 @@
    #:canceled #f
    #:processed #f))
 
-(define* (submit-builds-for-issue build-coordinator
-                                  guix-data-service
-                                  issue
-                                  derivation-changes
-                                  target-commit)
-  (define target-derivations
-    (fold (lambda (package result)
-            (fold
-             (lambda (change result)
-               (if (and (string=? (assoc-ref change "target")
-                                  "")
-                        (member (assoc-ref change "system")
-                                %systems-to-submit-builds-for)
-                        (eq? (vector-length
-                              (assoc-ref change "builds"))
-                             0))
-                   (cons (assoc-ref change "derivation-file-name")
-                         result)
-                   result))
-             result
-             (vector->list
-              (assoc-ref package "target"))))
-          '()
-          derivation-changes))
-  (define target-derivations-length
-    (length target-derivations))
-
-  (simple-format #t "~A target derivations for issue ~A\n"
-                 target-derivations-length
-                 issue)
+(define* (submit-builds-for-category build-coordinator
+                                     guix-data-service
+                                     category-name
+                                     category-value
+                                     derivation-changes
+                                     target-commit
+                                     #:key build-limit)
+  (define (submit-builds build-details
+                         build-ids-to-keep-set)
+    (for-each
+     (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))))))
+     build-details)
 
-  (if (< target-derivations-length 200)
-      (for-each (lambda (derivation)
-                  (submit-build build-coordinator
-                                guix-data-service
-                                derivation
-                                #:priority 0
-                                #:tags
-                                `(((key . category)
-                                   (value . package))
-                                  ((key . issue)
-                                   (value . ,issue))
-                                  ((key . revision)
-                                   (value . ,target-commit)))))
-                target-derivations)
-      (simple-format #t "skipping issue ~A as too many target derivations (~A)\n"
-                     issue
-                     target-derivations-length))
+    (cancel-builds-not-for-revision
+     build-coordinator
+     category-name
+     category-value
+     target-commit
+     build-ids-to-keep-set))
 
-  (cancel-builds-not-for-revision
-   build-coordinator
-   'issue
-   issue
-   target-commit
-   target-derivations))
+  (let loop ((changes
+              (append-map! (lambda (package)
+                             (vector->list
+                              (assoc-ref package "target")))
+                           derivation-changes))
+             (builds-to-submit-details '())
+             (build-ids-to-keep-set (set)))
 
-(define* (submit-builds-for-branch build-coordinator
-                                   guix-data-service
-                                   branch
-                                   derivation-changes
-                                   target-commit)
-  (define target-derivations
-    (fold (lambda (package result)
-            (fold
-             (lambda (change result)
-               (if (and (string=? (assoc-ref change "target")
-                                  "")
-                        (member (assoc-ref change "system")
-                                %systems-to-submit-builds-for)
-                        (eq? (vector-length
-                              (assoc-ref change "builds"))
-                             0))
-                   (cons (assoc-ref change "derivation-file-name")
-                         result)
-                   result))
-             result
-             (vector->list
-              (assoc-ref package "target"))))
-          '()
-          derivation-changes))
-  (define target-derivations-length
-    (length target-derivations))
+    (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)
 
-  (simple-format #t "~A target derivations for branch ~A\n"
-                 target-derivations-length
-                 branch)
+          (if (or (not build-limit)
+                  (< builds-to-submit-count
+                     build-limit))
+              (submit-builds 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)))
 
-  (for-each (lambda (derivation)
-              (submit-build build-coordinator
-                            guix-data-service
-                            derivation
-                            #:priority -100
-                            #:tags
-                            `(((key . category)
-                               (value . package))
-                              ((key . branch)
-                               (value . ,branch))
-                              ((key . revision)
-                               (value . ,target-commit)))))
-            target-derivations)
+        (let ((change (first changes)))
+          (peek "CHANGE" change)
+          (if (and (string=? (assoc-ref change "target")
+                             "")
+                   (member (assoc-ref change "system")
+                           %systems-to-submit-builds-for))
+              (loop (cdr changes)
+                    (if (find (lambda (build)
+                                (member (assoc-ref build "status")
+                                        '("scheduled"
+                                          "started"
+                                          "succeeded")))
+                              (vector->list
+                               (assoc-ref change "builds")))
+                        builds-to-submit-details ; build exists
+                        (cons
+                         (list (assoc-ref change "derivation-file-name")
+                               (if (member (assoc-ref change "system")
+                                           '("x86_64-linux" "aarch64-linux"))
+                                   -50
+                                   -100))
+                         builds-to-submit-details))
+                    (fold (lambda (build result)
+                            (if (member (assoc-ref build "status")
+                                        '("scheduled" "started"))
+                                (set-insert
+                                 (assoc-ref build "build_server_build_id")
+                                 result)
+                                result))
+                          build-ids-to-keep-set
+                          (vector->list
+                           (assoc-ref change "builds"))))
 
-  (cancel-builds-not-for-revision
-   build-coordinator
-   'branch
-   branch
-   target-commit
-   target-derivations))
+              (loop (cdr changes)
+                    builds-to-submit-details
+                    build-ids-to-keep-set))))))