diff options
| -rw-r--r-- | guix-build-coordinator/client-communication.scm | 60 | ||||
| -rw-r--r-- | scripts/guix-build-coordinator.in | 127 |
2 files changed, 99 insertions, 88 deletions
diff --git a/guix-build-coordinator/client-communication.scm b/guix-build-coordinator/client-communication.scm index 61b8731..21d9e67 100644 --- a/guix-build-coordinator/client-communication.scm +++ b/guix-build-coordinator/client-communication.scm @@ -48,8 +48,8 @@ send-submit-build-request send-cancel-build-request send-update-build-priority-request + fold-builds request-build-details - request-builds-list request-output-details request-agent-details request-agent-build-allocation-plan @@ -786,19 +786,21 @@ 'GET (string-append "/build/" uuid))) -(define* (request-builds-list coordinator-uri - #:key - (tags '()) - (not-tags '()) - (systems '()) - (not-systems '()) - (processed 'unset) - (canceled 'unset) - (priority-> 'unset) - (priority-< 'unset) - (relationship 'unset) - (after-id #f) - (limit #f)) +(define* (fold-builds coordinator-uri + proc + init + #:key + (tags '()) + (not-tags '()) + (systems '()) + (not-systems '()) + (processed 'unset) + (canceled 'unset) + (priority-> 'unset) + (priority-< 'unset) + (relationship 'unset) + (after-id #f) + (limit #f)) (let ((query-parameters `(,@(if (null? tags) '() @@ -853,15 +855,27 @@ ,@(if limit (list (simple-format #f "limit=~A" limit)) '())))) - (send-request coordinator-uri - 'GET - (string-append - "/builds" - (if (null? query-parameters) - "" - (string-append - "?" - (string-join query-parameters "&"))))))) + (let ((builds-stream + response + (send-request coordinator-uri + 'GET + (string-append + "/builds" + (if (null? query-parameters) + "" + (string-append + "?" + (string-join query-parameters "&"))))))) + (with-exception-handler + (lambda (exn) + (close-port + (response-port response)) + (raise-exception exn)) + (lambda () + (stream-fold proc init builds-stream) + (close-port + (response-port response)))) + #:unwind? #t))) (define (request-output-details coordinator-uri output) diff --git a/scripts/guix-build-coordinator.in b/scripts/guix-build-coordinator.in index a6e87c7..655e3ce 100644 --- a/scripts/guix-build-coordinator.in +++ b/scripts/guix-build-coordinator.in @@ -536,23 +536,11 @@ canceled?: ~A %client-option-defaults %builds-list-option-defaults) rest))) - (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 (assq-ref opts 'processed) - #:canceled (assq-ref opts 'canceled) - #:priority-> (assq-ref opts 'priority->) - #:priority-< (assq-ref opts 'priority-<) - #:relationship (assq-ref opts 'relationship) - #:after-id (assq-ref opts 'after-id) - #:limit (assq-ref opts 'limit)))) - (stream-for-each - (lambda (build-details) - (simple-format (current-output-port) - "id: ~A + (fold-builds + (assq-ref opts 'coordinator) + (lambda (build-details _) + (simple-format (current-output-port) + "id: ~A derivation: ~A processed: ~A canceled: ~A @@ -560,24 +548,36 @@ priority: ~A tags: ~A \n" - (assoc-ref build-details "uuid") - (assoc-ref build-details "derivation-name") - (if (assoc-ref build-details "processed") - "true" - "false") - (if (assoc-ref build-details "canceled") - "true" - "false") - (assoc-ref build-details "priority") - (string-join - (map (lambda (tag) - (let ((key (assoc-ref tag "key")) - (val (assoc-ref tag "value"))) - (string-append " " key ": " val))) - (vector->list - (assoc-ref build-details "tags"))) - "\n"))) - response)))) + (assoc-ref build-details "uuid") + (assoc-ref build-details "derivation-name") + (if (assoc-ref build-details "processed") + "true" + "false") + (if (assoc-ref build-details "canceled") + "true" + "false") + (assoc-ref build-details "priority") + (string-join + (map (lambda (tag) + (let ((key (assoc-ref tag "key")) + (val (assoc-ref tag "value"))) + (string-append " " key ": " val))) + (vector->list + (assoc-ref build-details "tags"))) + "\n")) + #f) + #f + #: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 (assq-ref opts 'processed) + #:canceled (assq-ref opts 'canceled) + #:priority-> (assq-ref opts 'priority->) + #:priority-< (assq-ref opts 'priority-<) + #:relationship (assq-ref opts 'relationship) + #:after-id (assq-ref opts 'after-id) + #:limit (assq-ref opts 'limit)))) (("build" "show-blocking" rest ...) (let ((opts (parse-options (append %base-options @@ -611,21 +611,19 @@ tags: (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 (assq-ref opts 'relationship)))) - - (stream->list - (stream-map - (lambda (build-details) - (assoc-ref build-details "uuid")) - response)))) + (fold-builds + (assq-ref opts 'coordinator) + (lambda (build-details result) + (cons (assoc-ref build-details "uuid") + result)) + '() + #: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 (assq-ref opts 'relationship))) (match (assq-ref opts 'arguments) (#f @@ -687,21 +685,20 @@ tags: %build-update-priority-option-defaults) rest))) (define (find-matching-builds) - (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-<)))) - - (stream-map - (lambda (build-details) - (assoc-ref build-details "uuid")) - response))) + (fold-builds + (assq-ref opts 'coordinator) + (lambda (build-details result) + (cons (assoc-ref build-details "uuid") + result)) + '() + #: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-<))) (match (assq-ref opts 'arguments) (#f |