From d452c56bf2abdc73f3beb27e2b09ded0e1630517 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Mon, 30 Jun 2025 19:23:42 +0200 Subject: [PATCH] Try to speed up a couple of endpoints by streaming JSON --- guix-data-service/comparison.scm | 76 +++++++++++++++++ guix-data-service/web/compare/controller.scm | 84 +++++++++++-------- guix-data-service/web/render.scm | 25 +++++- guix-data-service/web/revision/controller.scm | 55 +++++++----- 4 files changed, 185 insertions(+), 55 deletions(-) diff --git a/guix-data-service/comparison.scm b/guix-data-service/comparison.scm index 51d35c2..b3420be 100644 --- a/guix-data-service/comparison.scm +++ b/guix-data-service/comparison.scm @@ -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) diff --git a/guix-data-service/web/compare/controller.scm b/guix-data-service/web/compare/controller.scm index da6b73a..c992186 100644 --- a/guix-data-service/web/compare/controller.scm +++ b/guix-data-service/web/compare/controller.scm @@ -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) diff --git a/guix-data-service/web/render.scm b/guix-data-service/web/render.scm index 95c5a48..c4a8e85 100644 --- a/guix-data-service/web/render.scm +++ b/guix-data-service/web/render.scm @@ -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) diff --git a/guix-data-service/web/revision/controller.scm b/guix-data-service/web/revision/controller.scm index 8b6a2fe..9adb25f 100644 --- a/guix-data-service/web/revision/controller.scm +++ b/guix-data-service/web/revision/controller.scm @@ -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