From 811b3988c89874704dcd74d66105baef36a34db4 Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Tue, 21 Feb 2023 11:44:22 +0000
Subject: Rework canceling builds

Previously there were some protections introduced against canceling builds
that were required by other builds, but this change wasn't quite complete as
at least the command line interface wasn't updated to take this in to account.

This commit updates the command line interface, as well as improving the
controller.
---
 scripts/guix-build-coordinator.in | 111 +++++++++++++++++---------------------
 1 file changed, 48 insertions(+), 63 deletions(-)

(limited to 'scripts')

diff --git a/scripts/guix-build-coordinator.in b/scripts/guix-build-coordinator.in
index 8dbe5da..c892fe3 100644
--- a/scripts/guix-build-coordinator.in
+++ b/scripts/guix-build-coordinator.in
@@ -269,19 +269,13 @@
                               (cons arg
                                     (or (assq-ref result 'not-systems)
                                         '()))
-                              (alist-delete 'not-systems result))))
-        (option '("ignore-if-build-required-by-another") #t #f
-                (lambda (opt name arg result)
-                  (alist-cons 'ignore-if-build-required-by-another
-                              (string=? arg "true")
                               (alist-delete 'not-systems result))))))
 
 (define %build-cancel-option-defaults
   `((tags                                . ())
     (not-tags                            . ())
     (systems                             . ())
-    (not-systems                         . ())
-    (ignore-if-build-required-by-another . #t)))
+    (not-systems                         . ())))
 
 (define %build-update-priority-options
   (cons* (option '("new-priority") #t #f
@@ -591,70 +585,61 @@ tags:
                                       %base-option-defaults
                                       %build-cancel-option-defaults)
                               rest)))
-     (define (find-matching-builds)
+     (define (get-batch)
        (define limit 1000)
 
-       (let loop ((after-id #f)
-                  (result '()))
-         (let* ((response (request-builds-list
-                           (assq-ref opts 'coordinator)
-                           #:tags (assq-ref opts 'tags)
-                           #:not-tags (assq-ref opts 'not-tags)
-                           #:systems (assq-ref opts 'systems)
-                           #:not-systems (assq-ref opts 'not-systems)
-                           #:processed #f
-                           #:canceled #f
-                           #:after-id after-id
-                           #:limit 1000))
-                (received-builds
-                 (vector-length (assoc-ref response "builds")))
-                (new-result
-                 (fold
-                  (lambda (build-details result)
-                    (cons (assoc-ref build-details "uuid")
-                          result))
-                  result
-                  (vector->list (assoc-ref response "builds")))))
-           (display "." (current-error-port))
-           (force-output (current-error-port))
-           (if (< received-builds limit)
-               new-result
-               (loop (assoc-ref (vector-ref (assoc-ref response "builds")
-                                            (- received-builds 1))
-                                "uuid")
-                     new-result)))))
+       (simple-format (current-error-port)
+                      "requesting matching builds\n")
+       (force-output (current-error-port))
+       (let* ((response (request-builds-list
+                         (assq-ref opts 'coordinator)
+                         #:tags (assq-ref opts 'tags)
+                         #:not-tags (assq-ref opts 'not-tags)
+                         #:systems (assq-ref opts 'systems)
+                         #:not-systems (assq-ref opts 'not-systems)
+                         #:processed #f
+                         #:canceled #f
+                         #:relationship 'no-dependent-builds
+                         #:limit 1000))
+              (received-builds
+               (vector-length (assoc-ref response "builds"))))
+
+         (fold
+          (lambda (build-details result)
+            (cons (assoc-ref build-details "uuid")
+                  result))
+          '()
+          (vector->list (assoc-ref response "builds")))))
 
      (match (assq-ref opts 'arguments)
        (#f
-        (simple-format (current-error-port)
-                       "requesting matching builds")
-        (force-output (current-error-port))
-        (let* ((matching-builds (find-matching-builds))
-               (count (length matching-builds)))
-          (simple-format (current-error-port)
-                         "\nfound ~A builds matching criteria\n"
-                         count)
-
-          (call-with-progress-reporter (progress-reporter/bar
-                                        count
-                                        (simple-format #f "canceling ~A builds"
-                                                       count)
-                                        (current-error-port))
-            (lambda (report)
-              (for-each (lambda (id)
-                          (send-cancel-build-request
-                           (assq-ref opts 'coordinator)
-                           id
-                           #:ignore-if-build-required-by-another?
-                           (assq-ref opts 'ignore-if-build-required-by-another))
-                          (report))
-                        matching-builds)))))
+        (let loop ((matching-builds (get-batch)))
+          (let ((count (length matching-builds)))
+            (if (= 0 count)
+                (simple-format (current-error-port)
+                               "finished cancelling builds matching criteria\n")
+                (begin
+                  (simple-format (current-error-port)
+                                 "cancelling ~A builds matching criteria\n"
+                                 count)
+
+                  (call-with-progress-reporter (progress-reporter/bar
+                                                count
+                                                (simple-format #f "canceling ~A builds"
+                                                               count)
+                                                (current-error-port))
+                    (lambda (report)
+                      (for-each (lambda (id)
+                                  (send-cancel-build-request
+                                   (assq-ref opts 'coordinator)
+                                   id)
+                                  (report))
+                                matching-builds)))
+                  (loop (get-batch)))))))
        ((build-id)
         (send-cancel-build-request
          (assq-ref opts 'coordinator)
-         build-id
-         #:ignore-if-build-required-by-another?
-         (assq-ref opts 'ignore-if-build-required-by-another))))))
+         build-id)))))
   (("build" "update-priority" rest ...)
    (let ((opts (parse-options (append %client-options
                                       %base-options
-- 
cgit v1.2.3