Guard against canceling builds required by others

4 files changed, 69 insertions, 9 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)