aboutsummaryrefslogtreecommitdiff
path: root/scripts
diff options
context:
space:
mode:
authorChristopher Baines <mail@cbaines.net>2023-02-21 11:44:22 +0000
committerChristopher Baines <mail@cbaines.net>2023-02-21 11:44:22 +0000
commit811b3988c89874704dcd74d66105baef36a34db4 (patch)
treeb96ae7db0983b3450a79408e75b3fc5ee5b82ae4 /scripts
parent9920e359bb0c8e9c97f8eaf53219578d49b4a984 (diff)
downloadbuild-coordinator-811b3988c89874704dcd74d66105baef36a34db4.tar
build-coordinator-811b3988c89874704dcd74d66105baef36a34db4.tar.gz
Rework canceling builds
Previously there were some protections introduced against canceling builds that were required by other builds, but this change wasn't quite complete as at least the command line interface wasn't updated to take this in to account. This commit updates the command line interface, as well as improving the controller.
Diffstat (limited to 'scripts')
-rw-r--r--scripts/guix-build-coordinator.in111
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