diff options
Diffstat (limited to 'guix-build-coordinator/client-communication.scm')
| -rw-r--r-- | guix-build-coordinator/client-communication.scm | 228 |
1 files changed, 125 insertions, 103 deletions
diff --git a/guix-build-coordinator/client-communication.scm b/guix-build-coordinator/client-communication.scm index 67d8f65..2df9b32 100644 --- a/guix-build-coordinator/client-communication.scm +++ b/guix-build-coordinator/client-communication.scm @@ -25,6 +25,7 @@ #:use-module (srfi srfi-43) #:use-module (ice-9 format) #:use-module (ice-9 match) + #:use-module (ice-9 streams) #:use-module (ice-9 exceptions) #:use-module (rnrs bytevectors) #:use-module (json) @@ -327,105 +328,109 @@ `((error . 404)) #:code 404)))) (('GET "builds") - (let ((query-parameters (request-query-parameters request))) - (render-json - `((builds - . ,(list->vector - (map - (lambda (build-details) - `(,@(alist-delete - 'created-at - (alist-delete - 'end-time - build-details)) - (created-at . ,(or - (and=> - (assq-ref build-details 'created-at) - (lambda (time) - (strftime "%F %T" time))) - 'null)) - (end-time . ,(or (and=> - (assq-ref build-details 'end-time) + (let* ((query-parameters (request-query-parameters request)) + (fold-builds-args + (list + #:tags + (filter-map (match-lambda + ((key . value) + (if (eq? key 'tag) + (match (string-split value #\:) + ((tag-key tag-value) + (cons tag-key tag-value)) + ((tag-key) tag-key)) + #f))) + query-parameters) + #:not-tags + (filter-map (match-lambda + ((key . value) + (if (eq? key 'not_tag) + (match (string-split value #\:) + ((tag-key tag-value) + (cons tag-key tag-value)) + ((tag_key) tag_key)) + #f))) + query-parameters) + #:systems + (filter-map (match-lambda + ((key . value) + (if (eq? key 'system) + value + #f))) + query-parameters) + #:not-systems + (filter-map (match-lambda + ((key . value) + (if (eq? key 'not-system) + value + #f))) + query-parameters) + #:processed + (match (assq 'processed query-parameters) + ((_ . val) + (string=? val "true")) + (#f 'unset)) + #:canceled + (match (assq 'canceled query-parameters) + ((_ . val) + (string=? val "true")) + (#f 'unset)) + #:priority-> + (or (and=> (assq-ref query-parameters 'priority_gt) + string->number) + 'unset) + #:priority-< + (or (and=> (assq-ref query-parameters 'priority_lt) + string->number) + 'unset) + #:relationship + (or (and=> (assq-ref query-parameters 'relationship) + string->symbol) + 'unset) + #:after-id + (assq-ref query-parameters 'after_id) + #:limit + (and=> (assq-ref query-parameters 'limit) + string->number)))) + + (list + (build-response + #:code 200 + #:headers '((content-type . (application/json-seq)))) + (lambda (port) + (apply datastore-fold-builds + datastore + (lambda (build-details _) + (scm->json-seq + `((,@(alist-delete + 'created-at + (alist-delete + 'end-time + build-details)) + (created-at . ,(or + (and=> + (assq-ref build-details 'created-at) (lambda (time) (strftime "%F %T" time))) 'null)) - (tags . ,(vector-map - (lambda (_ tag) - (match tag - ((key . value) - `((key . ,key) - (value . ,value))))) - (datastore-fetch-build-tags - datastore - (assq-ref build-details 'uuid)))))) - (datastore-list-builds - datastore - #:tags - (filter-map (match-lambda - ((key . value) - (if (eq? key 'tag) - (match (string-split value #\:) - ((tag-key tag-value) - (cons tag-key tag-value)) - ((tag-key) tag-key)) - #f))) - query-parameters) - #:not-tags - (filter-map (match-lambda - ((key . value) - (if (eq? key 'not_tag) - (match (string-split value #\:) - ((tag-key tag-value) - (cons tag-key tag-value)) - ((tag_key) tag_key)) - #f))) - query-parameters) - #:systems - (filter-map (match-lambda - ((key . value) - (if (eq? key 'system) - value - #f))) - query-parameters) - #:not-systems - (filter-map (match-lambda - ((key . value) - (if (eq? key 'not-system) - value - #f))) - query-parameters) - #:processed - (match (assq 'processed query-parameters) - ((_ . val) - (string=? val "true")) - (#f 'unset)) - #:canceled - (match (assq 'canceled query-parameters) - ((_ . val) - (string=? val "true")) - (#f 'unset)) - #:priority-> - (or (and=> (assq-ref query-parameters 'priority_gt) - string->number) - 'unset) - #:priority-< - (or (and=> (assq-ref query-parameters 'priority_lt) - string->number) - 'unset) - #:relationship - (or (and=> (assq-ref query-parameters 'relationship) - string->symbol) - 'unset) - #:after-id - (assq-ref query-parameters 'after_id) - #:limit - (or (and=> (assq-ref query-parameters 'limit) - (lambda (val) - ;; Don't allow a high limit, as that could - ;; cause the query to run for a long time - (min (string->number val) - 100))) - 100))))))))) + (end-time . ,(or (and=> + (assq-ref build-details 'end-time) + (lambda (time) + (strftime "%F %T" time))) + 'null)) + (tags . ,(vector-map + (lambda (_ tag) + (match tag + ((key . value) + `((key . ,key) + (value . ,value))))) + (datastore-fetch-build-tags + datastore + (assq-ref build-details 'uuid)))))) + port) + #t) + #t + fold-builds-args))))) (('POST "builds") (let ((derivation-file (assoc-ref body "derivation")) (substitute-urls @@ -653,7 +658,8 @@ (string-append coordinator-uri path)) #:method method #:body (and=> request-body scm->json-string) - #:decode-body? #f))) + #:decode-body? #f + #:streaming? #t))) (if (>= (response-code response) 400) (begin (simple-format @@ -665,8 +671,11 @@ (lambda () (if (equal? '(application/json (charset . "utf-8")) (response-content-type response)) - (json-string->scm (utf8->string body)) - (utf8->string body))) + (json-string->scm + (utf8->string + (read-response-body response))) + (utf8->string + (read-response-body response)))) (lambda (key . args) (simple-format (current-error-port) @@ -676,9 +685,22 @@ (raise-exception (make-exception-with-message body)))) - (values - (json-string->scm (utf8->string body)) - response)))) + + (begin + (set-port-encoding! body "UTF-8") + + (values + (if (equal? '(application/json-seq) + (response-content-type response)) + (json-seq->scm + body + ;; TODO I would like to use 'throw, but it always raises an + ;; exception, so this needs fixing upstream first + #:handle-truncate 'replace) + (json-string->scm + (utf8->string + (read-response-body response)))) + response))))) (define* (send-submit-build-request coordinator-uri @@ -760,7 +782,7 @@ (priority-< 'unset) (relationship 'unset) (after-id #f) - (limit 100)) + (limit #f)) (let ((query-parameters `(,@(if (null? tags) '() |