Track when builds are submitted, and cancel them later

This housekeeping helps avoid building things unnecessarily, as well as
avoiding builds that can't happen since the derivation might no longer be
available.

2 files changed, 199 insertions, 33 deletions

diff --git a/guix-qa-frontpage/database.scm b/guix-qa-frontpage/database.scm
index d2e0b63..50276d7 100644
--- a/guix-qa-frontpage/database.scm
+++ b/guix-qa-frontpage/database.scm
@@ -41,7 +41,11 @@
             database-call-with-transaction
 
             clear-sqlite-cache-entry
-            with-sqlite-cache))
+            with-sqlite-cache
+
+            insert-into-builds-to-cancel-later
+            delete-from-builds-to-cancel-later
+            select-from-builds-to-cancel-later))
 
 (define-record-type <database>
   (make-database database-file reader-thread-channel writer-thread-channel
@@ -73,7 +77,12 @@ CREATE TABLE cache (
     data TEXT NOT NULL
 );
 
-CREATE UNIQUE INDEX IF NOT EXISTS cache_idx ON cache (key);")
+CREATE UNIQUE INDEX IF NOT EXISTS cache_idx ON cache (key);
+
+CREATE TABLE IF NOT EXISTS builds_to_cancel_later (
+    category_name TEXT NOT NULL,
+    category_value TEXT NOT NULL
+);")
 
   (sqlite-exec db schema))
 
@@ -91,7 +100,17 @@ SELECT name FROM sqlite_master WHERE type = 'table' AND name = :name")))
 
     (match (sqlite-step statement)
       (#f (perform-initial-database-setup db))
-      (_ #f))
+      (_
+       (sqlite-exec
+        db
+        "
+CREATE TABLE IF NOT EXISTS builds_to_cancel_later (
+    category_name TEXT NOT NULL,
+    category_value TEXT NOT NULL
+);
+
+CREATE UNIQUE INDEX IF NOT EXISTS builds_to_cancel_later_unique
+  ON builds_to_cancel_later (category_name, category_value);")))
 
     (sqlite-finalize statement)))
 
@@ -461,3 +480,71 @@ VALUES (:key, :timestamp, :data)"
 
             (apply values vals)))
         (apply values cached-values))))
+
+(define (insert-into-builds-to-cancel-later database category-name
+                                            category-value)
+  (database-call-with-transaction
+   database
+   (lambda (db)
+     (let ((statement
+            (sqlite-prepare
+             db
+             "
+INSERT INTO builds_to_cancel_later (category_name, category_value)
+  VALUES (:name, :value)
+ON CONFLICT IGNORE"
+             #:cache? #t)))
+       (sqlite-bind-arguments
+        statement
+        #:name category-name
+        #:value category-value)
+
+       (sqlite-step statement)
+       (sqlite-reset statement))))
+  #t)
+
+(define (delete-from-builds-to-cancel-later database category-name
+                                            category-value)
+  (database-call-with-transaction
+   database
+   (lambda (db)
+     (let ((statement
+            (sqlite-prepare
+             db
+             "
+DELETE FROM builds_to_cancel_later
+WHERE category_name = :name AND category_value = :value"
+             #:cache? #t)))
+       (sqlite-bind-arguments
+        statement
+        #:name category-name
+        #:value category-value)
+
+       (sqlite-step statement)
+       (sqlite-reset statement))))
+  #t)
+
+(define (select-from-builds-to-cancel-later database category-name)
+  (call-with-worker-thread
+   (database-reader-thread-channel database)
+   (lambda (db)
+     (let ((statement
+            (sqlite-prepare
+             db
+             "
+SELECT category_value FROM builds_to_cancel_later
+WHERE category_name = :name"
+             #:cache? #t)))
+
+       (sqlite-bind-arguments
+        statement
+        #:name category-name)
+
+       (let ((result
+              (sqlite-map
+               (match-lambda
+                 (#(val) val))
+               statement)))
+         (sqlite-reset statement)
+
+         result)))))
diff --git a/guix-qa-frontpage/manage-builds.scm b/guix-qa-frontpage/manage-builds.scm
index 73aee8d..e872d26 100644
--- a/guix-qa-frontpage/manage-builds.scm
+++ b/guix-qa-frontpage/manage-builds.scm
@@ -93,6 +93,9 @@
                      "target")
                     "commit")))
 
+              (insert-into-builds-to-cancel-later database
+                                                  "issue"
+                                                  (number->string issue-number))
               (submit-builds-for-category build-coordinator
                                           guix-data-service
                                           'issue
@@ -122,13 +125,36 @@
         350))
 
   (define (submit-builds)
-    (simple-format #t "submitting patch builds\n")
-    (let ((series (with-sqlite-cache
-                   database
-                   'latest-patchwork-series-by-issue
-                   latest-patchwork-series-by-issue
-                   #:ttl 3000)))
-
+    (let* ((all-series
+            (with-sqlite-cache
+             database
+             'latest-patchwork-series-by-issue
+             latest-patchwork-series-by-issue
+             #:ttl 3000))
+           (first-n-series
+            (take all-series series-count)))
+
+      (let* ((issues-with-builds-previously-submitted
+              (select-from-builds-to-cancel-later
+               database
+               "issue"))
+             (issues-with-builds-to-cancel
+              (lset-difference
+               string=?
+               issues-with-builds-previously-submitted
+               first-n-series)))
+        (for-each
+         (lambda (issue-number)
+           (cancel-builds build-coordinator
+                          "issue"
+                          issue-number)
+           (delete-from-builds-to-cancel-later
+            database
+            "issue"
+            issue-number))
+         issues-with-builds-to-cancel))
+
+      (simple-format #t "submitting patch builds\n")
       (n-par-for-each
        4
        (match-lambda
@@ -142,7 +168,7 @@
            #:build-limit
            (* (length %systems-to-submit-builds-for)
               300))))
-       (take series series-count))))
+       first-n-series)))
 
   (call-with-new-thread
    (lambda ()
@@ -243,6 +269,9 @@
                      "target")
                     "commit")))
 
+              (insert-into-builds-to-cancel-later database
+                                                  "branch"
+                                                  branch)
               (submit-builds-for-category build-coordinator
                                           guix-data-service
                                           'branch
@@ -259,30 +288,52 @@
                                            guix-data-service)
   (define (submit-builds)
     (simple-format #t "submitting branch builds\n")
-    (let ((branches
-           (take (with-sqlite-cache
-                  database
-                  'list-non-master-branches
-                  list-non-master-branches
-                  #:ttl 0)
-                 2)))
+    (let* ((branches
+            (take (with-sqlite-cache
+                   database
+                   'list-non-master-branches
+                   list-non-master-branches
+                   #:ttl 0)
+                  2))
+           (branch-names
+            (map car branches)))
+
+      (let* ((branches-with-builds-previously-submitted
+              (select-from-builds-to-cancel-later
+               database
+               "branch"))
+             (branches-with-builds-to-cancel
+              (lset-difference
+               string=?
+               branches-with-builds-previously-submitted
+               branch-names)))
+        (for-each
+         (lambda (branch)
+           (cancel-builds build-coordinator
+                          "branch"
+                          branch)
+           (delete-from-builds-to-cancel-later
+            database
+            "branch"
+            branch))
+         branches-with-builds-to-cancel))
+
       (for-each
-       (match-lambda*
-         ((index (branch . details))
-          (submit-builds-for-branch
-           database
-           build-coordinator
-           guix-data-service
-           branch
-           #:priority
-           (lambda (change)
-             (- (if (member (assoc-ref change "system")
-                            '("x86_64-linux" "aarch64-linux"))
-                    400
-                    350)
-                (* index 100))))))
+       (lambda (index branch)
+         (submit-builds-for-branch
+          database
+          build-coordinator
+          guix-data-service
+          branch
+          #:priority
+          (lambda (change)
+            (- (if (member (assoc-ref change "system")
+                           '("x86_64-linux" "aarch64-linux"))
+                   400
+                   350)
+               (* index 100)))))
        (iota (length branches))
-       branches)))
+       branch-names)))
 
   (call-with-new-thread
    (lambda ()
@@ -369,6 +420,34 @@
     (unless (= 0 batch-size)
       (loop (process-batch)))))
 
+(define (cancel-builds build-coordinator
+                       category-name
+                       category-value)
+  (simple-format (current-error-port)
+                 "canceling builds for ~A ~A\n"
+                 category-name
+                 category-value)
+  (for-each-build
+   build-coordinator
+   (lambda (build-details)
+     (retry-on-error
+      (lambda ()
+        (send-cancel-build-request build-coordinator
+                                   (assoc-ref build-details "uuid")))
+      #:times 6
+      #:delay 15)
+     (simple-format (current-error-port)
+                    "canceled ~A\n"
+                    (assoc-ref build-details "uuid")))
+   #:tags
+   `(((key . category)
+      (value . package))
+     ((key . ,category-name)
+      (value . ,category-value)))
+   #:canceled #f
+   #:processed #f
+   #:relationship 'no-dependent-builds))
+
 (define (cancel-builds-not-for-revision build-coordinator
                                         category-name
                                         category-value