Replace request-builds-list by fold-builds

As this can wait until the stream is finished and properly close the port.

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