From a129cc97756eb8f69e909a3aadd954c947561810 Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Tue, 22 Dec 2020 18:29:35 +0000
Subject: Implement canceling builds in bulk

Through the command line interface.
---
 scripts/guix-build-coordinator.in | 92 ++++++++++++++++++++++++++++++++++++---
 1 file changed, 87 insertions(+), 5 deletions(-)

(limited to 'scripts')

diff --git a/scripts/guix-build-coordinator.in b/scripts/guix-build-coordinator.in
index cb52b41..9fb6edf 100644
--- a/scripts/guix-build-coordinator.in
+++ b/scripts/guix-build-coordinator.in
@@ -33,6 +33,7 @@
              (fibers conditions)
              (prometheus)
              ((guix ui) #:select (read/eval))
+             (guix progress)
              (guix derivations)
              (guix-build-coordinator hooks)
              (guix-build-coordinator utils)
@@ -169,6 +170,34 @@
     (canceled     . 'unset)
     (limit        . 1000)))
 
+(define %build-cancel-options
+  (list (option '("tag") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'tags
+                              (cons (match (string-split arg #\=)
+                                      ((key value) (cons key value)))
+                                    (or (assq-ref result 'tags)
+                                        '()))
+                              (alist-delete 'tags result))))
+        (option '("not-tag") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'not-tags
+                              (cons (match (string-split arg #\=)
+                                      ((key value) (cons key value)))
+                                    (or (assq-ref result 'not-tags)
+                                        '()))
+                              (alist-delete 'not-tags result))))
+        (option '("processed") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'processed
+                              (string=? arg "true")
+                              result)))))
+
+(define %build-cancel-option-defaults
+  `((tags         . ())
+    (not-tags     . ())
+    (processed    . 'unset)))
+
 (define %service-options
   (list (option '("pid-file") #t #f
                 (lambda (opt name arg result)
@@ -402,13 +431,66 @@ tags:
            (assoc-ref build "derivation_name")))
         (vector->list (assoc-ref response "builds"))))))
   (("build" "cancel" rest ...)
-   (let ((opts (parse-options (append %build-options
-                                      %base-options)
-                              (append %build-option-defaults
-                                      %client-option-defaults
-                                      %base-option-defaults)
+   (let ((opts (parse-options (append %client-options
+                                      %base-options
+                                      %build-cancel-options)
+                              (append %client-option-defaults
+                                      %base-option-defaults
+                                      %build-cancel-option-defaults)
                               rest)))
+     (define (find-matching-builds)
+       (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)
+                           #:processed (assq-ref opts 'processed)
+                           #: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)))))
+
      (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)
+                          (report))
+                        matching-builds)))))
        ((build-id)
         (send-cancel-build-request (assq-ref opts 'coordinator)
                                    build-id)))))
-- 
cgit v1.2.3