aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--guix-build-coordinator/client-communication.scm60
-rw-r--r--scripts/guix-build-coordinator.in127
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