mirror of
git://git.savannah.gnu.org/guix/data-service.git
synced 2023-12-14 03:23:03 +01:00
Split the thread pool used for database connections
In to two thread pools, a default one, and one reserved for essential functionality. There are some pages that use slow queries, so this should help stop those pages block other operations.
This commit is contained in:
parent
4fa7a3601e
commit
9f080524bc
|
@ -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,25 +129,15 @@
|
|||
(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
|
||||
(put-message (thread-pool-channel)
|
||||
(list reply
|
||||
(get-internal-real-time)
|
||||
thunk))))
|
||||
reply))
|
||||
|
|
|
@ -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
|
||||
(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)
|
||||
body))
|
||||
(render-html
|
||||
#:sxml (general-not-found
|
||||
"Page not found"
|
||||
"")
|
||||
#:code 404)))
|
||||
|
||||
(define (delegate-to-with-secret-key-base f)
|
||||
(or (f request
|
||||
(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)
|
||||
secret-key-base))
|
||||
(render-html
|
||||
#:sxml (general-not-found
|
||||
"Page not found"
|
||||
|
@ -663,6 +678,8 @@
|
|||
(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
|
||||
|
@ -674,7 +691,7 @@
|
|||
git-repository-details
|
||||
(all-branches-with-most-recent-commit
|
||||
conn (first git-repository-details))))
|
||||
(all-git-repositories conn))))))))
|
||||
(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)
|
||||
(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)))))
|
||||
(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
|
||||
|
|
|
@ -180,16 +180,7 @@
|
|||
(current-error-port))
|
||||
#f)))
|
||||
(%show-error-details
|
||||
(assoc-ref opts 'show-error-details))
|
||||
|
||||
(%thread-pool-threads
|
||||
(assoc-ref opts 'thread-pool-threads))
|
||||
(%thread-pool-idle-seconds
|
||||
60)
|
||||
(%thread-pool-idle-thunk
|
||||
(lambda ()
|
||||
(close-thread-postgresql-connection))))
|
||||
|
||||
(assoc-ref opts 'show-error-details)))
|
||||
|
||||
(let* ((startup-completed
|
||||
(make-atomic-box
|
||||
|
@ -208,11 +199,27 @@
|
|||
(assq-ref opts 'host)
|
||||
(assq-ref opts 'port))
|
||||
|
||||
(parameterize
|
||||
((thread-pool-channel
|
||||
(make-thread-pool-channel
|
||||
(floor (/ (assoc-ref opts 'thread-pool-threads)
|
||||
2))
|
||||
#:idle-seconds 60
|
||||
#:idle-thunk
|
||||
close-thread-postgresql-connection))
|
||||
|
||||
(reserved-thread-pool-channel
|
||||
(make-thread-pool-channel
|
||||
(floor (/ (assoc-ref opts 'thread-pool-threads)
|
||||
2))
|
||||
#:idle-seconds 60
|
||||
#:idle-thunk
|
||||
close-thread-postgresql-connection)))
|
||||
(start-guix-data-service-web-server
|
||||
(assq-ref opts 'port)
|
||||
(assq-ref opts 'host)
|
||||
(assq-ref opts 'secret-key-base)
|
||||
startup-completed))
|
||||
startup-completed)))
|
||||
#:statement-timeout
|
||||
(assq-ref opts 'postgresql-statement-timeout)))))
|
||||
|
||||
|
|
Loading…
Reference in a new issue