diff options
Diffstat (limited to 'guix-data-service')
| -rw-r--r-- | guix-data-service/utils.scm | 47 | ||||
| -rw-r--r-- | guix-data-service/web/controller.scm | 95 |
2 files changed, 72 insertions, 70 deletions
diff --git a/guix-data-service/utils.scm b/guix-data-service/utils.scm index 2527cf4..c5c6bdf 100644 --- a/guix-data-service/utils.scm +++ b/guix-data-service/utils.scm @@ -31,9 +31,8 @@ with-time-logging prevent-inlining-for-tests - %thread-pool-threads - %thread-pool-idle-seconds - %thread-pool-idle-thunk + thread-pool-channel + make-thread-pool-channel parallel-via-thread-pool-channel par-map& letpar& @@ -63,16 +62,10 @@ (define-syntax-rule (prevent-inlining-for-tests var) (set! var var)) -(define %thread-pool-threads - (make-parameter 8)) - -(define %thread-pool-idle-seconds - (make-parameter #f)) - -(define %thread-pool-idle-thunk - (make-parameter #f)) - -(define* (make-thread-pool-channel threads) +(define* (make-thread-pool-channel threads + #:key + idle-thunk + idle-seconds) (define (delay-logger seconds-delayed) (when (> seconds-delayed 1) (format @@ -80,12 +73,6 @@ "warning: thread pool delayed by ~1,2f seconds~%" seconds-delayed))) - (define idle-thunk - (%thread-pool-idle-thunk)) - - (define idle-seconds - (%thread-pool-idle-seconds)) - (let ((channel (make-channel))) (for-each (lambda _ @@ -142,27 +129,17 @@ (iota threads)) channel)) -(define %thread-pool-mutex (make-mutex)) -(define %thread-pool-channel #f) - -(define (make-thread-pool-channel!') - (with-mutex %thread-pool-mutex - (unless %thread-pool-channel - (set! %thread-pool-channel (make-thread-pool-channel - (%thread-pool-threads))) - (set! make-thread-pool-channel! (lambda () #t))))) - -(define make-thread-pool-channel! - (lambda () (make-thread-pool-channel!'))) +(define thread-pool-channel + (make-parameter #f)) (define (defer-to-thread-pool-channel thunk) - (make-thread-pool-channel!) (let ((reply (make-channel))) (spawn-fiber (lambda () - (put-message %thread-pool-channel (list reply - (get-internal-real-time) - thunk)))) + (put-message (thread-pool-channel) + (list reply + (get-internal-real-time) + thunk)))) reply)) (define (fetch-result-of-defered-thunk reply-channel) 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 |