diff options
Diffstat (limited to 'guix-data-service/web/controller.scm')
| -rw-r--r-- | guix-data-service/web/controller.scm | 95 |
1 files changed, 60 insertions, 35 deletions
diff --git a/guix-data-service/web/controller.scm b/guix-data-service/web/controller.scm index 34a7893..efdd92c 100644 --- a/guix-data-service/web/controller.scm +++ b/guix-data-service/web/controller.scm @@ -73,7 +73,12 @@ #:export (%show-error-details handle-static-assets make-render-metrics - controller)) + controller + + reserved-thread-pool-channel)) + +(define reserved-thread-pool-channel + (make-parameter #f)) (define cache-control-default-max-age (* 60 60 24)) ; One day @@ -636,23 +641,33 @@ (define path (uri-path (request-uri request))) - (define (delegate-to f) - (or (f request - method-and-path-components - mime-types - body) + (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)) (render-html #:sxml (general-not-found "Page not found" "") #:code 404))) - (define (delegate-to-with-secret-key-base f) - (or (f request - method-and-path-components - mime-types - body - secret-key-base) + (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)) (render-html #:sxml (general-not-found "Page not found" @@ -663,18 +678,20 @@ (base-controller request method-and-path-components #t) (match method-and-path-components (('GET) - (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)))))))) + (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))))))))) (('GET "builds") (delegate-to build-controller)) (('GET "statistics") @@ -687,7 +704,9 @@ #:sxml (view-statistics guix-revisions-count count-derivations)))) (('GET "metrics") - (render-metrics)) + (parameterize ((thread-pool-channel + (reserved-thread-pool-channel))) + (render-metrics))) (('GET "revision" args ...) (delegate-to revision-controller)) (('GET "repositories") @@ -697,12 +716,14 @@ (('GET "package" _ ...) (delegate-to package-controller)) (('GET "gnu" "store" filename) - ;; 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))))) + (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)))))) (('GET "gnu" "store" filename "formatted") (if (string-suffix? ".drv" filename) (render-formatted-derivation (string-append "/gnu/store/" filename)) @@ -731,16 +752,20 @@ (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)) + (delegate-to-with-secret-key-base build-server-controller + #:use-reserved-thread-pool? #t)) (('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)) - (('GET "job" job-id) (delegate-to jobs-controller)) - (('GET _ ...) (delegate-to nar-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)) ((method path ...) (render-html #:sxml (general-not-found |