Guard against canceling builds required by others

5 files changed, 89 insertions, 17 deletions

diff --git a/guix-build-coordinator/client-communication.scm b/guix-build-coordinator/client-communication.scm
index 8d089bb..e796bd8 100644
--- a/guix-build-coordinator/client-communication.scm
+++ b/guix-build-coordinator/client-communication.scm
@@ -172,9 +172,14 @@
                (derivation-inputs . ,(list->vector derivation-inputs))
                (setup-failures    . ,(list->vector setup-failures))))))))
       (('POST "build" uuid "cancel")
-       (cancel-build build-coordinator uuid)
-       (render-json
-        `((result . "build-canceled"))))
+       (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")))))
       (('POST "build" uuid "update-priority")
        (update-build-priority
         build-coordinator
@@ -584,12 +589,17 @@
                         `((defer-until . ,(date->string defer-until "~1 ~3")))
                         '()))))
 
-(define (send-cancel-build-request
-         coordinator-uri
-         build-id)
+(define* (send-cancel-build-request
+          coordinator-uri
+          build-id
+          #:key (ignore-if-build-required-by-another? #t))
   (send-request coordinator-uri
                 'POST
-                (string-append "/build/" build-id "/cancel")))
+                (string-append "/build/" build-id "/cancel"
+                               "?ignore-if-build-required-by-another="
+                               (if ignore-if-build-required-by-another?
+                                   "true"
+                                   "false"))))
 
 (define (send-update-build-priority-request
          coordinator-uri
diff --git a/guix-build-coordinator/coordinator.scm b/guix-build-coordinator/coordinator.scm
index 5a93d6f..ba489c0 100644
--- a/guix-build-coordinator/coordinator.scm
+++ b/guix-build-coordinator/coordinator.scm
@@ -494,7 +494,8 @@
        (stop-condition
         stop-condition)))))
 
-(define (cancel-build build-coordinator uuid)
+(define* (cancel-build build-coordinator uuid
+                       #:key (ignore-if-build-required-by-another? #t))
   (define datastore (build-coordinator-datastore build-coordinator))
 
   (datastore-call-with-transaction
@@ -509,7 +510,14 @@
        (when (assq-ref build-details 'processed)
          (raise-exception
           (make-exception-with-message
-           "cannot cancel and already processed build"))))
+           "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)
diff --git a/guix-build-coordinator/datastore.scm b/guix-build-coordinator/datastore.scm
index c67d9f1..66440bf 100644
--- a/guix-build-coordinator/datastore.scm
+++ b/guix-build-coordinator/datastore.scm
@@ -41,6 +41,7 @@
 (re-export datastore-list-unbuilt-derivation-outputs)
 (re-export datastore-list-build-outputs)
 (re-export datastore-build-exists-for-derivation-outputs?)
+(re-export datastore-build-required-by-another?)
 (re-export datastore-list-related-derivations-with-no-build-for-outputs)
 (re-export datastore-list-failed-builds-with-blocking-count)
 (re-export datastore-list-builds-for-derivation-recursive-inputs)
diff --git a/guix-build-coordinator/datastore/sqlite.scm b/guix-build-coordinator/datastore/sqlite.scm
index ba44d75..11947e3 100644
--- a/guix-build-coordinator/datastore/sqlite.scm
+++ b/guix-build-coordinator/datastore/sqlite.scm
@@ -26,6 +26,7 @@
             datastore-call-with-transaction
             datastore-store-derivation
             datastore-build-exists-for-derivation-outputs?
+            datastore-build-required-by-another?
             datastore-list-related-derivations-with-no-build-for-outputs
             datastore-list-failed-builds-with-blocking-count
             datastore-list-builds-for-derivation-recursive-inputs
@@ -826,6 +827,46 @@ WHERE derivation_outputs.derivation_id = :derivation_id
              #t
              #f))))))
 
+(define-method (datastore-build-required-by-another?
+                (datastore <sqlite-datastore>)
+                uuid)
+  (call-with-worker-thread
+   (slot-ref datastore 'worker-reader-thread-channel)
+   (lambda (db)
+     (let ((statement
+            (sqlite-prepare
+             db
+             "
+SELECT 1
+FROM builds
+INNER JOIN derivation_outputs
+  ON builds.derivation_id = derivation_outputs.derivation_id
+INNER JOIN outputs ON derivation_outputs.output_id = outputs.id
+INNER JOIN derivation_outputs AS all_derivation_outputs
+  ON outputs.id = all_derivation_outputs.output_id
+INNER JOIN derivation_inputs
+  ON derivation_inputs.derivation_output_id = all_derivation_outputs.id
+INNER JOIN derivations AS dependent_derivations
+  ON dependent_derivations.id = derivation_inputs.derivation_id
+INNER JOIN builds AS dependent_builds
+  ON dependent_builds.derivation_id = dependent_derivations.id
+ AND dependent_builds.processed = 0
+ AND dependent_builds.canceled = 0
+WHERE builds.uuid = :uuid
+"
+             #:cache? #t)))
+
+       (sqlite-bind-arguments
+        statement
+        #:uuid uuid)
+
+       (let ((result (sqlite-step statement)))
+         (sqlite-reset statement)
+
+         (if result
+             #t
+             #f))))))
+
 (define-method (datastore-list-related-derivations-with-no-build-for-outputs
                 (datastore <sqlite-datastore>)
                 derivation)
diff --git a/scripts/guix-build-coordinator.in b/scripts/guix-build-coordinator.in
index 5b7a580..17c8385 100644
--- a/scripts/guix-build-coordinator.in
+++ b/scripts/guix-build-coordinator.in
@@ -269,13 +269,19 @@
                               (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  . ())))
+  `((tags                                . ())
+    (not-tags                            . ())
+    (systems                             . ())
+    (not-systems                         . ())
+    (ignore-if-build-required-by-another . #t)))
 
 (define %build-update-priority-options
   (cons* (option '("new-priority") #t #f
@@ -636,13 +642,19 @@ tags:
                                         (current-error-port))
             (lambda (report)
               (for-each (lambda (id)
-                          (send-cancel-build-request (assq-ref opts 'coordinator)
-                                                     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)))))
        ((build-id)
-        (send-cancel-build-request (assq-ref opts 'coordinator)
-                                   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" "update-priority" rest ...)
    (let ((opts (parse-options (append %client-options
                                       %base-options