diff options
Diffstat (limited to 'guix-data-service/web/controller.scm')
| -rw-r--r-- | guix-data-service/web/controller.scm | 300 |
1 files changed, 128 insertions, 172 deletions
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 |