diff options
| author | Christopher Baines <mail@cbaines.net> | 2023-07-09 16:52:35 +0100 |
|---|---|---|
| committer | Christopher Baines <mail@cbaines.net> | 2023-07-10 18:56:31 +0100 |
| commit | 7251c7d653de29f36d50b33badf05a5db983b8e7 (patch) | |
| tree | 3f74252cf1f0d13d35dc1253406d9a3b92b67f7e /guix-data-service/web | |
| parent | 672ee6216e1d15f7f550f53017323b59f05303cb (diff) | |
| download | data-service-7251c7d653de29f36d50b33badf05a5db983b8e7.tar data-service-7251c7d653de29f36d50b33badf05a5db983b8e7.tar.gz | |
Stop using a pool of threads for database operations
Now that squee cooperates with suspendable ports, this is unnecessary. Use a
connection pool to still support running queries in parallel using multiple
connections.
Diffstat (limited to 'guix-data-service/web')
| -rw-r--r-- | guix-data-service/web/build-server/controller.scm | 130 | ||||
| -rw-r--r-- | guix-data-service/web/build/controller.scm | 60 | ||||
| -rw-r--r-- | guix-data-service/web/compare/controller.scm | 512 | ||||
| -rw-r--r-- | guix-data-service/web/controller.scm | 300 | ||||
| -rw-r--r-- | guix-data-service/web/jobs/controller.scm | 51 | ||||
| -rw-r--r-- | guix-data-service/web/nar/controller.scm | 51 | ||||
| -rw-r--r-- | guix-data-service/web/package/controller.scm | 14 | ||||
| -rw-r--r-- | guix-data-service/web/repository/controller.scm | 215 | ||||
| -rw-r--r-- | guix-data-service/web/revision/controller.scm | 694 | ||||
| -rw-r--r-- | guix-data-service/web/server.scm | 65 |
10 files changed, 974 insertions, 1118 deletions
diff --git a/guix-data-service/web/build-server/controller.scm b/guix-data-service/web/build-server/controller.scm index 7c31cf1..ca03284 100644 --- a/guix-data-service/web/build-server/controller.scm +++ b/guix-data-service/web/build-server/controller.scm @@ -26,6 +26,7 @@ #:use-module (guix-data-service substitutes) #:use-module (guix-data-service web render) #:use-module (guix-data-service web query-parameters) + #:use-module (guix-data-service web controller) #:use-module (guix-data-service jobs load-new-guix-revision) #:use-module (guix-data-service model utils) #:use-module (guix-data-service model build) @@ -60,18 +61,16 @@ (build-server-build-id (assq-ref query-parameters 'build_server_build_id)) (build - (parallel-via-thread-pool-channel - (with-thread-postgresql-connection - (lambda (conn) - (if build-server-build-id - (select-build-by-build-server-and-build-server-build-id - conn - build-server-id - build-server-build-id) - (select-build-by-build-server-and-derivation-file-name - conn - build-server-id - derivation-file-name))))))) + (with-resource-from-pool (connection-pool) conn + (if build-server-build-id + (select-build-by-build-server-and-build-server-build-id + conn + build-server-id + build-server-build-id) + (select-build-by-build-server-and-derivation-file-name + conn + build-server-id + derivation-file-name))))) (if build (render-html #:sxml @@ -88,13 +87,11 @@ ; guix-build-coordinator ; doesn't mark builds as ; failed-dependency - (parallel-via-thread-pool-channel - (with-thread-postgresql-connection - (lambda (conn) - (select-required-builds-that-failed - conn - build-server-id - derivation-file-name)))) + (with-resource-from-pool (connection-pool) conn + (select-required-builds-that-failed + conn + build-server-id + derivation-file-name)) #f))))) (render-html #:sxml (general-not-found @@ -121,27 +118,26 @@ (define build-server-id (string->number build-server-id-string)) - (define (call-via-thread-pool-channel handler) + (define (spawn-fiber-for-handler handler) (spawn-fiber (lambda () - (parallel-via-thread-pool-channel - (with-postgresql-connection - "build-event-handler-conn" - (lambda (conn) - (with-exception-handler - (lambda (exn) - (simple-format - (current-error-port) - "exception in build event handler: ~A\n" - exn)) - (lambda () - (with-throw-handler #t - (lambda () - (handler conn)) - (lambda _ - (display (backtrace) (current-error-port)) - (display "\n" (current-error-port))))) - #:unwind? #t))))))) + (with-postgresql-connection + "build-event-handler-conn" + (lambda (conn) + (with-exception-handler + (lambda (exn) + (simple-format + (current-error-port) + "exception in build event handler: ~A\n" + exn)) + (lambda () + (with-throw-handler #t + (lambda () + (handler conn)) + (lambda _ + (display (backtrace) (current-error-port)) + (display "\n" (current-error-port))))) + #:unwind? #t)))))) (define (with-build-ids-for-status data build-ids @@ -217,24 +213,24 @@ #f)))) items)) - (letpar& ((build-ids - (with-thread-postgresql-connection - (lambda (conn) - (with-postgresql-transaction - conn - (lambda (conn) - (handle-derivation-events - conn - filtered-items))))))) + (let ((build-ids + (with-resource-from-pool (reserved-connection-pool) conn + (with-postgresql-transaction + conn + (lambda (conn) + (handle-derivation-events + conn + filtered-items)))))) (with-build-ids-for-status items build-ids '("succeeded") (lambda (ids) - (call-via-thread-pool-channel + (spawn-fiber-for-handler (lambda (conn) - (handle-removing-blocking-build-entries-for-successful-builds conn ids))) + (handle-removing-blocking-build-entries-for-successful-builds + conn ids))) (request-query-of-build-server-substitutes build-server-id ids))) @@ -244,7 +240,7 @@ build-ids '("scheduled") (lambda (ids) - (call-via-thread-pool-channel + (spawn-fiber-for-handler (lambda (conn) (handle-blocked-builds-entries-for-scheduled-builds conn ids))))) @@ -253,7 +249,7 @@ build-ids '("failed" "failed-dependency" "canceled") (lambda (ids) - (call-via-thread-pool-channel + (spawn-fiber-for-handler (lambda (conn) (handle-populating-blocked-builds-for-build-failures conn ids))))))) @@ -263,12 +259,10 @@ #:code 400) (let ((provided-token (assq-ref parsed-query-parameters 'token)) (permitted-tokens - (parallel-via-thread-pool-channel - (with-thread-postgresql-connection - (lambda (conn) - (compute-tokens-for-build-server conn - secret-key-base - build-server-id)))))) + (with-resource-from-pool (reserved-connection-pool) conn + (compute-tokens-for-build-server conn + secret-key-base + build-server-id)))) (if (member provided-token (map cdr permitted-tokens) string=?) @@ -317,10 +311,8 @@ (define (handle-signing-key-request id) (render-html #:sxml (view-signing-key - (parallel-via-thread-pool-channel - (with-thread-postgresql-connection - (lambda (conn) - (select-signing-key conn id))))))) + (with-resource-from-pool (connection-pool) conn + (select-signing-key conn id))))) (define (build-server-controller request method-and-path-components @@ -329,17 +321,17 @@ secret-key-base) (match method-and-path-components (('GET "build-servers") - (letpar& ((build-servers - (with-thread-postgresql-connection - select-build-servers))) + (let ((build-servers + (with-resource-from-pool (connection-pool) conn + select-build-servers))) (render-build-servers mime-types build-servers))) (('GET "build-server" build-server-id) - (letpar& ((build-server - (with-thread-postgresql-connection - (lambda (conn) - (select-build-server conn (string->number - build-server-id)))))) + (let ((build-server + (with-resource-from-pool (connection-pool) conn + (lambda (conn) + (select-build-server conn (string->number + build-server-id)))))) (if build-server (render-build-server mime-types build-server) diff --git a/guix-data-service/web/build/controller.scm b/guix-data-service/web/build/controller.scm index 9e3b943..44b3380 100644 --- a/guix-data-service/web/build/controller.scm +++ b/guix-data-service/web/build/controller.scm @@ -21,6 +21,7 @@ #:use-module (guix-data-service utils) #:use-module (guix-data-service database) #:use-module (guix-data-service web render) + #:use-module (guix-data-service web controller) #:use-module (guix-data-service web query-parameters) #:use-module (guix-data-service model build) #:use-module (guix-data-service model system) @@ -41,7 +42,7 @@ (define parse-build-server (lambda (v) (letpar& ((build-servers - (with-thread-postgresql-connection + (with-resource-from-pool (connection-pool) conn select-build-servers))) (or (any (match-lambda ((id url lookup-all-derivations? lookup-builds?) @@ -88,39 +89,38 @@ (let ((system (assq-ref parsed-query-parameters 'system)) (target (assq-ref parsed-query-parameters 'target))) (letpar& ((build-server-options - (with-thread-postgresql-connection - (lambda (conn) - (map (match-lambda - ((id url lookup-all-derivations - lookup-builds) - (cons url id))) - (select-build-servers conn))))) + (with-resource-from-pool (connection-pool) conn + (map (match-lambda + ((id url lookup-all-derivations + lookup-builds) + (cons url id))) + (select-build-servers conn)))) (build-stats - (with-thread-postgresql-connection - (lambda (conn) - (select-build-stats - conn - (assq-ref parsed-query-parameters - 'build_server) - #:system system - #:target target)))) + (with-resource-from-pool (connection-pool) conn + (select-build-stats + conn + (assq-ref parsed-query-parameters + 'build_server) + #:system system + #:target target))) (builds-with-context - (with-thread-postgresql-connection - (lambda (conn) - (select-builds-with-context - conn - (assq-ref parsed-query-parameters - 'build_status) - (assq-ref parsed-query-parameters - 'build_server) - #:system system - #:target target - #:limit (assq-ref parsed-query-parameters - 'limit_results))))) + (with-resource-from-pool (connection-pool) conn + (select-builds-with-context + conn + (assq-ref parsed-query-parameters + 'build_status) + (assq-ref parsed-query-parameters + 'build_server) + #:system system + #:target target + #:limit (assq-ref parsed-query-parameters + 'limit_results)))) (systems - (with-thread-postgresql-connection list-systems)) + (call-with-resource-from-pool (connection-pool) + list-systems)) (targets - (with-thread-postgresql-connection valid-targets))) + (call-with-resource-from-pool (connection-pool) + valid-targets))) (render-html #:sxml (view-builds parsed-query-parameters diff --git a/guix-data-service/web/compare/controller.scm b/guix-data-service/web/compare/controller.scm index 3d96aa4..6380651 100644 --- a/guix-data-service/web/compare/controller.scm +++ b/guix-data-service/web/compare/controller.scm @@ -30,6 +30,7 @@ #:use-module (guix-data-service web util) #:use-module (guix-data-service web render) #:use-module (guix-data-service web query-parameters) + #:use-module (guix-data-service web controller) #:use-module (guix-data-service model utils) #:use-module (guix-data-service comparison) #:use-module (guix-data-service jobs load-new-guix-revision) @@ -55,42 +56,38 @@ s) (define (parse-commit s) - (parallel-via-thread-pool-channel - (with-thread-postgresql-connection - (lambda (conn) - (let* ((job-details - (select-job-for-commit conn s)) - (job-state - (assq-ref job-details 'state))) - (if job-details - (cond - ((string=? job-state "succeeded") - s) - ((string=? job-state "queued") - (make-invalid-query-parameter - s - `("data unavailable, " - (a (@ (href ,(string-append - "/revision/" s))) - "yet to process revision")))) - ((string=? job-state "failed") - (make-invalid-query-parameter - s - `("data unavailable, " - (a (@ (href ,(string-append - "/revision/" s))) - "failed to process revision")))) - (else - (make-invalid-query-parameter - s "unknown job state"))) + (with-resource-from-pool (connection-pool) conn + (let* ((job-details + (select-job-for-commit conn s)) + (job-state + (assq-ref job-details 'state))) + (if job-details + (cond + ((string=? job-state "succeeded") + s) + ((string=? job-state "queued") (make-invalid-query-parameter - s "unknown commit"))))))) + s + `("data unavailable, " + (a (@ (href ,(string-append + "/revision/" s))) + "yet to process revision")))) + ((string=? job-state "failed") + (make-invalid-query-parameter + s + `("data unavailable, " + (a (@ (href ,(string-append + "/revision/" s))) + "failed to process revision")))) + (else + (make-invalid-query-parameter + s "unknown job state"))) + (make-invalid-query-parameter + s "unknown commit"))))) (define (parse-derivation file-name) - (if (parallel-via-thread-pool-channel - (with-thread-postgresql-connection - (lambda (conn) - (select-derivation-by-file-name conn file-name)))) + (if (with-resource-from-pool (connection-pool) conn + (select-derivation-by-file-name conn file-name)) file-name (make-invalid-query-parameter file-name "unknown derivation"))) @@ -235,18 +232,16 @@ (letpar& ((base-job (match (assq-ref query-parameters 'base_commit) (($ <invalid-query-parameter> value) - (with-thread-postgresql-connection - (lambda (conn) - (and (string? value) - (select-job-for-commit conn value))))) + (with-resource-from-pool (connection-pool) conn + (and (string? value) + (select-job-for-commit conn value)))) (_ #f))) (target-job (match (assq-ref query-parameters 'target_commit) (($ <invalid-query-parameter> value) - (with-thread-postgresql-connection - (lambda (conn) - (and (string? value) - (select-job-for-commit conn value))))) + (with-resource-from-pool (connection-pool) conn + (and (string? value) + (select-job-for-commit conn value)))) (_ #f)))) (case (most-appropriate-mime-type '(application/json text/html) @@ -281,28 +276,24 @@ #f #f))))) (letpar& ((base-revision-id - (with-thread-postgresql-connection - (lambda (conn) - (commit->revision-id - conn - (assq-ref query-parameters 'base_commit))))) + (with-resource-from-pool (connection-pool) conn + (commit->revision-id + conn + (assq-ref query-parameters 'base_commit)))) (target-revision-id - (with-thread-postgresql-connection - (lambda (conn) - (commit->revision-id - conn - (assq-ref query-parameters 'target_commit))))) + (with-resource-from-pool (connection-pool) conn + (commit->revision-id + conn + (assq-ref query-parameters 'target_commit)))) (locale (assq-ref query-parameters 'locale))) (let-values (((base-packages-vhash target-packages-vhash) (package-data->package-data-vhashes - (parallel-via-thread-pool-channel - (with-thread-postgresql-connection - (lambda (conn) - (package-differences-data conn - base-revision-id - target-revision-id))))))) + (with-resource-from-pool (connection-pool) conn + (package-differences-data conn + base-revision-id + target-revision-id))))) (let ((new-packages (package-data-vhashes->new-packages base-packages-vhash target-packages-vhash)) @@ -313,20 +304,18 @@ (package-data-version-changes base-packages-vhash target-packages-vhash))) (letpar& ((lint-warnings-data - (with-thread-postgresql-connection - (lambda (conn) - (group-list-by-first-n-fields - 2 - (lint-warning-differences-data conn - base-revision-id - target-revision-id - locale))))) - (channel-news-data - (with-thread-postgresql-connection - (lambda (conn) - (channel-news-differences-data conn + (with-resource-from-pool (connection-pool) conn + (group-list-by-first-n-fields + 2 + (lint-warning-differences-data conn base-revision-id - target-revision-id))))) + target-revision-id + locale)))) + (channel-news-data + (with-resource-from-pool (connection-pool) conn + (channel-news-differences-data conn + base-revision-id + target-revision-id)))) (case (most-appropriate-mime-type '(application/json text/html) mime-types) @@ -412,18 +401,16 @@ (match-lambda ((locale) locale)) - (with-thread-postgresql-connection - (lambda (conn) - (lint-warning-message-locales-for-revision - conn - (assq-ref query-parameters 'target_commit)))))) - (cgit-url-bases - (with-thread-postgresql-connection - (lambda (conn) - (guix-revisions-cgit-url-bases + (with-resource-from-pool (connection-pool) conn + (lint-warning-message-locales-for-revision conn - (list base-revision-id - target-revision-id)))))) + (assq-ref query-parameters 'target_commit))))) + (cgit-url-bases + (with-resource-from-pool (connection-pool) conn + (guix-revisions-cgit-url-bases + conn + (list base-revision-id + target-revision-id))))) (render-html #:sxml (compare query-parameters 'revision @@ -463,29 +450,26 @@ (target-datetime (assq-ref query-parameters 'target_datetime)) (locale (assq-ref query-parameters 'locale))) (letpar& ((base-revision-details - (with-thread-postgresql-connection - (lambda (conn) - (select-guix-revision-for-branch-and-datetime - conn - base-branch - base-datetime)))) + (with-resource-from-pool (connection-pool) conn + (select-guix-revision-for-branch-and-datetime + conn + base-branch + base-datetime))) (target-revision-details - (with-thread-postgresql-connection - (lambda (conn) - (select-guix-revision-for-branch-and-datetime - conn - target-branch - target-datetime))))) - (letpar& ((lint-warnings-locale-options - (map - (match-lambda - ((locale) - locale)) - (with-thread-postgresql-connection - (lambda (conn) - (lint-warning-message-locales-for-revision - conn - (second base-revision-details))))))) + (with-resource-from-pool (connection-pool) conn + (select-guix-revision-for-branch-and-datetime + conn + target-branch + target-datetime)))) + (let ((lint-warnings-locale-options + (map + (match-lambda + ((locale) + locale)) + (with-resource-from-pool (connection-pool) conn + (lint-warning-message-locales-for-revision + conn + (second base-revision-details)))))) (let ((base-revision-id (first base-revision-details)) (target-revision-id @@ -493,12 +477,10 @@ (let-values (((base-packages-vhash target-packages-vhash) (package-data->package-data-vhashes - (parallel-via-thread-pool-channel - (with-thread-postgresql-connection - (lambda (conn) - (package-differences-data conn - base-revision-id - target-revision-id))))))) + (with-resource-from-pool (connection-pool) conn + (package-differences-data conn + base-revision-id + target-revision-id))))) (let* ((new-packages (package-data-vhashes->new-packages base-packages-vhash target-packages-vhash)) @@ -509,12 +491,10 @@ (package-data-version-changes base-packages-vhash target-packages-vhash)) (channel-news-data - (parallel-via-thread-pool-channel - (with-thread-postgresql-connection - (lambda (conn) - (channel-news-differences-data conn - base-revision-id - target-revision-id)))))) + (with-resource-from-pool (connection-pool) conn + (channel-news-differences-data conn + base-revision-id + target-revision-id)))) (case (most-appropriate-mime-type '(application/json text/html) mime-types) @@ -567,32 +547,29 @@ #:extra-headers http-headers-for-unchanging-content)) (else (render-html - #:sxml (compare `(,@query-parameters - (base_commit . ,(second base-revision-details)) - (target_commit . ,(second target-revision-details))) - 'datetime - (parallel-via-thread-pool-channel - (with-thread-postgresql-connection - (lambda (conn) - (guix-revisions-cgit-url-bases - conn - (list base-revision-id - target-revision-id))))) - new-packages - removed-packages - version-changes - (parallel-via-thread-pool-channel - (group-list-by-first-n-fields - 2 - (with-thread-postgresql-connection - (lambda (conn) - (lint-warning-differences-data - conn - base-revision-id - target-revision-id - locale))))) - lint-warnings-locale-options - channel-news-data) + #:sxml (compare + `(,@query-parameters + (base_commit . ,(second base-revision-details)) + (target_commit . ,(second target-revision-details))) + 'datetime + (with-resource-from-pool (connection-pool) conn + (guix-revisions-cgit-url-bases + conn + (list base-revision-id + target-revision-id))) + new-packages + removed-packages + version-changes + (group-list-by-first-n-fields + 2 + (with-resource-from-pool (connection-pool) conn + (lint-warning-differences-data + conn + base-revision-id + target-revision-id + locale))) + lint-warnings-locale-options + channel-news-data) #:extra-headers http-headers-for-unchanging-content))))))))))) (define (render-compare/derivation mime-types @@ -612,12 +589,11 @@ (let ((base-derivation (assq-ref query-parameters 'base_derivation)) (target-derivation (assq-ref query-parameters 'target_derivation))) - (letpar& ((data - (with-thread-postgresql-connection - (lambda (conn) - (derivation-differences-data conn - base-derivation - target-derivation))))) + (let ((data + (with-resource-from-pool (connection-pool) conn + (derivation-differences-data conn + base-derivation + target-derivation)))) (case (most-appropriate-mime-type '(application/json text/html) mime-types) @@ -655,9 +631,8 @@ ((? string? value) value) (_ #f)) (lambda (commit) - (with-thread-postgresql-connection - (lambda (conn) - (select-job-for-commit conn commit)))))) + (with-resource-from-pool (connection-pool) conn + (select-job-for-commit conn commit))))) (target-job (and=> (match (assq-ref query-parameters 'target_commit) (($ <invalid-query-parameter> value) @@ -665,9 +640,8 @@ ((? string? value) value) (_ #f)) (lambda (commit) - (with-thread-postgresql-connection - (lambda (conn) - (select-job-for-commit conn commit))))))) + (with-resource-from-pool (connection-pool) conn + (select-job-for-commit conn commit)))))) (render-json `((error . "invalid query") (query_parameters @@ -690,14 +664,14 @@ (target_job . ,target-job))))) (else (letpar& ((systems - (with-thread-postgresql-connection - list-systems)) + (call-with-resource-from-pool (connection-pool) + list-systems)) (targets - (with-thread-postgresql-connection - valid-targets)) + (call-with-resource-from-pool (connection-pool) + valid-targets)) (build-server-urls - (with-thread-postgresql-connection - select-build-server-urls-by-id))) + (call-with-resource-from-pool (connection-pool) + select-build-server-urls-by-id))) (render-html #:sxml (compare/package-derivations query-parameters @@ -718,19 +692,18 @@ (after-name (assq-ref query-parameters 'after_name)) (limit-results (assq-ref query-parameters 'limit_results))) (letpar& ((data - (with-thread-postgresql-connection - (lambda (conn) - (package-derivation-differences-data - conn - (commit->revision-id conn base-commit) - (commit->revision-id conn target-commit) - #:systems systems - #:targets targets - #:build-change build-change - #:after-name after-name - #:limit-results limit-results)))) + (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 + #:targets targets + #:build-change build-change + #:after-name after-name + #:limit-results limit-results))) (build-server-urls - (with-thread-postgresql-connection + (with-resource-from-pool (connection-pool) conn select-build-server-urls-by-id))) (let ((names-and-versions (package-derivation-data->names-and-versions data))) @@ -755,11 +728,11 @@ . ,derivation-changes)))) (else (letpar& ((systems - (with-thread-postgresql-connection - list-systems)) + (call-with-resource-from-pool (connection-pool) + list-systems)) (targets - (with-thread-postgresql-connection - valid-targets))) + (call-with-resource-from-pool (connection-pool) + valid-targets))) (render-html #:sxml (compare/package-derivations query-parameters @@ -784,11 +757,11 @@ #:sxml (compare/package-derivations query-parameters 'datetime - (parallel-via-thread-pool-channel - (with-thread-postgresql-connection list-systems)) + (call-with-resource-from-pool (connection-pool) + list-systems) (valid-targets->options - (parallel-via-thread-pool-channel - (with-thread-postgresql-connection valid-targets))) + (call-with-resource-from-pool (connection-pool) + valid-targets)) build-status-strings '() '() @@ -807,30 +780,27 @@ (limit-results (assq-ref query-parameters 'limit_results))) (letpar& ((base-revision-details - (with-thread-postgresql-connection - (lambda (conn) - (select-guix-revision-for-branch-and-datetime conn - base-branch - base-datetime)))) + (with-resource-from-pool (connection-pool) conn + (select-guix-revision-for-branch-and-datetime conn + base-branch + base-datetime))) (target-revision-details - (with-thread-postgresql-connection - (lambda (conn) - (select-guix-revision-for-branch-and-datetime conn - target-branch - target-datetime))))) + (with-resource-from-pool (connection-pool) conn + (select-guix-revision-for-branch-and-datetime conn + target-branch + target-datetime)))) (letpar& ((data - (with-thread-postgresql-connection - (lambda (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))))) + (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 ((names-and-versions (package-derivation-data->names-and-versions data))) (let-values @@ -859,15 +829,17 @@ #:sxml (compare/package-derivations query-parameters 'datetime - (parallel-via-thread-pool-channel - (with-thread-postgresql-connection list-systems)) + (call-with-resource-from-pool + (connection-pool) + list-systems) (valid-targets->options - (parallel-via-thread-pool-channel - (with-thread-postgresql-connection valid-targets))) + (call-with-resource-from-pool + (connection-pool) + valid-targets)) build-status-strings - (parallel-via-thread-pool-channel - (with-thread-postgresql-connection - select-build-server-urls-by-id)) + (call-with-resource-from-pool + (connection-pool) + select-build-server-urls-by-id) derivation-changes base-revision-details target-revision-details)))))))))))) @@ -894,16 +866,14 @@ (letpar& ((base-job (match (assq-ref query-parameters 'base_commit) (($ <invalid-query-parameter> value) - (with-thread-postgresql-connection - (lambda (conn) - (select-job-for-commit conn value)))) + (with-resource-from-pool (connection-pool) conn + (select-job-for-commit conn value))) (_ #f))) (target-job (match (assq-ref query-parameters 'target_commit) (($ <invalid-query-parameter> value) - (with-thread-postgresql-connection - (lambda (conn) - (select-job-for-commit conn value)))) + (with-resource-from-pool (connection-pool) conn + (select-job-for-commit conn value))) (_ #f)))) (render-html #:sxml (compare-invalid-parameters @@ -914,26 +884,22 @@ (let ((base-commit (assq-ref query-parameters 'base_commit)) (target-commit (assq-ref query-parameters 'target_commit))) (letpar& ((base-revision-id - (with-thread-postgresql-connection - (lambda (conn) - (commit->revision-id - conn - base-commit)))) + (with-resource-from-pool (connection-pool) conn + (commit->revision-id + conn + base-commit))) (target-revision-id - (with-thread-postgresql-connection - (lambda (conn) - (commit->revision-id - conn - target-commit))))) + (with-resource-from-pool (connection-pool) conn + (commit->revision-id + conn + target-commit)))) (let-values (((base-packages-vhash target-packages-vhash) (package-data->package-data-vhashes - (parallel-via-thread-pool-channel - (with-thread-postgresql-connection - (lambda (conn) - (package-differences-data conn - base-revision-id - target-revision-id))))))) + (with-resource-from-pool (connection-pool) conn + (package-differences-data conn + base-revision-id + target-revision-id))))) (case (most-appropriate-mime-type '(application/json text/html) mime-types) @@ -967,10 +933,10 @@ '((error . "invalid query")))) (else (letpar& ((systems - (with-thread-postgresql-connection + (with-resource-from-pool (connection-pool) conn list-systems)) (build-server-urls - (with-thread-postgresql-connection + (with-resource-from-pool (connection-pool) conn select-build-server-urls-by-id))) (render-html #:sxml (compare/system-test-derivations @@ -986,26 +952,23 @@ (target-commit (assq-ref query-parameters 'target_commit)) (system (assq-ref query-parameters 'system))) (letpar& ((data - (with-thread-postgresql-connection - (lambda (conn) - (system-test-derivations-differences-data - conn - (commit->revision-id conn base-commit) - (commit->revision-id conn target-commit) - system)))) + (with-resource-from-pool (connection-pool) conn + (system-test-derivations-differences-data + conn + (commit->revision-id conn base-commit) + (commit->revision-id conn target-commit) + system))) (build-server-urls - (with-thread-postgresql-connection + (with-resource-from-pool (connection-pool) conn select-build-server-urls-by-id)) (base-git-repositories - (with-thread-postgresql-connection - (lambda (conn) - (git-repositories-containing-commit conn base-commit)))) + (with-resource-from-pool (connection-pool) conn + (git-repositories-containing-commit conn base-commit))) (target-git-repositories - (with-thread-postgresql-connection - (lambda (conn) - (git-repositories-containing-commit conn target-commit)))) + (with-resource-from-pool (connection-pool) conn + (git-repositories-containing-commit conn target-commit))) (systems - (with-thread-postgresql-connection + (with-resource-from-pool (connection-pool) conn list-systems))) (case (most-appropriate-mime-type '(application/json text/html) @@ -1040,10 +1003,10 @@ '((error . "invalid query")))) (else (letpar& ((systems - (with-thread-postgresql-connection + (with-resource-from-pool (connection-pool) conn list-systems)) (build-server-urls - (with-thread-postgresql-connection + (with-resource-from-pool (connection-pool) conn select-build-server-urls-by-id))) (render-html #:sxml (compare/system-test-derivations @@ -1062,42 +1025,37 @@ (system (assq-ref query-parameters 'system))) (letpar& ((base-revision-details - (with-thread-postgresql-connection - (lambda (conn) - (select-guix-revision-for-branch-and-datetime conn - base-branch - base-datetime)))) + (with-resource-from-pool (connection-pool) conn + (select-guix-revision-for-branch-and-datetime conn + base-branch + base-datetime))) (target-revision-details - (with-thread-postgresql-connection - (lambda (conn) - (select-guix-revision-for-branch-and-datetime conn - target-branch - target-datetime))))) + (with-resource-from-pool (connection-pool) conn + (select-guix-revision-for-branch-and-datetime conn + target-branch + target-datetime)))) (letpar& ((data - (with-thread-postgresql-connection - (lambda (conn) - (system-test-derivations-differences-data - conn - (first base-revision-details) - (first target-revision-details) - system)))) + (with-resource-from-pool (connection-pool) conn + (system-test-derivations-differences-data + conn + (first base-revision-details) + (first target-revision-details) + system))) (build-server-urls - (with-thread-postgresql-connection + (with-resource-from-pool (connection-pool) conn select-build-server-urls-by-id)) (base-git-repositories - (with-thread-postgresql-connection - (lambda (conn) - (git-repositories-containing-commit - conn - (second base-revision-details))))) + (with-resource-from-pool (connection-pool) conn + (git-repositories-containing-commit + conn + (second base-revision-details)))) (target-git-repositories - (with-thread-postgresql-connection - (lambda (conn) - (git-repositories-containing-commit - conn - (second target-revision-details))))) + (with-resource-from-pool (connection-pool) conn + (git-repositories-containing-commit + conn + (second target-revision-details)))) (systems - (with-thread-postgresql-connection + (with-resource-from-pool (connection-pool) conn list-systems))) (case (most-appropriate-mime-type '(application/json text/html) diff --git a/guix-data-service/web/controller.scm b/guix-data-service/web/controller.scm index 2b8d2b5..c9a6a04 100644 --- a/guix-data-service/web/controller.scm +++ b/guix-data-service/web/controller.scm @@ -75,9 +75,13 @@ make-render-metrics controller - reserved-thread-pool-channel)) + connection-pool + reserved-connection-pool)) -(define reserved-thread-pool-channel +(define connection-pool + (make-parameter #f)) + +(define reserved-connection-pool (make-parameter #f)) (define cache-control-default-max-age @@ -186,22 +190,28 @@ (lambda () (letpar& ((metric-values - (with-thread-postgresql-connection + (call-with-resource-from-pool + (reserved-connection-pool) fetch-high-level-table-size-metrics)) (guix-revisions-count - (with-thread-postgresql-connection + (call-with-resource-from-pool + (reserved-connection-pool) count-guix-revisions)) (pg-stat-user-tables-metrics - (with-thread-postgresql-connection + (call-with-resource-from-pool + (reserved-connection-pool) fetch-pg-stat-user-tables-metrics)) (pg-stat-user-indexes-metrics - (with-thread-postgresql-connection + (call-with-resource-from-pool + (reserved-connection-pool) fetch-pg-stat-user-indexes-metrics)) (pg-stats-metric-values - (with-thread-postgresql-connection + (call-with-resource-from-pool + (reserved-connection-pool) fetch-pg-stats-metrics)) (load-new-guix-revision-job-metrics - (with-thread-postgresql-connection + (call-with-resource-from-pool + (reserved-connection-pool) select-load-new-guix-revision-job-metrics))) (for-each (match-lambda @@ -301,29 +311,25 @@ (define (render-derivation derivation-file-name) (letpar& ((derivation - (with-thread-postgresql-connection - (lambda (conn) - (select-derivation-by-file-name conn derivation-file-name))))) + (with-resource-from-pool (reserved-connection-pool) conn + (select-derivation-by-file-name conn derivation-file-name)))) (if derivation (letpar& ((derivation-inputs - (with-thread-postgresql-connection - (lambda (conn) - (select-derivation-inputs-by-derivation-id - conn - (first derivation))))) + (with-resource-from-pool (reserved-connection-pool) conn + (select-derivation-inputs-by-derivation-id + conn + (first derivation)))) (derivation-outputs - (with-thread-postgresql-connection - (lambda (conn) - (select-derivation-outputs-by-derivation-id - conn - (first derivation))))) + (with-resource-from-pool (reserved-connection-pool) conn + (select-derivation-outputs-by-derivation-id + conn + (first derivation)))) (builds - (with-thread-postgresql-connection - (lambda (conn) - (select-builds-with-context-by-derivation-file-name - conn - (second derivation)))))) + (with-resource-from-pool (reserved-connection-pool) conn + (select-builds-with-context-by-derivation-file-name + conn + (second derivation))))) (render-html #:sxml (view-derivation derivation derivation-inputs @@ -339,30 +345,25 @@ (define (render-json-derivation derivation-file-name) (let ((derivation - (parallel-via-thread-pool-channel - (with-thread-postgresql-connection - (lambda (conn) - (select-derivation-by-file-name conn - derivation-file-name)))))) + (with-resource-from-pool (reserved-connection-pool) conn + (select-derivation-by-file-name conn + derivation-file-name)))) (if derivation (letpar& ((derivation-inputs - (with-thread-postgresql-connection - (lambda (conn) - (select-derivation-inputs-by-derivation-id - conn - (first derivation))))) + (with-resource-from-pool (connection-pool) conn + (select-derivation-inputs-by-derivation-id + conn + (first derivation)))) (derivation-outputs - (with-thread-postgresql-connection - (lambda (conn) - (select-derivation-outputs-by-derivation-id - conn - (first derivation))))) + (with-resource-from-pool (connection-pool) conn + (select-derivation-outputs-by-derivation-id + conn + (first derivation)))) (derivation-sources - (with-thread-postgresql-connection - (lambda (conn) - (select-derivation-sources-by-derivation-id - conn - (first derivation)))))) + (with-resource-from-pool (connection-pool) conn + (select-derivation-sources-by-derivation-id + conn + (first derivation))))) (render-json `((inputs . ,(list->vector (map @@ -400,30 +401,25 @@ (define (render-formatted-derivation derivation-file-name) (let ((derivation - (parallel-via-thread-pool-channel - (with-thread-postgresql-connection - (lambda (conn) - (select-derivation-by-file-name conn - derivation-file-name)))))) + (with-resource-from-pool (connection-pool) conn + (select-derivation-by-file-name conn + derivation-file-name)))) (if derivation (letpar& ((derivation-inputs - (with-thread-postgresql-connection - (lambda (conn) - (select-derivation-inputs-by-derivation-id - conn - (first derivation))))) + (with-resource-from-pool (connection-pool) conn + (select-derivation-inputs-by-derivation-id + conn + (first derivation)))) (derivation-outputs - (with-thread-postgresql-connection - (lambda (conn) - (select-derivation-outputs-by-derivation-id - conn - (first derivation))))) + (with-resource-from-pool (connection-pool) conn + (select-derivation-outputs-by-derivation-id + conn + (first derivation)))) (derivation-sources - (with-thread-postgresql-connection - (lambda (conn) - (select-derivation-sources-by-derivation-id - conn - (first derivation)))))) + (with-resource-from-pool (connection-pool) conn + (select-derivation-sources-by-derivation-id + conn + (first derivation))))) (render-html #:sxml (view-formatted-derivation derivation derivation-inputs @@ -439,12 +435,10 @@ (define (render-narinfos filename) (let ((narinfos - (parallel-via-thread-pool-channel - (with-thread-postgresql-connection - (lambda (conn) - (select-nars-for-output - conn - (string-append "/gnu/store/" filename))))))) + (with-resource-from-pool (connection-pool) conn + (select-nars-for-output + conn + (string-append "/gnu/store/" filename))))) (if (null? narinfos) (render-html #:sxml (general-not-found @@ -457,15 +451,12 @@ (define (render-store-item filename) (letpar& ((derivation - (with-thread-postgresql-connection - (lambda (conn) - (select-derivation-by-output-filename conn filename))))) + (with-resource-from-pool (reserved-connection-pool) conn + (select-derivation-by-output-filename conn filename)))) (match derivation (() - (match (parallel-via-thread-pool-channel - (with-thread-postgresql-connection - (lambda (conn) - (select-derivation-source-file-by-store-path conn filename)))) + (match (with-resource-from-pool (reserved-connection-pool) conn + (select-derivation-source-file-by-store-path conn filename)) (() (render-html #:sxml (general-not-found @@ -476,24 +467,20 @@ (render-html #:sxml (view-derivation-source-file filename - (parallel-via-thread-pool-channel - (with-thread-postgresql-connection - (lambda (conn) - (select-derivation-source-file-nar-details-by-file-name - conn - filename))))) + (with-resource-from-pool (reserved-connection-pool) conn + (select-derivation-source-file-nar-details-by-file-name + conn + filename))) #:extra-headers http-headers-for-unchanging-content)))) (derivations (letpar& ((nars - (with-thread-postgresql-connection - (lambda (conn) - (select-nars-for-output conn filename)))) + (with-resource-from-pool (reserved-connection-pool) conn + (select-nars-for-output conn filename))) (builds - (with-thread-postgresql-connection - (lambda (conn) - (select-builds-with-context-by-derivation-output - conn - filename))))) + (with-resource-from-pool (reserved-connection-pool) conn + (select-builds-with-context-by-derivation-output + conn + filename)))) (render-html #:sxml (view-store-item filename derivations @@ -502,16 +489,12 @@ (define (render-json-store-item filename) (let ((derivation - (parallel-via-thread-pool-channel - (with-thread-postgresql-connection - (lambda (conn) - (select-derivation-by-output-filename conn filename)))))) + (with-resource-from-pool (connection-pool) conn + (select-derivation-by-output-filename conn filename)))) (match derivation (() - (match (parallel-via-thread-pool-channel - (with-thread-postgresql-connection - (lambda (conn) - (select-derivation-source-file-by-store-path conn filename)))) + (match (with-resource-from-pool (connection-pool) conn + (select-derivation-source-file-by-store-path conn filename)) (() (render-json '((error . "store item not found")))) ((id) @@ -522,17 +505,14 @@ (match-lambda ((key . value) `((,key . ,value)))) - (parallel-via-thread-pool-channel - (with-thread-postgresql-connection - (lambda (conn) - (select-derivation-source-file-nar-details-by-file-name - conn - filename)))))))))))) + (with-resource-from-pool (connection-pool) conn + (select-derivation-source-file-nar-details-by-file-name + conn + filename)))))))))) (derivations (letpar& ((nars - (with-thread-postgresql-connection - (lambda (conn) - (select-nars-for-output conn filename))))) + (with-resource-from-pool (connection-pool) conn + (select-nars-for-output conn filename)))) (render-json `((nars . ,(list->vector (map @@ -653,33 +633,23 @@ (define path (uri-path (request-uri request))) - (define* (delegate-to f #:key use-reserved-thread-pool?) - (or (parameterize - ((thread-pool-channel - (if use-reserved-thread-pool? - (reserved-thread-pool-channel) - (thread-pool-channel)))) - (f request - method-and-path-components - mime-types - body)) + (define* (delegate-to f) + (or (f request + method-and-path-components + mime-types + body) (render-html #:sxml (general-not-found "Page not found" "") #:code 404))) - (define* (delegate-to-with-secret-key-base f #:key use-reserved-thread-pool?) - (or (parameterize - ((thread-pool-channel - (if use-reserved-thread-pool? - (reserved-thread-pool-channel) - (thread-pool-channel)))) - (f request - method-and-path-components - mime-types - body - secret-key-base)) + (define* (delegate-to-with-secret-key-base f) + (or (f request + method-and-path-components + mime-types + body + secret-key-base) (render-html #:sxml (general-not-found "Page not found" @@ -690,35 +660,29 @@ (base-controller request method-and-path-components #t) (match method-and-path-components (('GET) - (parameterize ((thread-pool-channel - (reserved-thread-pool-channel))) - (render-html - #:sxml (index - (parallel-via-thread-pool-channel - (with-thread-postgresql-connection - (lambda (conn) - (map - (lambda (git-repository-details) - (cons - git-repository-details - (all-branches-with-most-recent-commit - conn (first git-repository-details)))) - (all-git-repositories conn))))))))) + (render-html + #:sxml (index + (with-resource-from-pool (reserved-connection-pool) conn + (map + (lambda (git-repository-details) + (cons + git-repository-details + (all-branches-with-most-recent-commit + conn (first git-repository-details)))) + (all-git-repositories conn)))))) (('GET "builds") (delegate-to build-controller)) (('GET "statistics") (letpar& ((guix-revisions-count - (with-thread-postgresql-connection count-guix-revisions)) + (with-resource-from-pool (connection-pool) conn count-guix-revisions)) (count-derivations - (with-thread-postgresql-connection count-derivations))) + (with-resource-from-pool (connection-pool) conn count-derivations))) (render-html #:sxml (view-statistics guix-revisions-count count-derivations)))) (('GET "metrics") - (parameterize ((thread-pool-channel - (reserved-thread-pool-channel))) - (render-metrics))) + (render-metrics)) (('GET "revision" args ...) (delegate-to revision-controller)) (('GET "repositories") @@ -728,14 +692,12 @@ (('GET "package" _ ...) (delegate-to package-controller)) (('GET "gnu" "store" filename) - (parameterize ((thread-pool-channel - (reserved-thread-pool-channel))) - ;; These routes are a little special, as the extensions aren't used for - ;; content negotiation, so just use the path from the request - (let ((path (uri-path (request-uri request)))) - (if (string-suffix? ".drv" path) - (render-derivation (uri-decode path)) - (render-store-item (uri-decode path)))))) + ;; These routes are a little special, as the extensions aren't used for + ;; content negotiation, so just use the path from the request + (let ((path (uri-path (request-uri request)))) + (if (string-suffix? ".drv" path) + (render-derivation (uri-decode path)) + (render-store-item (uri-decode path))))) (('GET "gnu" "store" filename "formatted") (if (string-suffix? ".drv" filename) (render-formatted-derivation (string-append "/gnu/store/" filename)) @@ -747,12 +709,10 @@ (('GET "gnu" "store" filename "plain") (if (string-suffix? ".drv" filename) (let ((raw-drv - (parallel-via-thread-pool-channel - (with-thread-postgresql-connection - (lambda (conn) - (select-serialized-derivation-by-file-name - conn - (string-append "/gnu/store/" filename))))))) + (with-resource-from-pool (connection-pool) conn + (select-serialized-derivation-by-file-name + conn + (string-append "/gnu/store/" filename))))) (if raw-drv (render-text raw-drv) (not-found (request-uri request)))) @@ -764,20 +724,16 @@ (render-json-derivation (string-append "/gnu/store/" filename)) (render-json-store-item (string-append "/gnu/store/" filename)))) (('GET "build-servers") - (delegate-to-with-secret-key-base build-server-controller - #:use-reserved-thread-pool? #t)) + (delegate-to-with-secret-key-base build-server-controller)) (('GET "dumps" _ ...) (delegate-to dumps-controller)) (((or 'GET 'POST) "build-server" _ ...) (delegate-to-with-secret-key-base build-server-controller)) (('GET "compare" _ ...) (delegate-to compare-controller)) (('GET "compare-by-datetime" _ ...) (delegate-to compare-controller)) - (('GET "jobs" _ ...) (delegate-to jobs-controller - #:use-reserved-thread-pool? #t)) - (('GET "job" job-id) (delegate-to jobs-controller - #:use-reserved-thread-pool? #t)) - (('GET _ ...) (delegate-to nar-controller - #:use-reserved-thread-pool? #t)) + (('GET "jobs" _ ...) (delegate-to jobs-controller)) + (('GET "job" job-id) (delegate-to jobs-controller)) + (('GET _ ...) (delegate-to nar-controller)) ((method path ...) (render-html #:sxml (general-not-found diff --git a/guix-data-service/web/jobs/controller.scm b/guix-data-service/web/jobs/controller.scm index 47034ee..b8b494d 100644 --- a/guix-data-service/web/jobs/controller.scm +++ b/guix-data-service/web/jobs/controller.scm @@ -20,6 +20,7 @@ #:use-module (guix-data-service utils) #:use-module (guix-data-service database) #:use-module (guix-data-service web render) + #:use-module (guix-data-service web controller) #:use-module (guix-data-service web query-parameters) #:use-module (guix-data-service web util) #:use-module (guix-data-service jobs load-new-guix-revision) @@ -73,14 +74,14 @@ (define limit-results (assq-ref query-parameters 'limit_results)) (letpar& ((jobs - (with-thread-postgresql-connection - (lambda (conn) - (select-jobs-and-events - conn - (assq-ref query-parameters 'before_id) - limit-results)))) + (with-resource-from-pool (connection-pool) conn + (select-jobs-and-events + conn + (assq-ref query-parameters 'before_id) + limit-results))) (recent-events - (with-thread-postgresql-connection + (call-with-resource-from-pool + (connection-pool) select-recent-job-events))) (case (most-appropriate-mime-type '(application/json text/html) @@ -116,14 +117,13 @@ limit-results)))))))) (define (render-job-events mime-types query-parameters) - (letpar& ((recent-events - (with-thread-postgresql-connection - (lambda (conn) - (select-recent-job-events - conn - ;; TODO Ideally there wouldn't be a limit - #:limit (or (assq-ref query-parameters 'limit_results) - 1000000)))))) + (let ((recent-events + (with-resource-from-pool (connection-pool) conn + (select-recent-job-events + conn + ;; TODO Ideally there wouldn't be a limit + #:limit (or (assq-ref query-parameters 'limit_results) + 1000000))))) (render-html #:sxml (view-job-events query-parameters @@ -132,19 +132,18 @@ (define (render-job-queue mime-types) (render-html #:sxml (view-job-queue - (parallel-via-thread-pool-channel - (with-thread-postgresql-connection - select-unprocessed-jobs-and-events))))) + (call-with-resource-from-pool + (connection-pool) + select-unprocessed-jobs-and-events)))) (define (render-job mime-types job-id query-parameters) - (letpar& ((log-text - (with-thread-postgresql-connection - (lambda (conn) - (log-for-job conn job-id - #:character-limit - (assq-ref query-parameters 'characters) - #:start-character - (assq-ref query-parameters 'start_character)))))) + (let ((log-text + (with-resource-from-pool (connection-pool) conn + (log-for-job conn job-id + #:character-limit + (assq-ref query-parameters 'characters) + #:start-character + (assq-ref query-parameters 'start_character))))) (case (most-appropriate-mime-type '(text/plain text/html) mime-types) diff --git a/guix-data-service/web/nar/controller.scm b/guix-data-service/web/nar/controller.scm index 2164860..e2ace7a 100644 --- a/guix-data-service/web/nar/controller.scm +++ b/guix-data-service/web/nar/controller.scm @@ -34,6 +34,7 @@ #:use-module (guix-data-service utils) #:use-module (guix-data-service database) #:use-module (guix-data-service web render) + #:use-module (guix-data-service web controller) #:use-module (guix-data-service web nar html) #:use-module (guix-data-service model derivation) #:export (nar-controller @@ -99,11 +100,9 @@ mime-types file-name) (or - (and=> (parallel-via-thread-pool-channel - (with-thread-postgresql-connection - (lambda (conn) - (select-serialized-derivation-by-file-name conn - file-name)))) + (and=> (with-resource-from-pool (reserved-connection-pool) conn + (select-serialized-derivation-by-file-name conn + file-name)) (lambda (derivation-text) (let ((derivation-bytevector (string->bytevector derivation-text @@ -130,11 +129,9 @@ mime-types file-name) (or - (and=> (parallel-via-thread-pool-channel - (with-thread-postgresql-connection - (lambda (conn) - (select-derivation-source-file-nar-data-by-file-name conn - file-name)))) + (and=> (with-resource-from-pool (reserved-connection-pool) conn + (select-derivation-source-file-nar-data-by-file-name conn + file-name)) (lambda (data) (list (build-response #:code 200 @@ -150,11 +147,9 @@ (define (render-narinfo request hash) (or - (and=> (parallel-via-thread-pool-channel - (with-thread-postgresql-connection - (lambda (conn) - (select-derivation-by-file-name-hash conn - hash)))) + (and=> (with-resource-from-pool (reserved-connection-pool) conn + (select-derivation-by-file-name-hash conn + hash)) (lambda (derivation) (list (build-response #:code 200 @@ -162,17 +157,15 @@ (let ((derivation-file-name (second derivation))) (letpar& ((derivation-text - (with-thread-postgresql-connection - (lambda (conn) - (select-serialized-derivation-by-file-name - conn - derivation-file-name)))) + (with-resource-from-pool (reserved-connection-pool) conn + (select-serialized-derivation-by-file-name + conn + derivation-file-name))) (derivation-references - (with-thread-postgresql-connection - (lambda (conn) - (select-derivation-references-by-derivation-id - conn - (first derivation)))))) + (with-resource-from-pool (reserved-connection-pool) conn + (select-derivation-references-by-derivation-id + conn + (first derivation))))) (let* ((derivation-bytevector (string->bytevector derivation-text "ISO-8859-1")) @@ -195,11 +188,9 @@ (narinfo-string derivation-file-name nar-bytevector derivation-references))))))) - (and=> (parallel-via-thread-pool-channel - (with-thread-postgresql-connection - (lambda (conn) - (select-derivation-source-file-data-by-file-name-hash conn - hash)))) + (and=> (with-resource-from-pool (reserved-connection-pool) conn + (select-derivation-source-file-data-by-file-name-hash conn + hash)) (match-lambda ((store-path compression compressed-size hash-algorithm hash uncompressed-size) diff --git a/guix-data-service/web/package/controller.scm b/guix-data-service/web/package/controller.scm index 465c2a3..8dc6b0f 100644 --- a/guix-data-service/web/package/controller.scm +++ b/guix-data-service/web/package/controller.scm @@ -22,6 +22,7 @@ #:use-module (guix-data-service utils) #:use-module (guix-data-service database) #:use-module (guix-data-service web render) + #:use-module (guix-data-service web controller) #:use-module (guix-data-service web query-parameters) #:use-module (guix-data-service web util) #:use-module (guix-data-service model package) @@ -40,13 +41,12 @@ `((system ,parse-system #:default "x86_64-linux") (target ,parse-target #:default ""))))) (letpar& ((package-versions-with-branches - (with-thread-postgresql-connection - (lambda (conn) - (branches-by-package-version conn name - (assq-ref parsed-query-parameters - 'system) - (assq-ref parsed-query-parameters - 'target)))))) + (with-resource-from-pool (connection-pool) conn + (branches-by-package-version conn name + (assq-ref parsed-query-parameters + 'system) + (assq-ref parsed-query-parameters + 'target))))) (case (most-appropriate-mime-type '(application/json text/html) mime-types) diff --git a/guix-data-service/web/repository/controller.scm b/guix-data-service/web/repository/controller.scm index cf6d07f..6724d6f 100644 --- a/guix-data-service/web/repository/controller.scm +++ b/guix-data-service/web/repository/controller.scm @@ -34,6 +34,7 @@ #:use-module (guix-data-service model git-repository) #:use-module (guix-data-service web view html) #:use-module (guix-data-service web revision controller) + #:use-module (guix-data-service web controller) #:use-module (guix-data-service web repository html) #:export (repository-controller)) @@ -47,7 +48,7 @@ (match method-and-path-components (('GET "repositories") (letpar& ((git-repositories - (with-thread-postgresql-connection + (with-resource-from-pool (connection-pool) conn all-git-repositories))) (case (most-appropriate-mime-type '(application/json text/html) @@ -67,17 +68,14 @@ #:sxml (view-git-repositories git-repositories)))))) (('GET "repository" id) - (match (parallel-via-thread-pool-channel - (with-thread-postgresql-connection - (lambda (conn) - (select-git-repository conn id)))) + (match (with-resource-from-pool (connection-pool) conn + (select-git-repository conn id)) ((label url cgit-url-base fetch-with-authentication?) (letpar& ((branches - (with-thread-postgresql-connection - (lambda (conn) - (all-branches-with-most-recent-commit - conn - (string->number id)))))) + (with-resource-from-pool (connection-pool) conn + (all-branches-with-most-recent-commit + conn + (string->number id))))) (case (most-appropriate-mime-type '(application/json text/html) mime-types) @@ -122,17 +120,16 @@ (before_date ,parse-datetime) (limit_results ,parse-result-limit #:default 100))))) (letpar& ((revisions - (with-thread-postgresql-connection - (lambda (conn) - (most-recent-commits-for-branch - conn - (string->number repository-id) - branch-name - #:limit (assq-ref parsed-query-parameters 'limit_results) - #:after-date (assq-ref parsed-query-parameters - 'after_date) - #:before-date (assq-ref parsed-query-parameters - 'before_date)))))) + (with-resource-from-pool (connection-pool) conn + (most-recent-commits-for-branch + conn + (string->number repository-id) + branch-name + #:limit (assq-ref parsed-query-parameters 'limit_results) + #:after-date (assq-ref parsed-query-parameters + 'after_date) + #:before-date (assq-ref parsed-query-parameters + 'before_date))))) (case (most-appropriate-mime-type '(application/json text/html) mime-types) @@ -164,12 +161,11 @@ revisions))))))))) (('GET "repository" repository-id "branch" branch-name "package" package-name) (letpar& ((package-versions - (with-thread-postgresql-connection - (lambda (conn) - (package-versions-for-branch conn - (string->number repository-id) - branch-name - package-name))))) + (with-resource-from-pool (connection-pool) conn + (package-versions-for-branch conn + (string->number repository-id) + branch-name + package-name)))) (case (most-appropriate-mime-type '(application/json text/html) mime-types) @@ -216,17 +212,17 @@ request `((system ,parse-system #:default "x86_64-linux"))))) (letpar& ((system-test-history - (with-thread-postgresql-connection - (lambda (conn) - (system-test-derivations-for-branch - conn - (string->number repository-id) - branch-name - (assq-ref parsed-query-parameters - 'system) - system-test-name)))) + (with-resource-from-pool (connection-pool) conn + (system-test-derivations-for-branch + conn + (string->number repository-id) + branch-name + (assq-ref parsed-query-parameters + 'system) + system-test-name))) (valid-systems - (with-thread-postgresql-connection list-systems))) + (call-with-resource-from-pool (connection-pool) + list-systems))) (case (most-appropriate-mime-type '(application/json text/html) mime-types) @@ -261,11 +257,10 @@ system-test-history))))))) (('GET "repository" repository-id "branch" branch-name "latest-processed-revision") (letpar& ((commit-hash - (with-thread-postgresql-connection - (lambda (conn) - (latest-processed-commit-for-branch conn - repository-id - branch-name))))) + (with-resource-from-pool (connection-pool) conn + (latest-processed-commit-for-branch conn + repository-id + branch-name)))) (if commit-hash (render-view-revision mime-types commit-hash @@ -278,11 +273,10 @@ branch-name)))) (('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "packages") (letpar& ((commit-hash - (with-thread-postgresql-connection - (lambda (conn) - (latest-processed-commit-for-branch conn - repository-id - branch-name))))) + (with-resource-from-pool (connection-pool) conn + (latest-processed-commit-for-branch conn + repository-id + branch-name)))) (if commit-hash (let ((parsed-query-parameters (guard-against-mutually-exclusive-query-parameters @@ -319,11 +313,10 @@ branch-name)))) (('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "package-derivations") (letpar& ((commit-hash - (with-thread-postgresql-connection - (lambda (conn) - (latest-processed-commit-for-branch conn - repository-id - branch-name))))) + (with-resource-from-pool (connection-pool) conn + (latest-processed-commit-for-branch conn + repository-id + branch-name)))) (if commit-hash (let ((parsed-query-parameters (guard-against-mutually-exclusive-query-parameters @@ -353,12 +346,11 @@ branch-name)))) (('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "fixed-output-package-derivations") - (letpar& ((commit-hash - (with-thread-postgresql-connection - (lambda (conn) - (latest-processed-commit-for-branch conn - repository-id - branch-name))))) + (let ((commit-hash + (with-resource-from-pool (connection-pool) conn + (latest-processed-commit-for-branch conn + repository-id + branch-name)))) (if commit-hash (let ((parsed-query-parameters (guard-against-mutually-exclusive-query-parameters @@ -383,12 +375,11 @@ repository-id branch-name)))) (('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "package-derivation-outputs") - (letpar& ((commit-hash - (with-thread-postgresql-connection - (lambda (conn) - (latest-processed-commit-for-branch conn - repository-id - branch-name))))) + (let ((commit-hash + (with-resource-from-pool (connection-pool) conn + (latest-processed-commit-for-branch conn + repository-id + branch-name)))) (if commit-hash (let ((parsed-query-parameters (guard-against-mutually-exclusive-query-parameters @@ -431,11 +422,10 @@ (('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "system-tests") (letpar& ((commit-hash - (with-thread-postgresql-connection - (lambda (conn) - (latest-processed-commit-for-branch conn - repository-id - branch-name))))) + (with-resource-from-pool (connection-pool) conn + (latest-processed-commit-for-branch conn + repository-id + branch-name)))) (if commit-hash (let ((parsed-query-parameters (parse-query-parameters @@ -450,11 +440,10 @@ branch-name)))) (('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "package-reproducibility") (letpar& ((commit-hash - (with-thread-postgresql-connection - (lambda (conn) - (latest-processed-commit-for-branch conn - repository-id - branch-name))))) + (with-resource-from-pool (connection-pool) conn + (latest-processed-commit-for-branch conn + repository-id + branch-name)))) (if commit-hash (render-revision-package-reproduciblity mime-types @@ -473,11 +462,10 @@ branch-name)))) (('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "package-substitute-availability") (letpar& ((commit-hash - (with-thread-postgresql-connection - (lambda (conn) - (latest-processed-commit-for-branch conn - repository-id - branch-name))))) + (with-resource-from-pool (connection-pool) conn + (latest-processed-commit-for-branch conn + repository-id + branch-name)))) (if commit-hash (render-revision-package-substitute-availability mime-types commit-hash @@ -488,11 +476,10 @@ (('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "lint-warnings") (letpar& ((commit-hash - (with-thread-postgresql-connection - (lambda (conn) - (latest-processed-commit-for-branch conn - repository-id - branch-name))))) + (with-resource-from-pool (connection-pool) conn + (latest-processed-commit-for-branch conn + repository-id + branch-name)))) (if commit-hash (let ((parsed-query-parameters (parse-query-parameters @@ -523,11 +510,10 @@ branch-name)))) (('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "package" name version) (letpar& ((commit-hash - (with-thread-postgresql-connection - (lambda (conn) - (latest-processed-commit-for-branch conn - repository-id - branch-name))))) + (with-resource-from-pool (connection-pool) conn + (latest-processed-commit-for-branch conn + repository-id + branch-name)))) (let ((parsed-query-parameters (parse-query-parameters request @@ -558,9 +544,9 @@ (define (parse-build-system) (let ((systems - (parallel-via-thread-pool-channel - (with-thread-postgresql-connection - list-systems)))) + (call-with-resource-from-pool + (connection-pool) + list-systems))) (lambda (s) (if (member s systems) s @@ -598,16 +584,15 @@ (assq-ref parsed-query-parameters 'target))) (letpar& ((package-derivations - (with-thread-postgresql-connection - (lambda (conn) - (package-derivations-for-branch conn - (string->number repository-id) - branch-name - system - target - package-name)))) + (with-resource-from-pool (connection-pool) conn + (package-derivations-for-branch conn + (string->number repository-id) + branch-name + system + target + package-name))) (build-server-urls - (with-thread-postgresql-connection + (call-with-resource-from-pool (connection-pool) select-build-server-urls-by-id))) (case (most-appropriate-mime-type '(application/json text/html) @@ -635,10 +620,10 @@ package-derivations)))))) (else (letpar& ((systems - (with-thread-postgresql-connection + (with-resource-from-pool (connection-pool) conn list-systems)) (targets - (with-thread-postgresql-connection + (with-resource-from-pool (connection-pool) conn valid-targets))) (render-html #:sxml (view-branch-package-derivations @@ -673,17 +658,17 @@ (assq-ref parsed-query-parameters 'output))) (letpar& ((package-outputs - (with-thread-postgresql-connection - (lambda (conn) - (package-outputs-for-branch conn - (string->number repository-id) - branch-name - system - target - package-name - output-name)))) + (with-resource-from-pool (connection-pool) conn + (package-outputs-for-branch conn + (string->number repository-id) + branch-name + system + target + package-name + output-name))) (build-server-urls - (with-thread-postgresql-connection + (call-with-resource-from-pool + (connection-pool) select-build-server-urls-by-id))) (case (most-appropriate-mime-type '(application/json text/html) @@ -711,10 +696,10 @@ package-outputs)))))) (else (letpar& ((systems - (with-thread-postgresql-connection + (with-resource-from-pool (connection-pool) conn list-systems)) (targets - (with-thread-postgresql-connection + (with-resource-from-pool (connection-pool) conn valid-targets))) (render-html #:sxml (view-branch-package-outputs diff --git a/guix-data-service/web/revision/controller.scm b/guix-data-service/web/revision/controller.scm index 1cb4528..9cfddd4 100644 --- a/guix-data-service/web/revision/controller.scm +++ b/guix-data-service/web/revision/controller.scm @@ -30,6 +30,7 @@ #:use-module (guix-data-service web sxml) #:use-module (guix-data-service web query-parameters) #:use-module (guix-data-service web util) + #:use-module (guix-data-service web controller) #:use-module (guix-data-service model utils) #:use-module (guix-data-service jobs load-new-guix-revision) #:use-module (guix-data-service model build) @@ -84,7 +85,7 @@ (define (parse-build-server v) (letpar& ((build-servers - (with-thread-postgresql-connection select-build-servers))) + (with-resource-from-pool (connection-pool) conn select-build-servers))) (or (any (match-lambda ((id url lookup-all-derivations? lookup-builds?) (if (eq? (string->number v) @@ -105,20 +106,16 @@ (match method-and-path-components (('GET "revision" commit-hash) - (if (parallel-via-thread-pool-channel - (with-thread-postgresql-connection - (lambda (conn) - (guix-revision-loaded-successfully? conn commit-hash)))) + (if (with-resource-from-pool (connection-pool) conn + (guix-revision-loaded-successfully? conn commit-hash)) (render-view-revision mime-types commit-hash #:path-base path) (render-unknown-revision mime-types commit-hash))) (('GET "revision" commit-hash "news") - (if (parallel-via-thread-pool-channel - (with-thread-postgresql-connection - (lambda (conn) - (guix-revision-loaded-successfully? conn commit-hash)))) + (if (with-resource-from-pool (connection-pool) conn + (guix-revision-loaded-successfully? conn commit-hash)) (let ((parsed-query-parameters (parse-query-parameters request @@ -129,10 +126,8 @@ (render-unprocessed-revision mime-types commit-hash))) (('GET "revision" commit-hash "packages") - (if (parallel-via-thread-pool-channel - (with-thread-postgresql-connection - (lambda (conn) - (guix-revision-loaded-successfully? conn commit-hash)))) + (if (with-resource-from-pool (connection-pool) conn + (guix-revision-loaded-successfully? conn commit-hash)) (let ((parsed-query-parameters (guard-against-mutually-exclusive-query-parameters (parse-query-parameters @@ -158,30 +153,24 @@ (render-unprocessed-revision mime-types commit-hash))) (('GET "revision" commit-hash "packages-translation-availability") - (if (parallel-via-thread-pool-channel - (with-thread-postgresql-connection - (lambda (conn) - (guix-revision-loaded-successfully? conn commit-hash)))) + (if (with-resource-from-pool (connection-pool) conn + (guix-revision-loaded-successfully? conn commit-hash)) (render-revision-packages-translation-availability mime-types commit-hash #:path-base path) (render-unprocessed-revision mime-types commit-hash))) (('GET "revision" commit-hash "package" name) - (if (parallel-via-thread-pool-channel - (with-thread-postgresql-connection - (lambda (conn) - (guix-revision-loaded-successfully? conn commit-hash)))) + (if (with-resource-from-pool (connection-pool) conn + (guix-revision-loaded-successfully? conn commit-hash)) (render-revision-package mime-types commit-hash name) (render-unprocessed-revision mime-types commit-hash))) (('GET "revision" commit-hash "package" name version) - (if (parallel-via-thread-pool-channel - (with-thread-postgresql-connection - (lambda (conn) - (guix-revision-loaded-successfully? conn commit-hash)))) + (if (with-resource-from-pool (connection-pool) conn + (guix-revision-loaded-successfully? conn commit-hash)) (let ((parsed-query-parameters (parse-query-parameters request @@ -194,10 +183,8 @@ (render-unprocessed-revision mime-types commit-hash))) (('GET "revision" commit-hash "package-derivations") - (if (parallel-via-thread-pool-channel - (with-thread-postgresql-connection - (lambda (conn) - (guix-revision-loaded-successfully? conn commit-hash)))) + (if (with-resource-from-pool (connection-pool) conn + (guix-revision-loaded-successfully? conn commit-hash)) (let ((parsed-query-parameters (guard-against-mutually-exclusive-query-parameters (parse-query-parameters @@ -228,10 +215,8 @@ (render-unprocessed-revision mime-types commit-hash))) (('GET "revision" commit-hash "fixed-output-package-derivations") - (if (parallel-via-thread-pool-channel - (with-thread-postgresql-connection - (lambda (conn) - (guix-revision-loaded-successfully? conn commit-hash)))) + (if (with-resource-from-pool (connection-pool) conn + (guix-revision-loaded-successfully? conn commit-hash)) (let ((parsed-query-parameters (guard-against-mutually-exclusive-query-parameters (parse-query-parameters @@ -254,10 +239,8 @@ (render-unprocessed-revision mime-types commit-hash))) (('GET "revision" commit-hash "package-derivation-outputs") - (if (parallel-via-thread-pool-channel - (with-thread-postgresql-connection - (lambda (conn) - (guix-revision-loaded-successfully? conn commit-hash)))) + (if (with-resource-from-pool (connection-pool) conn + (guix-revision-loaded-successfully? conn commit-hash)) (let ((parsed-query-parameters (guard-against-mutually-exclusive-query-parameters (parse-query-parameters @@ -287,10 +270,8 @@ (render-unprocessed-revision mime-types commit-hash))) (('GET "revision" commit-hash "system-tests") - (if (parallel-via-thread-pool-channel - (with-thread-postgresql-connection - (lambda (conn) - (guix-revision-loaded-successfully? conn commit-hash)))) + (if (with-resource-from-pool (connection-pool) conn + (guix-revision-loaded-successfully? conn commit-hash)) (let ((parsed-query-parameters (parse-query-parameters request @@ -302,40 +283,32 @@ (render-unprocessed-revision mime-types commit-hash))) (('GET "revision" commit-hash "channel-instances") - (if (parallel-via-thread-pool-channel - (with-thread-postgresql-connection - (lambda (conn) - (channel-instances-exist-for-guix-revision? conn commit-hash)))) + (if (with-resource-from-pool (connection-pool) conn + (channel-instances-exist-for-guix-revision? conn commit-hash)) (render-revision-channel-instances mime-types commit-hash #:path-base path) (render-unprocessed-revision mime-types commit-hash))) (('GET "revision" commit-hash "package-substitute-availability") - (if (parallel-via-thread-pool-channel - (with-thread-postgresql-connection - (lambda (conn) - (guix-revision-loaded-successfully? conn commit-hash)))) + (if (with-resource-from-pool (connection-pool) conn + (guix-revision-loaded-successfully? conn commit-hash)) (render-revision-package-substitute-availability mime-types commit-hash #:path-base path) (render-unprocessed-revision mime-types commit-hash))) (('GET "revision" commit-hash "package-reproducibility") - (if (parallel-via-thread-pool-channel - (with-thread-postgresql-connection - (lambda (conn) - (guix-revision-loaded-successfully? conn commit-hash)))) + (if (with-resource-from-pool (connection-pool) conn + (guix-revision-loaded-successfully? conn commit-hash)) (render-revision-package-reproduciblity mime-types commit-hash #:path-base path) (render-unprocessed-revision mime-types commit-hash))) (('GET "revision" commit-hash "builds") - (if (parallel-via-thread-pool-channel - (with-thread-postgresql-connection - (lambda (conn) - (guix-revision-loaded-successfully? conn commit-hash)))) + (if (with-resource-from-pool (connection-pool) conn + (guix-revision-loaded-successfully? conn commit-hash)) (let ((parsed-query-parameters (guard-against-mutually-exclusive-query-parameters (parse-query-parameters @@ -357,10 +330,8 @@ (render-unprocessed-revision mime-types commit-hash))) (('GET "revision" commit-hash "blocking-builds") - (if (parallel-via-thread-pool-channel - (with-thread-postgresql-connection - (lambda (conn) - (guix-revision-loaded-successfully? conn commit-hash)))) + (if (with-resource-from-pool (connection-pool) conn + (guix-revision-loaded-successfully? conn commit-hash)) (let ((parsed-query-parameters (guard-against-mutually-exclusive-query-parameters (parse-query-parameters @@ -381,10 +352,8 @@ (render-unprocessed-revision mime-types commit-hash))) (('GET "revision" commit-hash "lint-warnings") - (if (parallel-via-thread-pool-channel - (with-thread-postgresql-connection - (lambda (conn) - (guix-revision-loaded-successfully? conn commit-hash)))) + (if (with-resource-from-pool (connection-pool) conn + (guix-revision-loaded-successfully? conn commit-hash)) (let ((parsed-query-parameters (parse-query-parameters request @@ -424,18 +393,15 @@ #:code 404)) (else (letpar& ((job - (with-thread-postgresql-connection - (lambda (conn) - (select-job-for-commit conn commit-hash)))) + (with-resource-from-pool (connection-pool) conn + (select-job-for-commit conn commit-hash))) (git-repositories-and-branches - (with-thread-postgresql-connection - (lambda (conn) - (git-branches-with-repository-details-for-commit conn - commit-hash)))) + (with-resource-from-pool (connection-pool) conn + (git-branches-with-repository-details-for-commit conn + commit-hash))) (jobs-and-events - (with-thread-postgresql-connection - (lambda (conn) - (select-jobs-and-events-for-commit conn commit-hash))))) + (with-resource-from-pool (connection-pool) conn + (select-jobs-and-events-for-commit conn commit-hash)))) (render-html #:code 404 @@ -455,18 +421,15 @@ #:code 404)) (else (letpar& ((job - (with-thread-postgresql-connection - (lambda (conn) - (select-job-for-commit conn commit-hash)))) + (with-resource-from-pool (connection-pool) conn + (select-job-for-commit conn commit-hash))) (git-repositories-and-branches - (with-thread-postgresql-connection - (lambda (conn) - (git-branches-with-repository-details-for-commit conn - commit-hash)))) + (with-resource-from-pool (connection-pool) conn + (git-branches-with-repository-details-for-commit conn + commit-hash))) (jobs-and-events - (with-thread-postgresql-connection - (lambda (conn) - (select-jobs-and-events-for-commit conn commit-hash))))) + (with-resource-from-pool (connection-pool) conn + (select-jobs-and-events-for-commit conn commit-hash)))) (render-html #:code 404 @@ -482,27 +445,22 @@ (header-text `("Revision " (samp ,commit-hash)))) (letpar& ((packages-count - (with-thread-postgresql-connection - (lambda (conn) - (count-packages-in-revision conn commit-hash)))) + (with-resource-from-pool (connection-pool) conn + (count-packages-in-revision conn commit-hash))) (git-repositories-and-branches - (with-thread-postgresql-connection - (lambda (conn) - (git-branches-with-repository-details-for-commit conn - commit-hash)))) + (with-resource-from-pool (connection-pool) conn + (git-branches-with-repository-details-for-commit conn + commit-hash))) (derivations-counts - (with-thread-postgresql-connection - (lambda (conn) - (count-packages-derivations-in-revision conn commit-hash)))) + (with-resource-from-pool (connection-pool) conn + (count-packages-derivations-in-revision conn commit-hash))) (jobs-and-events - (with-thread-postgresql-connection - (lambda (conn) - (select-jobs-and-events-for-commit conn commit-hash)))) + (with-resource-from-pool (connection-pool) conn + (select-jobs-and-events-for-commit conn commit-hash))) (lint-warning-counts - (with-thread-postgresql-connection - (lambda (conn) - (lint-warning-count-by-lint-checker-for-revision conn - commit-hash))))) + (with-resource-from-pool (connection-pool) conn + (lint-warning-count-by-lint-checker-for-revision conn + commit-hash)))) (case (most-appropriate-mime-type '(application/json text/html) mime-types) @@ -547,12 +505,11 @@ (header-link (string-append "/revision/" commit-hash))) (letpar& ((system-tests - (with-thread-postgresql-connection - (lambda (conn) - (select-system-tests-for-guix-revision - conn - (assq-ref query-parameters 'system) - commit-hash))))) + (with-resource-from-pool (connection-pool) conn + (select-system-tests-for-guix-revision + conn + (assq-ref query-parameters 'system) + commit-hash)))) (case (most-appropriate-mime-type '(application/json text/html) mime-types) @@ -576,12 +533,11 @@ system-tests)))))) (else (letpar& ((git-repositories - (with-thread-postgresql-connection - (lambda (conn) - (git-repositories-containing-commit conn - commit-hash)))) + (with-resource-from-pool (connection-pool) conn + (git-repositories-containing-commit conn + commit-hash))) (systems - (with-thread-postgresql-connection list-systems))) + (with-resource-from-pool (connection-pool) conn list-systems))) (render-html #:sxml (view-revision-system-tests commit-hash @@ -603,9 +559,8 @@ (string-append "/revision/" commit-hash))) (letpar& ((channel-instances - (with-thread-postgresql-connection - (lambda (conn) - (select-channel-instances-for-guix-revision conn commit-hash))))) + (with-resource-from-pool (connection-pool) conn + (select-channel-instances-for-guix-revision conn commit-hash)))) (case (most-appropriate-mime-type '(application/json text/html) mime-types) @@ -632,12 +587,12 @@ commit-hash #:key path-base) (letpar& ((substitute-availability - (with-thread-postgresql-connection - (lambda (conn) - (select-package-output-availability-for-revision conn - commit-hash)))) + (with-resource-from-pool (connection-pool) conn + (select-package-output-availability-for-revision conn + commit-hash))) (build-server-urls - (with-thread-postgresql-connection + (call-with-resource-from-pool + (connection-pool) select-build-server-urls-by-id))) (case (most-appropriate-mime-type '(application/json text/html) @@ -678,9 +633,8 @@ (string-append "/revision/" commit-hash))) (letpar& ((output-consistency - (with-thread-postgresql-connection - (lambda (conn) - (select-output-consistency-for-revision conn commit-hash))))) + (with-resource-from-pool (connection-pool) conn + (select-output-consistency-for-revision conn commit-hash)))) (case (most-appropriate-mime-type '(application/json text/html) mime-types) @@ -713,11 +667,10 @@ query-parameters '())))) (letpar& ((news-entries - (with-thread-postgresql-connection - (lambda (conn) - (select-channel-news-entries-contained-in-guix-revision - conn - commit-hash))))) + (with-resource-from-pool (connection-pool) conn + (select-channel-news-entries-contained-in-guix-revision + conn + commit-hash)))) (case (most-appropriate-mime-type '(application/json text/html) mime-types) @@ -774,26 +727,24 @@ (locale (assq-ref query-parameters 'locale))) (letpar& ((packages - (with-thread-postgresql-connection - (lambda (conn) - (if search-query - (search-packages-in-revision - conn - commit-hash - search-query - #:limit-results limit-results - #:locale locale) - (select-packages-in-revision - conn - commit-hash - #:limit-results limit-results - #:after-name (assq-ref query-parameters 'after_name) - #:locale (assq-ref query-parameters 'locale)))))) + (with-resource-from-pool (connection-pool) conn + (if search-query + (search-packages-in-revision + conn + commit-hash + search-query + #:limit-results limit-results + #:locale locale) + (select-packages-in-revision + conn + commit-hash + #:limit-results limit-results + #:after-name (assq-ref query-parameters 'after_name) + #:locale (assq-ref query-parameters 'locale))))) (git-repositories - (with-thread-postgresql-connection - (lambda (conn) - (git-repositories-containing-commit conn - commit-hash))))) + (with-resource-from-pool (connection-pool) conn + (git-repositories-containing-commit conn + commit-hash)))) (let ((show-next-page? (and (not search-query) (>= (length packages) @@ -843,14 +794,12 @@ packages)))) #:extra-headers http-headers-for-unchanging-content)) (else - (letpar& - ((locale-options - (with-thread-postgresql-connection - (lambda (conn) + (let ((locale-options + (with-resource-from-pool (connection-pool) conn (description-and-synopsis-locale-options (package-description-and-synopsis-locale-options-guix-revision conn - (commit->revision-id conn commit-hash))))))) + (commit->revision-id conn commit-hash)))))) (render-html #:sxml (view-revision-packages commit-hash query-parameters @@ -874,19 +823,17 @@ (header-text `("Revision " (samp ,commit-hash)))) (letpar& ((package-synopsis-counts - (with-thread-postgresql-connection - (lambda (conn) - (synopsis-counts-by-locale conn - (commit->revision-id - conn - commit-hash))))) + (with-resource-from-pool (connection-pool) conn + (synopsis-counts-by-locale conn + (commit->revision-id + conn + commit-hash)))) (package-description-counts - (with-thread-postgresql-connection - (lambda (conn) - (description-counts-by-locale conn - (commit->revision-id - conn - commit-hash)))))) + (with-resource-from-pool (connection-pool) conn + (description-counts-by-locale conn + (commit->revision-id + conn + commit-hash))))) (case (most-appropriate-mime-type '(application/json text/html) mime-types) @@ -916,16 +863,14 @@ (string-append "/revision/" commit-hash))) (letpar& ((package-versions - (with-thread-postgresql-connection - (lambda (conn) - (select-package-versions-for-revision conn - commit-hash - name)))) + (with-resource-from-pool (connection-pool) conn + (select-package-versions-for-revision conn + commit-hash + name))) (git-repositories-and-branches - (with-thread-postgresql-connection - (lambda (conn) - (git-branches-with-repository-details-for-commit conn - commit-hash))))) + (with-resource-from-pool (connection-pool) conn + (git-branches-with-repository-details-for-commit conn + commit-hash)))) (case (most-appropriate-mime-type '(application/json text/html) mime-types) @@ -963,48 +908,42 @@ (match-lambda ((locale) locale)) - (parallel-via-thread-pool-channel - (with-thread-postgresql-connection - (lambda (conn) - (delete-duplicates - (append - (package-description-and-synopsis-locale-options-guix-revision - conn (commit->revision-id conn commit-hash)) - (lint-warning-message-locales-for-revision conn commit-hash)))))))) + (with-resource-from-pool (connection-pool) conn + (delete-duplicates + (append + (package-description-and-synopsis-locale-options-guix-revision + conn (commit->revision-id conn commit-hash)) + (lint-warning-message-locales-for-revision conn commit-hash)))))) (define locale (assq-ref query-parameters 'locale)) (letpar& ((metadata - (with-thread-postgresql-connection - (lambda (conn) - (select-package-metadata-by-revision-name-and-version - conn - commit-hash - name - version - locale)))) + (with-resource-from-pool (connection-pool) conn + (select-package-metadata-by-revision-name-and-version + conn + commit-hash + name + version + locale))) (derivations - (with-thread-postgresql-connection - (lambda (conn) - (select-derivations-by-revision-name-and-version - conn - commit-hash - name - version)))) + (with-resource-from-pool (connection-pool) conn + (select-derivations-by-revision-name-and-version + conn + commit-hash + name + version))) (git-repositories - (with-thread-postgresql-connection - (lambda (conn) - (git-repositories-containing-commit conn - commit-hash)))) + (with-resource-from-pool (connection-pool) conn + (git-repositories-containing-commit conn + commit-hash))) (lint-warnings - (with-thread-postgresql-connection - (lambda (conn) - (select-lint-warnings-by-revision-package-name-and-version - conn - commit-hash - name - version - #:locale locale))))) + (with-resource-from-pool (connection-pool) conn + (select-lint-warnings-by-revision-package-name-and-version + conn + commit-hash + name + version + #:locale locale)))) (case (most-appropriate-mime-type '(application/json text/html) mime-types) @@ -1062,9 +1001,11 @@ `((error . "invalid query")))) (else (letpar& ((systems - (with-thread-postgresql-connection list-systems)) + (call-with-resource-from-pool (connection-pool) + list-systems)) (targets - (with-thread-postgresql-connection valid-targets))) + (call-with-resource-from-pool (connection-pool) + valid-targets))) (render-html #:sxml (view-revision-package-derivations commit-hash query-parameters @@ -1087,46 +1028,45 @@ (assq-ref query-parameters 'field))) (letpar& ((derivations - (with-thread-postgresql-connection - (lambda (conn) - (if search-query - (search-package-derivations-in-revision - conn - commit-hash - search-query - #: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)) - (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)))))) + (with-resource-from-pool (connection-pool) conn + (if search-query + (search-package-derivations-in-revision + conn + commit-hash + search-query + #: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)) + (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))))) (build-server-urls - (with-thread-postgresql-connection + (with-resource-from-pool (connection-pool) conn select-build-server-urls-by-id))) (let ((show-next-page? (if all-results @@ -1161,9 +1101,11 @@ derivations)))))) (else (letpar& ((systems - (with-thread-postgresql-connection list-systems)) + (call-with-resource-from-pool (connection-pool) + list-systems)) (targets - (with-thread-postgresql-connection valid-targets))) + (call-with-resource-from-pool (connection-pool) + valid-targets))) (render-html #:sxml (view-revision-package-derivations commit-hash @@ -1197,9 +1139,11 @@ `((error . "invalid query")))) (else (letpar& ((systems - (with-thread-postgresql-connection list-systems)) + (call-with-resource-from-pool (connection-pool) + list-systems)) (targets - (with-thread-postgresql-connection valid-targets))) + (call-with-resource-from-pool (connection-pool) + valid-targets))) (render-html #:sxml (view-revision-fixed-output-package-derivations commit-hash @@ -1222,20 +1166,19 @@ (assq-ref query-parameters 'field))) (letpar& ((derivations - (with-thread-postgresql-connection - (lambda (conn) - (select-fixed-output-package-derivations-in-revision - conn - commit-hash - (assq-ref query-parameters 'system) - (assq-ref query-parameters 'target) - #:latest-build-status (assq-ref query-parameters - 'latest_build_status) - #:limit-results limit-results - #:after-derivation-file-name - (assq-ref query-parameters 'after_name))))) + (with-resource-from-pool (connection-pool) conn + (select-fixed-output-package-derivations-in-revision + conn + commit-hash + (assq-ref query-parameters 'system) + (assq-ref query-parameters 'target) + #:latest-build-status (assq-ref query-parameters + 'latest_build_status) + #:limit-results limit-results + #:after-derivation-file-name + (assq-ref query-parameters 'after_name)))) (build-server-urls - (with-thread-postgresql-connection + (with-resource-from-pool (connection-pool) conn select-build-server-urls-by-id))) (let ((show-next-page? (if all-results @@ -1251,9 +1194,11 @@ `((derivations . ,(list->vector derivations))))) (else (letpar& ((systems - (with-thread-postgresql-connection list-systems)) + (call-with-resource-from-pool (connection-pool) + list-systems)) (targets - (with-thread-postgresql-connection valid-targets))) + (call-with-resource-from-pool (connection-pool) + valid-targets))) (render-html #:sxml (view-revision-fixed-output-package-derivations commit-hash @@ -1278,8 +1223,9 @@ (header-link (string-append "/revision/" commit-hash))) (define build-server-urls - (parallel-via-thread-pool-channel - (with-thread-postgresql-connection select-build-server-urls-by-id))) + (call-with-resource-from-pool + (connection-pool) + select-build-server-urls-by-id)) (if (any-invalid-query-parameters? query-parameters) (case (most-appropriate-mime-type @@ -1290,9 +1236,11 @@ `((error . "invalid query")))) (else (letpar& ((systems - (with-thread-postgresql-connection list-systems)) + (call-with-resource-from-pool (connection-pool) + list-systems)) (targets - (with-thread-postgresql-connection valid-targets))) + (call-with-resource-from-pool (connection-pool) + valid-targets))) (render-html #:sxml (view-revision-package-derivation-outputs commit-hash @@ -1313,23 +1261,22 @@ (assq-ref query-parameters 'field))) (letpar& ((derivation-outputs - (with-thread-postgresql-connection - (lambda (conn) - (select-derivation-outputs-in-revision - conn - commit-hash - #:search-query (assq-ref query-parameters 'search_query) - #:nars-from-build-servers - (assq-ref query-parameters 'substitutes_available_from) - #:no-nars-from-build-servers - (assq-ref query-parameters 'substitutes_not_available_from) - #:output-consistency - (assq-ref query-parameters 'output_consistency) - #:system (assq-ref query-parameters 'system) - #:target (assq-ref query-parameters 'target) - #:include-nars? (member "nars" fields) - #:limit-results limit-results - #:after-path (assq-ref query-parameters 'after_path)))))) + (with-resource-from-pool (connection-pool) conn + (select-derivation-outputs-in-revision + conn + commit-hash + #:search-query (assq-ref query-parameters 'search_query) + #:nars-from-build-servers + (assq-ref query-parameters 'substitutes_available_from) + #:no-nars-from-build-servers + (assq-ref query-parameters 'substitutes_not_available_from) + #:output-consistency + (assq-ref query-parameters 'output_consistency) + #:system (assq-ref query-parameters 'system) + #:target (assq-ref query-parameters 'target) + #:include-nars? (member "nars" fields) + #:limit-results limit-results + #:after-path (assq-ref query-parameters 'after_path))))) (let ((show-next-page? (if all-results #f @@ -1395,9 +1342,11 @@ derivation-outputs)))))) (else (letpar& ((systems - (with-thread-postgresql-connection list-systems)) + (call-with-resource-from-pool (connection-pool) + list-systems)) (targets - (with-thread-postgresql-connection valid-targets))) + (call-with-resource-from-pool (connection-pool) + valid-targets))) (render-html #:sxml (view-revision-package-derivation-outputs commit-hash @@ -1422,9 +1371,11 @@ (string-append "/revision/" commit-hash))) (if (any-invalid-query-parameters? query-parameters) (letpar& ((systems - (with-thread-postgresql-connection list-systems)) + (call-with-resource-from-pool (connection-pool) + list-systems)) (targets - (with-thread-postgresql-connection valid-targets))) + (call-with-resource-from-pool (connection-pool) + valid-targets))) (render-html #:sxml (view-revision-builds query-parameters @@ -1438,41 +1389,40 @@ (let ((system (assq-ref query-parameters 'system)) (target (assq-ref query-parameters 'target))) (letpar& ((systems - (with-thread-postgresql-connection list-systems)) + (call-with-resource-from-pool (connection-pool) + list-systems)) (targets - (with-thread-postgresql-connection valid-targets)) + (call-with-resource-from-pool (connection-pool) + valid-targets)) (build-server-options - (with-thread-postgresql-connection - (lambda (conn) - (map (match-lambda - ((id url lookup-all-derivations - lookup-builds) - (cons url id))) - (select-build-servers conn))))) + (with-resource-from-pool (connection-pool) conn + (map (match-lambda + ((id url lookup-all-derivations + lookup-builds) + (cons url id))) + (select-build-servers conn)))) (stats - (with-thread-postgresql-connection - (lambda (conn) - (select-build-stats - conn - (assq-ref query-parameters - 'build_server) - #:revision-commit commit-hash - #:system system - #:target target)))) + (with-resource-from-pool (connection-pool) conn + (select-build-stats + conn + (assq-ref query-parameters + 'build_server) + #:revision-commit commit-hash + #:system system + #:target target))) (builds - (with-thread-postgresql-connection - (lambda (conn) - (select-builds-with-context - conn - (assq-ref query-parameters - 'build_status) - (assq-ref query-parameters - 'build_server) - #:revision-commit commit-hash - #:system system - #:target target - #:limit (assq-ref query-parameters - 'limit_results)))))) + (with-resource-from-pool (connection-pool) conn + (select-builds-with-context + conn + (assq-ref query-parameters + 'build_status) + (assq-ref query-parameters + 'build_server) + #:revision-commit commit-hash + #:system system + #:target target + #:limit (assq-ref query-parameters + 'limit_results))))) (render-html #:sxml (view-revision-builds query-parameters commit-hash @@ -1494,9 +1444,11 @@ (string-append "/revision/" commit-hash))) (if (any-invalid-query-parameters? query-parameters) (letpar& ((systems - (with-thread-postgresql-connection list-systems)) + (call-with-resource-from-pool (connection-pool) + list-systems)) (targets - (with-thread-postgresql-connection valid-targets))) + (call-with-resource-from-pool (connection-pool) + valid-targets))) (render-html #:sxml (view-revision-blocking-builds query-parameters @@ -1509,29 +1461,29 @@ (let ((system (assq-ref query-parameters 'system)) (target (assq-ref query-parameters 'target))) (letpar& ((systems - (with-thread-postgresql-connection list-systems)) + (call-with-resource-from-pool (connection-pool) + list-systems)) (targets - (with-thread-postgresql-connection valid-targets)) + (call-with-resource-from-pool (connection-pool) + valid-targets)) (build-server-options - (with-thread-postgresql-connection - (lambda (conn) - (map (match-lambda - ((id url lookup-all-derivations - lookup-builds) - (cons url id))) - (select-build-servers conn))))) + (with-resource-from-pool (connection-pool) conn + (map (match-lambda + ((id url lookup-all-derivations + lookup-builds) + (cons url id))) + (select-build-servers conn)))) (blocking-builds - (with-thread-postgresql-connection - (lambda (conn) - (select-blocking-builds - conn - commit-hash - #:build-server-ids - (assq-ref query-parameters 'build_server) - #:system system - #:target target - #:limit (assq-ref query-parameters - 'limit_results)))))) + (with-resource-from-pool (connection-pool) conn + (select-blocking-builds + conn + commit-hash + #:build-server-ids + (assq-ref query-parameters 'build_server) + #:system system + #:target target + #:limit (assq-ref query-parameters + 'limit_results))))) (render-html #:sxml (view-revision-blocking-builds query-parameters commit-hash @@ -1551,24 +1503,20 @@ (header-link (string-append "/revision/" commit-hash))) (define lint-checker-options - (parallel-via-thread-pool-channel - (with-thread-postgresql-connection - (lambda (conn) - (map (match-lambda - ((name description network-dependent) - (cons (string-append name ": " description ) - name))) - (lint-checkers-for-revision conn commit-hash)))))) + (with-resource-from-pool (connection-pool) conn + (map (match-lambda + ((name description network-dependent) + (cons (string-append name ": " description ) + name))) + (lint-checkers-for-revision conn commit-hash)))) (define lint-warnings-locale-options - (parallel-via-thread-pool-channel - (with-thread-postgresql-connection - (lambda (conn) - (map - (match-lambda - ((locale) - locale)) - (lint-warning-message-locales-for-revision conn commit-hash)))))) + (with-resource-from-pool (connection-pool) conn + (map + (match-lambda + ((locale) + locale)) + (lint-warning-message-locales-for-revision conn commit-hash)))) (if (any-invalid-query-parameters? query-parameters) (case (most-appropriate-mime-type @@ -1597,18 +1545,16 @@ (fields (assq-ref query-parameters 'field))) (letpar& ((git-repositories - (with-thread-postgresql-connection - (lambda (conn) - (git-repositories-containing-commit conn - commit-hash)))) + (with-resource-from-pool (connection-pool) conn + (git-repositories-containing-commit conn + commit-hash))) (lint-warnings - (with-thread-postgresql-connection - (lambda (conn) - (lint-warnings-for-guix-revision conn commit-hash - #:locale locale - #:package-query package-query - #:linters linters - #:message-query message-query))))) + (with-resource-from-pool (connection-pool) conn + (lint-warnings-for-guix-revision conn commit-hash + #:locale locale + #:package-query package-query + #:linters linters + #:message-query message-query)))) (let ((any-translated-lint-warnings? (any-translated-lint-warnings? lint-warnings locale))) (case (most-appropriate-mime-type diff --git a/guix-data-service/web/server.scm b/guix-data-service/web/server.scm index 6570c1a..84a0e6b 100644 --- a/guix-data-service/web/server.scm +++ b/guix-data-service/web/server.scm @@ -25,8 +25,10 @@ #:use-module (web uri) #:use-module (system repl error-handling) #:use-module (ice-9 atomic) - #:use-module (fibers web server) + #:use-module (fibers) + #:use-module (fibers conditions) #:use-module (prometheus) + #:use-module (guix-data-service utils) #:use-module (guix-data-service database) #:use-module (guix-data-service web controller) #:use-module (guix-data-service web util) @@ -60,7 +62,9 @@ render-metrics)))) (define* (start-guix-data-service-web-server port host secret-key-base - startup-completed) + startup-completed + #:key postgresql-statement-timeout + postgresql-connections) (define registry (make-metrics-registry #:namespace "guixdataservice")) @@ -69,25 +73,50 @@ (%database-metrics-registry registry) - (call-with-error-handling - (lambda () - (run-server (lambda (request body) + (let ((finished? (make-condition))) + (call-with-sigint + (lambda () + (run-fibers + (lambda () + (parameterize + ((connection-pool + (make-resource-pool + (lambda () + (open-postgresql-connection + "web" + postgresql-statement-timeout)) + (floor (/ postgresql-connections 2)))) + + (reserved-connection-pool + (make-resource-pool + (lambda () + (open-postgresql-connection + "web-reserved" + postgresql-statement-timeout)) + (floor (/ postgresql-connections 2)))) + + (resource-pool-default-timeout 10)) + + (with-exception-handler + (lambda (exn) + (simple-format + (current-error-port) + "\n +error: guix-data-service could not start: ~A + +Check if it's already running, or whether another process is using that +port. Also, the port used can be changed by passing the --port option.\n" + exn) + (primitive-exit 1)) + (lambda () + (run-server/patched + (lambda (request body) (handler request body controller secret-key-base startup-completed render-metrics)) #:host host #:port port)) - #:on-error 'backtrace - #:post-error (lambda (key . args) - (when (eq? key 'system-error) - (match args - (("bind" "~A" ("Address already in use") _) - (simple-format - (current-error-port) - "\n -error: guix-data-service could not start, as it could not bind to port ~A - -Check if it's already running, or whether another process is using that -port. Also, the port used can be changed by passing the --port option.\n" - port))))))) + #:unwind? #t)) + (wait finished?)))) + finished?))) |