aboutsummaryrefslogtreecommitdiff
path: root/scripts
diff options
context:
space:
mode:
authorChristopher Baines <mail@cbaines.net>2023-05-19 13:47:21 +0100
committerChristopher Baines <mail@cbaines.net>2023-05-19 13:47:21 +0100
commit768c5e6d56569eaee46e98b41f5e28f43e424b64 (patch)
tree07774fc58b7a6b819bb1a721d059321d52378e46 /scripts
parentc97163f38f747f3eaebdc19707236810a0b8b047 (diff)
downloadbuild-coordinator-768c5e6d56569eaee46e98b41f5e28f43e424b64.tar
build-coordinator-768c5e6d56569eaee46e98b41f5e28f43e424b64.tar.gz
Change listing builds to work as a stream
Both in terms of getting the data from the database, and sending it to the client. This avoids the use of the after-id and ordering by id when listing builds, which makes listing builds faster. It does mean that the database reads may last for a while (which can be a problem), but maybe that can be addressed in other ways.
Diffstat (limited to 'scripts')
-rw-r--r--scripts/guix-build-coordinator.in144
1 files changed, 56 insertions, 88 deletions
diff --git a/scripts/guix-build-coordinator.in b/scripts/guix-build-coordinator.in
index daa0873..787542c 100644
--- a/scripts/guix-build-coordinator.in
+++ b/scripts/guix-build-coordinator.in
@@ -38,6 +38,7 @@
(srfi srfi-37)
(srfi srfi-43)
(ice-9 match)
+ (ice-9 streams)
(ice-9 suspendable-ports)
(web uri)
(fibers)
@@ -242,8 +243,7 @@
%common-build-filtering-options))
(define %builds-list-option-defaults
- `(,@%common-build-filtering-option-defaults
- (limit . 1000)))
+ `(,@%common-build-filtering-option-defaults))
(define %build-cancel-options
(list (option '("tag") #t #f
@@ -529,24 +529,23 @@ canceled?: ~A
%client-option-defaults
%builds-list-option-defaults)
rest)))
- (let loop ((after-id #f))
- (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 (or after-id (assq-ref opts 'after-id))
- #:limit (assq-ref opts 'limit))))
- (for-each
- (lambda (build-details)
- (simple-format (current-output-port)
- "id: ~A
+ (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
derivation: ~A
processed: ~A
canceled: ~A
@@ -554,31 +553,25 @@ 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")))
- (vector->list (assoc-ref response "builds")))
+ (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))))
- (unless (= (vector-length (assoc-ref response "builds")) 0)
- (loop
- (assoc-ref (vector-ref
- (assoc-ref response "builds")
- (- (vector-length (assoc-ref response "builds")) 1))
- "uuid")))))))
(("build" "show-blocking" rest ...)
(let ((opts (parse-options (append %base-options
%client-options
@@ -608,8 +601,6 @@ tags:
%build-cancel-option-defaults)
rest)))
(define (get-batch)
- (define limit 1000)
-
(simple-format (current-error-port)
"requesting matching builds\n")
(force-output (current-error-port))
@@ -621,17 +612,12 @@ tags:
#: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"))))
+ #:relationship 'no-dependent-builds)))
- (fold
- (lambda (build-details result)
- (cons (assoc-ref build-details "uuid")
- result))
- '()
- (vector->list (assoc-ref response "builds")))))
+ (stream-map
+ (lambda (build-details)
+ (assoc-ref build-details "uuid"))
+ response)))
(match (assq-ref opts 'arguments)
(#f
@@ -689,39 +675,21 @@ tags:
%build-update-priority-option-defaults)
rest)))
(define (find-matching-builds)
- (define limit 1000)
+ (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-<))))
- (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)))))
+ (stream-map
+ (lambda (build-details)
+ (assoc-ref build-details "uuid"))
+ response)))
(match (assq-ref opts 'arguments)
(#f