Try to speed up a couple of endpoints by streaming JSON
This commit is contained in:
parent
5a6d8d7261
commit
d452c56bf2
4 changed files with 185 additions and 55 deletions
|
|
@ -42,6 +42,7 @@
|
|||
package-derivation-data-vhash->derivations
|
||||
package-derivation-data-vhash->derivations-and-build-status
|
||||
package-derivation-data-changes
|
||||
package-derivation-data-changes/streaming
|
||||
|
||||
lint-warning-differences-data
|
||||
|
||||
|
|
@ -772,6 +773,81 @@ ORDER BY coalesce(base_packages.name, target_packages.name) ASC, base_packages.v
|
|||
'()
|
||||
target-versions)))
|
||||
|
||||
|
||||
(define (package-derivation-data-changes/streaming names-and-versions
|
||||
base-packages-vhash
|
||||
target-packages-vhash
|
||||
proc)
|
||||
|
||||
(define base-package-details-by-name-and-version
|
||||
(package-data-vhash->package-name-and-version-hash-table base-packages-vhash))
|
||||
|
||||
(define target-package-details-by-name-and-version
|
||||
(package-data-vhash->package-name-and-version-hash-table target-packages-vhash))
|
||||
|
||||
(define (derivation-system-and-target-list->alist lst)
|
||||
(if (null? lst)
|
||||
'()
|
||||
`(,(match (first lst)
|
||||
((derivation-file-name system target builds)
|
||||
`((system . ,system)
|
||||
(target . ,target)
|
||||
(derivation-file-name . ,derivation-file-name)
|
||||
(builds . ,(if (or (and (string? builds)
|
||||
(string-null? builds))
|
||||
(eq? #f builds))
|
||||
#()
|
||||
(json-string->scm builds))))))
|
||||
,@(derivation-system-and-target-list->alist (cdr lst)))))
|
||||
|
||||
(pair-for-each
|
||||
(lambda (pair)
|
||||
(let* ((name-and-version
|
||||
(car pair))
|
||||
(base-packages-entry
|
||||
(hash-ref base-package-details-by-name-and-version
|
||||
name-and-version))
|
||||
(target-packages-entry
|
||||
(hash-ref target-package-details-by-name-and-version
|
||||
name-and-version)))
|
||||
(cond
|
||||
((and base-packages-entry target-packages-entry)
|
||||
(let ((base-derivations (map cdr base-packages-entry))
|
||||
(target-derivations (map cdr target-packages-entry)))
|
||||
(if (equal? base-derivations target-derivations)
|
||||
#f
|
||||
(proc
|
||||
`((name . ,(car name-and-version))
|
||||
(version . ,(cdr name-and-version))
|
||||
(base . ,(list->vector
|
||||
(derivation-system-and-target-list->alist
|
||||
base-derivations)))
|
||||
(target . ,(list->vector
|
||||
(derivation-system-and-target-list->alist
|
||||
target-derivations))))
|
||||
(null? (cdr pair))))))
|
||||
(base-packages-entry
|
||||
(let ((base-derivations (map cdr base-packages-entry)))
|
||||
(proc
|
||||
`((name . ,(car name-and-version))
|
||||
(version . ,(cdr name-and-version))
|
||||
(base . ,(list->vector
|
||||
(derivation-system-and-target-list->alist
|
||||
base-derivations)))
|
||||
(target . ,(list->vector '())))
|
||||
(null? (cdr pair)))))
|
||||
(else
|
||||
(let ((target-derivations (map cdr target-packages-entry)))
|
||||
(proc
|
||||
`((name . ,(car name-and-version))
|
||||
(version . ,(cdr name-and-version))
|
||||
(base . ,(list->vector '()))
|
||||
(target . ,(list->vector
|
||||
(derivation-system-and-target-list->alist
|
||||
target-derivations))))
|
||||
(null? (cdr pair))))))))
|
||||
names-and-versions))
|
||||
|
||||
(define (package-derivation-data-changes names-and-versions
|
||||
base-packages-vhash
|
||||
target-packages-vhash)
|
||||
|
|
|
|||
|
|
@ -21,9 +21,11 @@
|
|||
#:use-module (srfi srfi-19)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (ice-9 vlist)
|
||||
#:use-module (ice-9 textual-ports)
|
||||
#:use-module (texinfo)
|
||||
#:use-module (texinfo html)
|
||||
#:use-module (texinfo plain-text)
|
||||
#:use-module (json)
|
||||
#:use-module (knots parallelism)
|
||||
#:use-module (knots resource-pool)
|
||||
#:use-module (guix-data-service utils)
|
||||
|
|
@ -718,40 +720,54 @@
|
|||
(let-values
|
||||
(((base-packages-vhash target-packages-vhash)
|
||||
(package-derivation-data->package-derivation-data-vhashes data)))
|
||||
(let ((derivation-changes
|
||||
(package-derivation-data-changes names-and-versions
|
||||
base-packages-vhash
|
||||
target-packages-vhash)))
|
||||
(case (most-appropriate-mime-type
|
||||
'(application/json text/html)
|
||||
mime-types)
|
||||
((application/json)
|
||||
(render-json
|
||||
`((revisions
|
||||
. ((base
|
||||
. ((commit . ,base-commit)))
|
||||
(target
|
||||
. ((commit . ,target-commit)))))
|
||||
(derivation_changes
|
||||
. ,derivation-changes))
|
||||
#:stream? #t))
|
||||
(else
|
||||
(fibers-let ((systems
|
||||
(call-with-resource-from-pool (connection-pool)
|
||||
list-systems))
|
||||
(targets
|
||||
(call-with-resource-from-pool (connection-pool)
|
||||
valid-targets)))
|
||||
(render-html
|
||||
#:sxml (compare/package-derivations
|
||||
query-parameters
|
||||
'revision
|
||||
systems
|
||||
(valid-targets->options targets)
|
||||
build-status-strings
|
||||
build-server-urls
|
||||
derivation-changes)
|
||||
#:stream? #t)))))))))))
|
||||
(case (most-appropriate-mime-type
|
||||
'(application/json text/html)
|
||||
mime-types)
|
||||
((application/json)
|
||||
(render-json
|
||||
(lambda (port)
|
||||
(scm-alist->streaming-json
|
||||
`((revisions . ((base
|
||||
. ((commit . ,base-commit)))
|
||||
(target
|
||||
. ((commit . ,target-commit)))))
|
||||
(derivation_changes
|
||||
.
|
||||
,(lambda (port)
|
||||
(put-string port "[")
|
||||
(package-derivation-data-changes/streaming
|
||||
names-and-versions
|
||||
base-packages-vhash
|
||||
target-packages-vhash
|
||||
(lambda (data last?)
|
||||
(scm->json data port #:unicode #t)
|
||||
(unless last?
|
||||
(put-string port ","))))
|
||||
(put-string port "]"))))
|
||||
port))
|
||||
#:stream? #t))
|
||||
(else
|
||||
(fibers-let ((derivation-changes
|
||||
(package-derivation-data-changes
|
||||
names-and-versions
|
||||
base-packages-vhash
|
||||
target-packages-vhash))
|
||||
(systems
|
||||
(call-with-resource-from-pool (connection-pool)
|
||||
list-systems))
|
||||
(targets
|
||||
(call-with-resource-from-pool (connection-pool)
|
||||
valid-targets)))
|
||||
(render-html
|
||||
#:sxml (compare/package-derivations
|
||||
query-parameters
|
||||
'revision
|
||||
systems
|
||||
(valid-targets->options targets)
|
||||
build-status-strings
|
||||
build-server-urls
|
||||
derivation-changes)
|
||||
#:stream? #t))))))))))
|
||||
|
||||
(define (render-compare-by-datetime/package-derivations mime-types
|
||||
query-parameters)
|
||||
|
|
|
|||
|
|
@ -25,6 +25,7 @@
|
|||
#:use-module (srfi srfi-26)
|
||||
#:use-module (ice-9 ftw)
|
||||
#:use-module (ice-9 iconv)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (ice-9 binary-ports)
|
||||
#:use-module (ice-9 textual-ports)
|
||||
#:use-module (web request)
|
||||
|
|
@ -37,6 +38,7 @@
|
|||
#:export (static-asset-from-store-renderer
|
||||
render-static-asset
|
||||
render-html
|
||||
scm-alist->streaming-json
|
||||
render-json
|
||||
render-text
|
||||
not-found
|
||||
|
|
@ -158,6 +160,25 @@
|
|||
(lambda (port)
|
||||
(sxml->html sxml port)))))))
|
||||
|
||||
(define* (scm-alist->streaming-json alist port #:key unicode)
|
||||
(put-string port "{")
|
||||
(pair-for-each
|
||||
(lambda (pair)
|
||||
(match (car pair)
|
||||
((k . v)
|
||||
(put-string port "\"")
|
||||
(put-string port (if (string? k)
|
||||
k
|
||||
(symbol->string k)))
|
||||
(put-string port "\":")
|
||||
(if (procedure? v)
|
||||
(v port)
|
||||
(scm->json v port #:unicode unicode))))
|
||||
(unless (null? (cdr pair))
|
||||
(put-string port ",")))
|
||||
alist)
|
||||
(put-string port "}"))
|
||||
|
||||
(define* (render-json json #:key (extra-headers '())
|
||||
(code 200)
|
||||
stream?)
|
||||
|
|
@ -172,7 +193,9 @@
|
|||
json
|
||||
(if stream?
|
||||
(lambda (port)
|
||||
(scm->json json port #:unicode #t))
|
||||
(if (procedure? json)
|
||||
(json port)
|
||||
(scm->json json port #:unicode #t)))
|
||||
(call-with-encoded-output-string
|
||||
"utf-8"
|
||||
(lambda (port)
|
||||
|
|
|
|||
|
|
@ -18,6 +18,7 @@
|
|||
(define-module (guix-data-service web revision controller)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (ice-9 textual-ports)
|
||||
#:use-module (web uri)
|
||||
#:use-module (web request)
|
||||
#:use-module (texinfo)
|
||||
|
|
@ -1134,26 +1135,40 @@
|
|||
mime-types)
|
||||
((application/json)
|
||||
(render-json
|
||||
`((derivations . ,(list->vector
|
||||
(map (match-lambda
|
||||
((derivation system target)
|
||||
`((derivation . ,derivation)
|
||||
,@(if (member "system" fields)
|
||||
`((system . ,system))
|
||||
'())
|
||||
,@(if (member "target" fields)
|
||||
`((target . ,target))
|
||||
'())))
|
||||
((derivation system target builds)
|
||||
`((derivation . ,derivation)
|
||||
,@(if (member "system" fields)
|
||||
`((system . ,system))
|
||||
'())
|
||||
,@(if (member "target" fields)
|
||||
`((target . ,target))
|
||||
'())
|
||||
(builds . ,builds))))
|
||||
derivations))))
|
||||
(lambda (port)
|
||||
(scm-alist->streaming-json
|
||||
`((derivations
|
||||
.
|
||||
,(lambda (port)
|
||||
(put-string port "[")
|
||||
(pair-for-each
|
||||
(lambda (pair)
|
||||
(scm->json
|
||||
(match (car pair)
|
||||
((derivation system target)
|
||||
`((derivation . ,derivation)
|
||||
,@(if (member "system" fields)
|
||||
`((system . ,system))
|
||||
'())
|
||||
,@(if (member "target" fields)
|
||||
`((target . ,target))
|
||||
'())))
|
||||
((derivation system target builds)
|
||||
`((derivation . ,derivation)
|
||||
,@(if (member "system" fields)
|
||||
`((system . ,system))
|
||||
'())
|
||||
,@(if (member "target" fields)
|
||||
`((target . ,target))
|
||||
'())
|
||||
(builds . ,builds))))
|
||||
port
|
||||
#:unicode #t)
|
||||
(unless (null? (cdr pair))
|
||||
(put-char port #\,)))
|
||||
derivations)
|
||||
(put-string port "]"))))
|
||||
port))
|
||||
#:stream? #t))
|
||||
(else
|
||||
(fibers-let ((systems
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue