diff options
| -rw-r--r-- | scripts/guix-build-coordinator.in | 92 |
1 files changed, 87 insertions, 5 deletions
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))))) |