diff options
Diffstat (limited to 'guix-data-service/web/revision/controller.scm')
| -rw-r--r-- | guix-data-service/web/revision/controller.scm | 127 |
1 files changed, 72 insertions, 55 deletions
diff --git a/guix-data-service/web/revision/controller.scm b/guix-data-service/web/revision/controller.scm index 114e9f4..b22fbed 100644 --- a/guix-data-service/web/revision/controller.scm +++ b/guix-data-service/web/revision/controller.scm @@ -24,6 +24,8 @@ #: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) #:use-module (guix-data-service database) #:use-module (guix-data-service web render) @@ -84,7 +86,7 @@ status)))) (define (parse-build-server v) - (letpar& ((build-servers + (fibers-let ((build-servers (call-with-resource-from-pool (connection-pool) select-build-servers))) (or (any (match-lambda @@ -395,7 +397,7 @@ `((unknown_commit . ,commit-hash)) #:code 404)) (else - (letpar& ((job + (fibers-let ((job (with-resource-from-pool (connection-pool) conn (select-job-for-commit conn commit-hash))) (git-repositories-and-branches @@ -423,7 +425,7 @@ `((unknown_commit . ,commit-hash)) #:code 404)) (else - (letpar& ((job + (fibers-let ((job (with-resource-from-pool (connection-pool) conn (select-job-for-commit conn commit-hash))) (git-repositories-and-branches @@ -446,8 +448,9 @@ commit-hash #:key path-base (header-text - `("Revision " (samp ,commit-hash)))) - (letpar& ((packages-count + `("Revision " (samp ,commit-hash))) + (max-age cache-control-default-max-age)) + (fibers-let ((packages-count (with-resource-from-pool (connection-pool) conn (count-packages-in-revision conn commit-hash))) (git-repositories-and-branches @@ -484,7 +487,10 @@ (network_dependent . ,(string=? network-dependent "t")) (count . ,(string->number count)))))) lint-warning-counts))) - #:extra-headers http-headers-for-unchanging-content)) + #:extra-headers + `((cache-control + . (public + (max-age . ,max-age)))))) (else (render-html #:sxml (view-revision @@ -496,7 +502,10 @@ lint-warning-counts #:path-base path-base #:header-text header-text) - #:extra-headers http-headers-for-unchanging-content))))) + #:extra-headers + `((cache-control + . (public + (max-age . ,max-age))))))))) (define* (render-revision-system-tests mime-types commit-hash @@ -507,7 +516,7 @@ `("Revision " (samp ,commit-hash))) (header-link (string-append "/revision/" commit-hash))) - (letpar& ((system-tests + (fibers-let ((system-tests (with-resource-from-pool (connection-pool) conn (select-system-tests-for-guix-revision conn @@ -535,7 +544,7 @@ (builds . ,(list->vector builds))))) system-tests)))))) (else - (letpar& ((git-repositories + (fibers-let ((git-repositories (with-resource-from-pool (connection-pool) conn (git-repositories-containing-commit conn commit-hash))) @@ -561,7 +570,7 @@ (header-link (string-append "/revision/" commit-hash))) - (letpar& ((channel-instances + (fibers-let ((channel-instances (with-resource-from-pool (connection-pool) conn (select-channel-instances-for-guix-revision conn commit-hash)))) (case (most-appropriate-mime-type @@ -589,7 +598,7 @@ (define* (render-revision-package-substitute-availability mime-types commit-hash #:key path-base) - (letpar& ((substitute-availability + (fibers-let ((substitute-availability (with-resource-from-pool (connection-pool) conn (select-package-output-availability-for-revision conn commit-hash))) @@ -635,7 +644,7 @@ (header-link (string-append "/revision/" commit-hash))) - (letpar& ((output-consistency + (fibers-let ((output-consistency (with-resource-from-pool (connection-pool) conn (select-output-consistency-for-revision conn commit-hash)))) (case (most-appropriate-mime-type @@ -669,7 +678,7 @@ #:sxml (view-revision-news commit-hash query-parameters '())))) - (letpar& ((news-entries + (fibers-let ((news-entries (with-resource-from-pool (connection-pool) conn (select-channel-news-entries-contained-in-guix-revision conn @@ -728,7 +737,7 @@ 99999)) ; TODO There shouldn't be a limit (fields (assq-ref query-parameters 'field)) (locale (assq-ref query-parameters 'locale))) - (letpar& + (fibers-let ((packages (with-resource-from-pool (connection-pool) conn (if search-query @@ -825,7 +834,7 @@ "/revision/" commit-hash)) (header-text `("Revision " (samp ,commit-hash)))) - (letpar& ((package-synopsis-counts + (fibers-let ((package-synopsis-counts (with-resource-from-pool (connection-pool) conn (synopsis-counts-by-locale conn (commit->revision-id @@ -865,7 +874,7 @@ (header-link (string-append "/revision/" commit-hash))) - (letpar& ((package-versions + (fibers-let ((package-versions (with-resource-from-pool (connection-pool) conn (select-package-versions-for-revision conn commit-hash @@ -922,7 +931,7 @@ (define has-replacement? (assq-ref query-parameters 'has_replacement)) - (letpar& ((metadata + (fibers-let ((metadata (with-resource-from-pool (connection-pool) conn (select-package-metadata-by-revision-name-and-version conn @@ -1034,7 +1043,7 @@ (render-json `((error . "invalid query")))) (else - (letpar& ((systems + (fibers-let ((systems (call-with-resource-from-pool (connection-pool) list-systems)) (targets @@ -1060,10 +1069,10 @@ (assq-ref query-parameters 'search_query)) (fields (assq-ref query-parameters 'field))) - (letpar& + (fibers-let ((derivations - (with-resource-from-pool (connection-pool) conn - (if search-query + (if search-query + (with-resource-from-pool (connection-pool) conn (search-package-derivations-in-revision conn commit-hash @@ -1081,24 +1090,31 @@ string->symbol) #:limit-results limit-results #:after-name (assq-ref query-parameters 'after_name) - #:include-builds? (member "builds" fields)) - (select-package-derivations-in-revision - conn - commit-hash - #:systems (assq-ref query-parameters 'system) - #:targets (assq-ref query-parameters 'target) - #:maximum-builds (assq-ref query-parameters 'maximum_builds) - #:minimum-builds (assq-ref query-parameters 'minimum_builds) - #:build-from-build-servers (assq-ref query-parameters - 'build_from_build_server) - #:no-build-from-build-servers (assq-ref query-parameters - 'no_build_from_build_server) - #:build-status (and=> (assq-ref query-parameters - 'build_status) - string->symbol) - #:limit-results limit-results - #:after-name (assq-ref query-parameters 'after_name) - #:include-builds? (member "builds" fields))))) + #:include-builds? (member "builds" fields))) + (concatenate! + (fibers-map + (lambda (system) + (with-resource-from-pool (connection-pool) conn + (select-package-derivations-in-revision + conn + commit-hash + #:system system + #:targets (assq-ref query-parameters 'target) + #:maximum-builds (assq-ref query-parameters 'maximum_builds) + #:minimum-builds (assq-ref query-parameters 'minimum_builds) + #:build-from-build-servers (assq-ref query-parameters + 'build_from_build_server) + #:no-build-from-build-servers (assq-ref query-parameters + 'no_build_from_build_server) + #:build-status (and=> (assq-ref query-parameters + 'build_status) + string->symbol) + #:limit-results limit-results + #:after-name (assq-ref query-parameters 'after_name) + #:include-builds? (member "builds" fields)))) + (or (assq-ref query-parameters 'system) + (call-with-resource-from-pool (connection-pool) + list-systems)))))) (build-server-urls (call-with-resource-from-pool (connection-pool) select-build-server-urls-by-id))) @@ -1132,9 +1148,10 @@ `((target . ,target)) '()) (builds . ,builds)))) - derivations)))))) + derivations)))) + #:stream? #t)) (else - (letpar& ((systems + (fibers-let ((systems (call-with-resource-from-pool (connection-pool) list-systems)) (targets @@ -1172,7 +1189,7 @@ (render-json `((error . "invalid query")))) (else - (letpar& ((systems + (fibers-let ((systems (call-with-resource-from-pool (connection-pool) list-systems)) (targets @@ -1198,7 +1215,7 @@ (assq-ref query-parameters 'search_query)) (fields (assq-ref query-parameters 'field))) - (letpar& + (fibers-let ((derivations (with-resource-from-pool (connection-pool) conn (select-fixed-output-package-derivations-in-revision @@ -1227,7 +1244,7 @@ (render-json `((derivations . ,(list->vector derivations))))) (else - (letpar& ((systems + (fibers-let ((systems (call-with-resource-from-pool (connection-pool) list-systems)) (targets @@ -1269,7 +1286,7 @@ (render-json `((error . "invalid query")))) (else - (letpar& ((systems + (fibers-let ((systems (call-with-resource-from-pool (connection-pool) list-systems)) (targets @@ -1293,7 +1310,7 @@ (assq-ref query-parameters 'all_results)) (fields (assq-ref query-parameters 'field))) - (letpar& + (fibers-let ((derivation-outputs (with-resource-from-pool (connection-pool) conn (select-derivation-outputs-in-revision @@ -1366,16 +1383,16 @@ (build-server-count (length build-servers))) (cond - ((or (eq? hash-count 0) - (eq? build-server-count 1)) + ((or (= hash-count 0) + (= build-server-count 1)) "unknown") - ((eq? hash-count 1) + ((= hash-count 1) "matching") ((> hash-count 1) "not-matching"))))))) derivation-outputs)))))) (else - (letpar& ((systems + (fibers-let ((systems (call-with-resource-from-pool (connection-pool) list-systems)) (targets @@ -1404,7 +1421,7 @@ (header-link (string-append "/revision/" commit-hash))) (if (any-invalid-query-parameters? query-parameters) - (letpar& ((systems + (fibers-let ((systems (call-with-resource-from-pool (connection-pool) list-systems)) (targets @@ -1422,7 +1439,7 @@ '()))) (let ((system (assq-ref query-parameters 'system)) (target (assq-ref query-parameters 'target))) - (letpar& ((systems + (fibers-let ((systems (call-with-resource-from-pool (connection-pool) list-systems)) (targets @@ -1477,7 +1494,7 @@ (header-link (string-append "/revision/" commit-hash))) (if (any-invalid-query-parameters? query-parameters) - (letpar& ((systems + (fibers-let ((systems (call-with-resource-from-pool (connection-pool) list-systems)) (targets @@ -1494,7 +1511,7 @@ '()))) (let ((system (assq-ref query-parameters 'system)) (target (assq-ref query-parameters 'target))) - (letpar& ((systems + (fibers-let ((systems (call-with-resource-from-pool (connection-pool) list-systems)) (targets @@ -1577,7 +1594,7 @@ (linters (assq-ref query-parameters 'linter)) (message-query (assq-ref query-parameters 'message_query)) (fields (assq-ref query-parameters 'field))) - (letpar& + (fibers-let ((git-repositories (with-resource-from-pool (connection-pool) conn (git-repositories-containing-commit conn |