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.

3 files changed, 105 insertions, 101 deletions

diff --git a/guix-build-coordinator/client-communication.scm b/guix-build-coordinator/client-communication.scm
index 926c4f4..39b0c23 100644
--- a/guix-build-coordinator/client-communication.scm
+++ b/guix-build-coordinator/client-communication.scm
@@ -173,13 +173,14 @@
                (setup-failures    . ,(list->vector setup-failures))))))))
       (('POST "build" uuid "cancel")
        (let ((query-parameters (request-query-parameters request)))
-         (cancel-build build-coordinator uuid
-                       #:ignore-if-build-required-by-another?
-                       (string=? (assq-ref query-parameters
-                                           'ignore-if-build-required-by-another)
-                                 "true"))
          (render-json
-          `((result . "build-canceled")))))
+          `((result
+             .
+             ,(cancel-build build-coordinator uuid
+                            #:ignore-if-build-required-by-another?
+                            (string=? (assq-ref query-parameters
+                                                'ignore-if-build-required-by-another)
+                                      "true")))))))
       (('POST "build" uuid "update-priority")
        (update-build-priority
         build-coordinator
diff --git a/guix-build-coordinator/coordinator.scm b/guix-build-coordinator/coordinator.scm
index 04d8aac..85c1a03 100644
--- a/guix-build-coordinator/coordinator.scm
+++ b/guix-build-coordinator/coordinator.scm
@@ -480,38 +480,56 @@
                        #:key (ignore-if-build-required-by-another? #t))
   (define datastore (build-coordinator-datastore build-coordinator))
 
-  (datastore-call-with-transaction
-   datastore
-   (lambda (db)
-     (let ((build-details (datastore-find-build datastore uuid)))
-       (when (assq-ref build-details 'canceled)
-         (raise-exception
-          (make-exception-with-message
-           "cannot cancel and already canceled build")))
-
-       (when (assq-ref build-details 'processed)
-         (raise-exception
-          (make-exception-with-message
-           "cannot cancel and already processed build")))
-
-       (when (and ignore-if-build-required-by-another?
-                  (datastore-build-required-by-another? datastore
-                                                        uuid))
-         (raise-exception
-          (make-exception-with-message
-           "build required by another"))))
-
-     (datastore-remove-build-from-allocation-plan datastore uuid)
-     (datastore-cancel-build datastore uuid)
-     (datastore-insert-unprocessed-hook-event datastore
-                                              "build-canceled"
-                                              (list uuid))))
-
-  (trigger-build-allocation build-coordinator)
-
-  (build-coordinator-prompt-hook-processing-for-event build-coordinator
-                                                      'build-canceled)
-  #t)
+  (define (perform-operation)
+    (let ((val
+           (datastore-call-with-transaction
+            datastore
+            (lambda (db)
+              (let ((build-details (datastore-find-build datastore uuid)))
+                (when (assq-ref build-details 'canceled)
+                  (raise-exception
+                   (make-exception-with-message
+                    "cannot cancel and already canceled build")))
+
+                (when (assq-ref build-details 'processed)
+                  (raise-exception
+                   (make-exception-with-message
+                    "cannot cancel and already processed build"))))
+
+              (when (and ignore-if-build-required-by-another?
+                         (datastore-build-required-by-another? datastore
+                                                               uuid))
+                (raise-exception
+                 (make-transaction-rollback-exception
+                  'skipped-as-build-required-by-another)))
+
+              (datastore-remove-build-from-allocation-plan datastore uuid)
+              (datastore-cancel-build datastore uuid)
+              (datastore-insert-unprocessed-hook-event datastore
+                                                       "build-canceled"
+                                                       (list uuid))
+              'build-canceled))))
+
+      (when (eq? val 'build-canceled)
+        (trigger-build-allocation build-coordinator)
+
+        (build-coordinator-prompt-hook-processing-for-event build-coordinator
+                                                            'build-canceled))
+
+      val))
+
+  (if ignore-if-build-required-by-another?
+      (let ((build-required
+             ;; Do this check here outside the transaction to avoid having to
+             ;; start a transaction if there are builds requiring this one
+             ;;
+             ;; It's important to repeat this check inside the transaction for
+             ;; correctness.
+             (datastore-build-required-by-another? datastore uuid)))
+        (if build-required
+            'skipped-as-build-required-by-another
+            (perform-operation)))
+      (perform-operation)))
 
 (define (update-build-priority build-coordinator uuid new-priority)
   (define datastore (build-coordinator-datastore build-coordinator))
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