diff options
Diffstat (limited to 'scripts/guix-build-coordinator.in')
| -rw-r--r-- | scripts/guix-build-coordinator.in | 111 |
1 files changed, 48 insertions, 63 deletions
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 |