cbaines/guix-data-service
1
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Try to speed up a couple of endpoints by streaming JSON

Browse source
This commit is contained in:
Christopher Baines 2025-06-30 19:23:42 +02:00
parent 5a6d8d7261
commit d452c56bf2
4 changed files with 185 additions and 55 deletions
Download patch file Download diff file Expand all files Collapse all files

76
guix-data-service/comparison.scm
View file

@ -42,6 +42,7 @@
package-derivation-data-vhash->derivations package-derivation-data-vhash->derivations
package-derivation-data-vhash->derivations-and-build-status package-derivation-data-vhash->derivations-and-build-status
package-derivation-data-changes package-derivation-data-changes
package-derivation-data-changes/streaming
lint-warning-differences-data lint-warning-differences-data
@ -772,6 +773,81 @@ ORDER BY coalesce(base_packages.name, target_packages.name) ASC, base_packages.v
'() '()
target-versions))) 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 (define (package-derivation-data-changes names-and-versions
base-packages-vhash base-packages-vhash
target-packages-vhash) target-packages-vhash)

84
guix-data-service/web/compare/controller.scm
View file

@ -21,9 +21,11 @@
#:use-module (srfi srfi-19) #:use-module (srfi srfi-19)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (ice-9 vlist) #:use-module (ice-9 vlist)
#:use-module (ice-9 textual-ports)
#:use-module (texinfo) #:use-module (texinfo)
#:use-module (texinfo html) #:use-module (texinfo html)
#:use-module (texinfo plain-text) #:use-module (texinfo plain-text)
#:use-module (json)
#:use-module (knots parallelism) #:use-module (knots parallelism)
#:use-module (knots resource-pool) #:use-module (knots resource-pool)
#:use-module (guix-data-service utils) #:use-module (guix-data-service utils)
@ -718,40 +720,54 @@
(let-values (let-values
(((base-packages-vhash target-packages-vhash) (((base-packages-vhash target-packages-vhash)
(package-derivation-data->package-derivation-data-vhashes data))) (package-derivation-data->package-derivation-data-vhashes data)))
(let ((derivation-changes (case (most-appropriate-mime-type
(package-derivation-data-changes names-and-versions '(application/json text/html)
base-packages-vhash mime-types)
target-packages-vhash))) ((application/json)
(case (most-appropriate-mime-type (render-json
'(application/json text/html) (lambda (port)
mime-types) (scm-alist->streaming-json
((application/json) `((revisions . ((base
(render-json . ((commit . ,base-commit)))
`((revisions (target
. ((base . ((commit . ,target-commit)))))
. ((commit . ,base-commit))) (derivation_changes
(target .
. ((commit . ,target-commit))))) ,(lambda (port)
(derivation_changes (put-string port "[")
. ,derivation-changes)) (package-derivation-data-changes/streaming
#:stream? #t)) names-and-versions
(else base-packages-vhash
(fibers-let ((systems target-packages-vhash
(call-with-resource-from-pool (connection-pool) (lambda (data last?)
list-systems)) (scm->json data port #:unicode #t)
(targets (unless last?
(call-with-resource-from-pool (connection-pool) (put-string port ","))))
valid-targets))) (put-string port "]"))))
(render-html port))
#:sxml (compare/package-derivations #:stream? #t))
query-parameters (else
'revision (fibers-let ((derivation-changes
systems (package-derivation-data-changes
(valid-targets->options targets) names-and-versions
build-status-strings base-packages-vhash
build-server-urls target-packages-vhash))
derivation-changes) (systems
#:stream? #t))))))))))) (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 (define (render-compare-by-datetime/package-derivations mime-types
query-parameters) query-parameters)

25
guix-data-service/web/render.scm
View file

@ -25,6 +25,7 @@
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:use-module (ice-9 ftw) #:use-module (ice-9 ftw)
#:use-module (ice-9 iconv) #:use-module (ice-9 iconv)
#:use-module (ice-9 match)
#:use-module (ice-9 binary-ports) #:use-module (ice-9 binary-ports)
#:use-module (ice-9 textual-ports) #:use-module (ice-9 textual-ports)
#:use-module (web request) #:use-module (web request)
@ -37,6 +38,7 @@
#:export (static-asset-from-store-renderer #:export (static-asset-from-store-renderer
render-static-asset render-static-asset
render-html render-html
scm-alist->streaming-json
render-json render-json
render-text render-text
not-found not-found
@ -158,6 +160,25 @@
(lambda (port) (lambda (port)
(sxml->html sxml 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 '()) (define* (render-json json #:key (extra-headers '())
(code 200) (code 200)
stream?) stream?)
@ -172,7 +193,9 @@
json json
(if stream? (if stream?
(lambda (port) (lambda (port)
(scm->json json port #:unicode #t)) (if (procedure? json)
(json port)
(scm->json json port #:unicode #t)))
(call-with-encoded-output-string (call-with-encoded-output-string
"utf-8" "utf-8"
(lambda (port) (lambda (port)

55
guix-data-service/web/revision/controller.scm
View file

@ -18,6 +18,7 @@
(define-module (guix-data-service web revision controller) (define-module (guix-data-service web revision controller)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (ice-9 textual-ports)
#:use-module (web uri) #:use-module (web uri)
#:use-module (web request) #:use-module (web request)
#:use-module (texinfo) #:use-module (texinfo)
@ -1134,26 +1135,40 @@
mime-types) mime-types)
((application/json) ((application/json)
(render-json (render-json
`((derivations . ,(list->vector (lambda (port)
(map (match-lambda (scm-alist->streaming-json
((derivation system target) `((derivations
`((derivation . ,derivation) .
,@(if (member "system" fields) ,(lambda (port)
`((system . ,system)) (put-string port "[")
'()) (pair-for-each
,@(if (member "target" fields) (lambda (pair)
`((target . ,target)) (scm->json
'()))) (match (car pair)
((derivation system target builds) ((derivation system target)
`((derivation . ,derivation) `((derivation . ,derivation)
,@(if (member "system" fields) ,@(if (member "system" fields)
`((system . ,system)) `((system . ,system))
'()) '())
,@(if (member "target" fields) ,@(if (member "target" fields)
`((target . ,target)) `((target . ,target))
'()) '())))
(builds . ,builds)))) ((derivation system target builds)
derivations)))) `((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)) #:stream? #t))
(else (else
(fibers-let ((systems (fibers-let ((systems