diff options
Diffstat (limited to 'guix-data-service/web/compare/controller.scm')
| -rw-r--r-- | guix-data-service/web/compare/controller.scm | 88 |
1 files changed, 51 insertions, 37 deletions
diff --git a/guix-data-service/web/compare/controller.scm b/guix-data-service/web/compare/controller.scm index ebbf6df..dbb4975 100644 --- a/guix-data-service/web/compare/controller.scm +++ b/guix-data-service/web/compare/controller.scm @@ -24,6 +24,8 @@ #:use-module (texinfo) #:use-module (texinfo html) #:use-module (texinfo plain-text) + #:use-module (knots parallelism) + #:use-module (knots resource-pool) #:use-module (guix-data-service utils) #:use-module (guix-data-service database) #:use-module (guix-data-service web sxml) @@ -229,7 +231,7 @@ (define (render-compare mime-types query-parameters) (if (any-invalid-query-parameters? query-parameters) - (letpar& ((base-job + (fibers-let ((base-job (match (assq-ref query-parameters 'base_commit) (($ <invalid-query-parameter> value) (with-resource-from-pool (connection-pool) conn @@ -275,7 +277,7 @@ #f #f #f))))) - (letpar& ((base-revision-id + (fibers-let ((base-revision-id (with-resource-from-pool (connection-pool) conn (commit->revision-id conn @@ -303,7 +305,7 @@ (version-changes (package-data-version-changes base-packages-vhash target-packages-vhash))) - (letpar& ((lint-warnings-data + (fibers-let ((lint-warnings-data (with-resource-from-pool (connection-pool) conn (group-list-by-first-n-fields 2 @@ -396,7 +398,7 @@ lint-warnings-data)))) #:extra-headers http-headers-for-unchanging-content)) (else - (letpar& ((lint-warnings-locale-options + (fibers-let ((lint-warnings-locale-options (map (match-lambda ((locale) @@ -449,7 +451,7 @@ (target-branch (assq-ref query-parameters 'target_branch)) (target-datetime (assq-ref query-parameters 'target_datetime)) (locale (assq-ref query-parameters 'locale))) - (letpar& ((base-revision-details + (fibers-let ((base-revision-details (with-resource-from-pool (connection-pool) conn (select-guix-revision-for-branch-and-datetime conn @@ -624,7 +626,7 @@ '(application/json text/html) mime-types) ((application/json) - (letpar& ((base-job + (fibers-let ((base-job (and=> (match (assq-ref query-parameters 'base_commit) (($ <invalid-query-parameter> value) (and (string? value) value)) @@ -663,7 +665,7 @@ (base_job . ,base-job) (target_job . ,target-job))))) (else - (letpar& ((systems + (fibers-let ((systems (call-with-resource-from-pool (connection-pool) list-systems)) (targets @@ -684,27 +686,33 @@ (let ((base-commit (assq-ref query-parameters 'base_commit)) (target-commit (assq-ref query-parameters 'target_commit)) - (systems (assq-ref query-parameters 'system)) + (systems (or (assq-ref query-parameters 'system) + (call-with-resource-from-pool (connection-pool) + list-systems))) (targets (assq-ref query-parameters 'target)) (build-change (and=> (assq-ref query-parameters 'build_change) string->symbol)) (after-name (assq-ref query-parameters 'after_name)) (limit-results (assq-ref query-parameters 'limit_results))) - (letpar& ((data + (let ((data + (concatenate! + (fibers-map + (lambda (system) (with-resource-from-pool (connection-pool) conn (package-derivation-differences-data conn (commit->revision-id conn base-commit) (commit->revision-id conn target-commit) - #:systems systems + #:system system #:targets targets #:build-change build-change #:after-name after-name #:limit-results limit-results))) - (build-server-urls - (call-with-resource-from-pool (connection-pool) - select-build-server-urls-by-id))) + systems))) + (build-server-urls + (call-with-resource-from-pool (connection-pool) + select-build-server-urls-by-id))) (let ((names-and-versions (package-derivation-data->names-and-versions data))) (let-values @@ -725,9 +733,10 @@ (target . ((commit . ,target-commit))))) (derivation_changes - . ,derivation-changes)))) + . ,derivation-changes)) + #:stream? #t)) (else - (letpar& ((systems + (fibers-let ((systems (call-with-resource-from-pool (connection-pool) list-systems)) (targets @@ -741,7 +750,8 @@ (valid-targets->options targets) build-status-strings build-server-urls - derivation-changes)))))))))))) + derivation-changes) + #:stream? #t))))))))))) (define (render-compare-by-datetime/package-derivations mime-types query-parameters) @@ -771,14 +781,16 @@ (base-datetime (assq-ref query-parameters 'base_datetime)) (target-branch (assq-ref query-parameters 'target_branch)) (target-datetime (assq-ref query-parameters 'target_datetime)) - (systems (assq-ref query-parameters 'system)) + (systems (or (assq-ref query-parameters 'system) + (call-with-resource-from-pool (connection-pool) + list-systems))) (targets (assq-ref query-parameters 'target)) (build-change (and=> (assq-ref query-parameters 'build_change) string->symbol)) (after-name (assq-ref query-parameters 'after_name)) (limit-results (assq-ref query-parameters 'limit_results))) - (letpar& + (fibers-let ((base-revision-details (with-resource-from-pool (connection-pool) conn (select-guix-revision-for-branch-and-datetime conn @@ -789,18 +801,20 @@ (select-guix-revision-for-branch-and-datetime conn target-branch target-datetime)))) - (letpar& - ((data - (with-resource-from-pool (connection-pool) conn - (package-derivation-differences-data - conn - (first base-revision-details) - (first target-revision-details) - #:systems systems - #:targets targets - #:build-change build-change - #:after-name after-name - #:limit-results limit-results)))) + (let ((data + (fibers-map + (lambda (system) + (with-resource-from-pool (connection-pool) conn + (package-derivation-differences-data + conn + (first base-revision-details) + (first target-revision-details) + #:system system + #:targets targets + #:build-change build-change + #:after-name after-name + #:limit-results limit-results))) + systems))) (let ((names-and-versions (package-derivation-data->names-and-versions data))) (let-values @@ -863,7 +877,7 @@ (render-json '((error . "invalid query")))) (else - (letpar& ((base-job + (fibers-let ((base-job (match (assq-ref query-parameters 'base_commit) (($ <invalid-query-parameter> value) (with-resource-from-pool (connection-pool) conn @@ -883,7 +897,7 @@ (let ((base-commit (assq-ref query-parameters 'base_commit)) (target-commit (assq-ref query-parameters 'target_commit))) - (letpar& ((base-revision-id + (fibers-let ((base-revision-id (with-resource-from-pool (connection-pool) conn (commit->revision-id conn @@ -932,7 +946,7 @@ (render-json '((error . "invalid query")))) (else - (letpar& ((systems + (fibers-let ((systems (with-resource-from-pool (connection-pool) conn list-systems)) (build-server-urls @@ -951,7 +965,7 @@ (let ((base-commit (assq-ref query-parameters 'base_commit)) (target-commit (assq-ref query-parameters 'target_commit)) (system (assq-ref query-parameters 'system))) - (letpar& ((data + (fibers-let ((data (with-resource-from-pool (connection-pool) conn (system-test-derivations-differences-data conn @@ -1002,7 +1016,7 @@ (render-json '((error . "invalid query")))) (else - (letpar& ((systems + (fibers-let ((systems (with-resource-from-pool (connection-pool) conn list-systems)) (build-server-urls @@ -1023,7 +1037,7 @@ (target-branch (assq-ref query-parameters 'target_branch)) (target-datetime (assq-ref query-parameters 'target_datetime)) (system (assq-ref query-parameters 'system))) - (letpar& + (fibers-let ((base-revision-details (with-resource-from-pool (connection-pool) conn (select-guix-revision-for-branch-and-datetime conn @@ -1034,7 +1048,7 @@ (select-guix-revision-for-branch-and-datetime conn target-branch target-datetime)))) - (letpar& ((data + (fibers-let ((data (with-resource-from-pool (connection-pool) conn (system-test-derivations-differences-data conn |