aboutsummaryrefslogtreecommitdiff
path: root/guix-data-service/web/compare/controller.scm
diff options
context:
space:
mode:
Diffstat (limited to 'guix-data-service/web/compare/controller.scm')
-rw-r--r--guix-data-service/web/compare/controller.scm88
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