diff options
author | Christopher Baines <mail@cbaines.net> | 2022-07-07 22:11:38 +0100 |
---|---|---|
committer | Christopher Baines <mail@cbaines.net> | 2022-07-07 22:11:38 +0100 |
commit | 3175ac21c2eea043297e9a47e374635baad03c79 (patch) | |
tree | ec080881eae8fae934180556f11770c3a68ae668 | |
parent | 08f1ecda5d7e5ef81c92380bcca3960267fa9199 (diff) | |
download | build-coordinator-3175ac21c2eea043297e9a47e374635baad03c79.tar build-coordinator-3175ac21c2eea043297e9a47e374635baad03c79.tar.gz |
Support updating build priorities through the command line
-rw-r--r-- | guix-build-coordinator/client-communication.scm | 18 | ||||
-rw-r--r-- | scripts/guix-build-coordinator.in | 230 |
2 files changed, 178 insertions, 70 deletions
diff --git a/guix-build-coordinator/client-communication.scm b/guix-build-coordinator/client-communication.scm index 2453800..9c13e76 100644 --- a/guix-build-coordinator/client-communication.scm +++ b/guix-build-coordinator/client-communication.scm @@ -45,6 +45,7 @@ send-submit-build-request send-cancel-build-request + send-update-build-priority-request request-build-details request-builds-list request-output-details @@ -173,6 +174,14 @@ (cancel-build build-coordinator uuid) (render-json `((result . "build-canceled")))) + (('POST "build" uuid "update-priority") + (update-build-priority + build-coordinator + uuid + (assoc-ref body "new_priority")) + + (render-json + `((result . "build-priority-updated")))) (('GET "builds" "blocking") (let ((query-parameters (request-query-parameters request))) (render-json @@ -574,6 +583,15 @@ 'POST (string-append "/build/" build-id "/cancel"))) +(define (send-update-build-priority-request + coordinator-uri + build-id + new-priority) + (send-request coordinator-uri + 'POST + (string-append "/build/" build-id "/update-priority") + `((new_priority . ,new-priority)))) + (define (request-build-details coordinator-uri uuid) (send-request coordinator-uri diff --git a/scripts/guix-build-coordinator.in b/scripts/guix-build-coordinator.in index 937ee4b..2483c7e 100644 --- a/scripts/guix-build-coordinator.in +++ b/scripts/guix-build-coordinator.in @@ -141,75 +141,66 @@ (ensure-all-related-derivation-outputs-have-builds . #f) (tags . ()))) -(define %builds-list-options - (list (option '("tag") #t #f - (lambda (opt name arg result) - (alist-cons 'tags - (cons (match (string-split arg #\=) - ((key value) - `((key . ,key) - (value . ,value))) - ((key) key)) - (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) - `((key . ,key) - (value . ,value))) - ((key) key)) - (or (assq-ref result 'not-tags) - '())) - (alist-delete 'not-tags result)))) - (option '("system") #t #f - (lambda (opt name arg result) - (alist-cons 'systems - (cons arg - (or (assq-ref result 'systems) - '())) - (alist-delete 'systems result)))) - (option '("not-system") #t #f - (lambda (opt name arg result) - (alist-cons 'not-systems - (cons arg - (or (assq-ref result 'not-systems) - '())) - (alist-delete 'not-systems result)))) - (option '("processed") #t #f - (lambda (opt name arg result) - (alist-cons 'processed - (string=? arg "true") - result))) - (option '("canceled") #t #f - (lambda (opt name arg result) - (alist-cons 'canceled - (string=? arg "true") - result))) - (option '("priority-gt") #t #f - (lambda (opt name arg result) - (alist-cons 'priority-> - (string->number arg) - result))) - (option '("priority-lt") #t #f - (lambda (opt name arg result) - (alist-cons 'priority-< - (string->number arg) - result))) - (option '("after-id") #t #f - (lambda (opt name arg result) - (alist-cons 'after-id - arg - result))) - (option '("limit") #t #f - (lambda (opt name arg result) - (alist-cons 'limit - (string->number arg) - result))))) - -(define %builds-list-option-defaults +(define %common-build-filtering-options + (list + (option '("tag") #t #f + (lambda (opt name arg result) + (alist-cons 'tags + (cons (match (string-split arg #\=) + ((key value) + `((key . ,key) + (value . ,value))) + ((key) key)) + (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) + `((key . ,key) + (value . ,value))) + ((key) key)) + (or (assq-ref result 'not-tags) + '())) + (alist-delete 'not-tags result)))) + (option '("system") #t #f + (lambda (opt name arg result) + (alist-cons 'systems + (cons arg + (or (assq-ref result 'systems) + '())) + (alist-delete 'systems result)))) + (option '("not-system") #t #f + (lambda (opt name arg result) + (alist-cons 'not-systems + (cons arg + (or (assq-ref result 'not-systems) + '())) + (alist-delete 'not-systems result)))) + (option '("processed") #t #f + (lambda (opt name arg result) + (alist-cons 'processed + (string=? arg "true") + result))) + (option '("canceled") #t #f + (lambda (opt name arg result) + (alist-cons 'canceled + (string=? arg "true") + result))) + (option '("priority-gt") #t #f + (lambda (opt name arg result) + (alist-cons 'priority-> + (string->number arg) + result))) + (option '("priority-lt") #t #f + (lambda (opt name arg result) + (alist-cons 'priority-< + (string->number arg) + result))))) + +(define %common-build-filtering-option-defaults `((tags . ()) (not-tags . ()) (systems . ()) @@ -217,7 +208,23 @@ (processed . 'unset) (canceled . 'unset) (priority-> . 'unset) - (priority-< . 'unset) + (priority-< . 'unset))) + +(define %builds-list-options + (cons* (option '("after-id") #t #f + (lambda (opt name arg result) + (alist-cons 'after-id + arg + result))) + (option '("limit") #t #f + (lambda (opt name arg result) + (alist-cons 'limit + (string->number arg) + result))) + %common-build-filtering-options)) + +(define %builds-list-option-defaults + `(,@%common-build-filtering-option-defaults (limit . 1000))) (define %build-cancel-options @@ -264,6 +271,17 @@ (systems . ()) (not-systems . ()))) +(define %build-update-priority-options + (cons* (option '("new-priority") #t #f + (lambda (opt name arg result) + (alist-cons 'new-priority + (string->number arg) + (alist-delete 'new-priority result)))) + %common-build-filtering-options)) + +(define %build-update-priority-option-defaults + %common-build-filtering-option-defaults) + (define %build-show-blocking-options (list (option '("system") #t #f (lambda (opt name arg result) @@ -618,6 +636,78 @@ tags: ((build-id) (send-cancel-build-request (assq-ref opts 'coordinator) build-id))))) + (("build" "update-priority" rest ...) + (let ((opts (parse-options (append %client-options + %base-options + %build-update-priority-options) + (append %client-option-defaults + %base-option-defaults + %build-update-priority-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) + #:systems (assq-ref opts 'systems) + #:not-systems (assq-ref opts 'not-systems) + #:processed #f + #:canceled #f + #:priority-> (assq-ref opts 'priority->) + #:priority-< (assq-ref opts 'priority-<) + #: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 + "updating priorities for ~A builds" count) + (current-error-port)) + (lambda (report) + (for-each (lambda (id) + (send-update-build-priority-request + (assq-ref opts 'coordinator) + id + (assq-ref opts 'new-priority)) + (report)) + matching-builds))))) + ((build-id) + (send-update-build-priority-request (assq-ref opts 'coordinator) + build-id + (assq-ref opts 'new-priority)))))) (("build" rest ...) (let ((opts (parse-options (append %build-options %base-options) |