guix/data-service
2
0
Fork 0
mirror of git://git.savannah.gnu.org/guix/data-service.git synced 2023-12-14 03:23:03 +01:00
Code Issues Releases Wiki Activity

Split the thread pool used for database connections

Browse source 
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:
Christopher Baines 2023-04-27 10:31:09 +02:00
parent 4fa7a3601e
commit 9f080524bc
3 changed files with 94 additions and 85 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

47
guix-data-service/utils.scm
View file

@ -31,9 +31,8 @@
with-time-logging with-time-logging
prevent-inlining-for-tests prevent-inlining-for-tests
%thread-pool-threads thread-pool-channel
%thread-pool-idle-seconds make-thread-pool-channel
%thread-pool-idle-thunk
parallel-via-thread-pool-channel parallel-via-thread-pool-channel
par-map& par-map&
letpar& letpar&
@ -63,16 +62,10 @@
(define-syntax-rule (prevent-inlining-for-tests var) (define-syntax-rule (prevent-inlining-for-tests var)
(set! var var)) (set! var var))
(define %thread-pool-threads (define* (make-thread-pool-channel threads
(make-parameter 8)) #:key
idle-thunk
(define %thread-pool-idle-seconds idle-seconds)
(make-parameter #f))
(define %thread-pool-idle-thunk
(make-parameter #f))
(define* (make-thread-pool-channel threads)
(define (delay-logger seconds-delayed) (define (delay-logger seconds-delayed)
(when (> seconds-delayed 1) (when (> seconds-delayed 1)
(format (format
@ -80,12 +73,6 @@
"warning: thread pool delayed by ~1,2f seconds~%" "warning: thread pool delayed by ~1,2f seconds~%"
seconds-delayed))) seconds-delayed)))
(define idle-thunk
(%thread-pool-idle-thunk))
(define idle-seconds
(%thread-pool-idle-seconds))
(let ((channel (make-channel))) (let ((channel (make-channel)))
(for-each (for-each
(lambda _ (lambda _
@ -142,27 +129,17 @@
(iota threads)) (iota threads))
channel)) channel))
(define %thread-pool-mutex (make-mutex)) (define thread-pool-channel
(define %thread-pool-channel #f) (make-parameter #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 (defer-to-thread-pool-channel thunk) (define (defer-to-thread-pool-channel thunk)
(make-thread-pool-channel!)
(let ((reply (make-channel))) (let ((reply (make-channel)))
(spawn-fiber (spawn-fiber
(lambda () (lambda ()
(put-message %thread-pool-channel (list reply (put-message (thread-pool-channel)
(get-internal-real-time) (list reply
thunk)))) (get-internal-real-time)
thunk))))
reply)) reply))
(define (fetch-result-of-defered-thunk reply-channel) (define (fetch-result-of-defered-thunk reply-channel)

95
guix-data-service/web/controller.scm
View file

@ -73,7 +73,12 @@
#:export (%show-error-details #:export (%show-error-details
handle-static-assets handle-static-assets
make-render-metrics make-render-metrics
controller)) controller
reserved-thread-pool-channel))
(define reserved-thread-pool-channel
(make-parameter #f))
(define cache-control-default-max-age (define cache-control-default-max-age
(* 60 60 24)) ; One day (* 60 60 24)) ; One day
@ -636,23 +641,33 @@
(define path (define path
(uri-path (request-uri request))) (uri-path (request-uri request)))
(define (delegate-to f) (define* (delegate-to f #:key use-reserved-thread-pool?)
(or (f request (or (parameterize
method-and-path-components ((thread-pool-channel
mime-types (if use-reserved-thread-pool?
body) (reserved-thread-pool-channel)
(thread-pool-channel))))
(f request
method-and-path-components
mime-types
body))
(render-html (render-html
#:sxml (general-not-found #:sxml (general-not-found
"Page not found" "Page not found"
"") "")
#:code 404))) #:code 404)))
(define (delegate-to-with-secret-key-base f) (define* (delegate-to-with-secret-key-base f #:key use-reserved-thread-pool?)
(or (f request (or (parameterize
method-and-path-components ((thread-pool-channel
mime-types (if use-reserved-thread-pool?
body (reserved-thread-pool-channel)
secret-key-base) (thread-pool-channel))))
(f request
method-and-path-components
mime-types
body
secret-key-base))
(render-html (render-html
#:sxml (general-not-found #:sxml (general-not-found
"Page not found" "Page not found"
@ -663,18 +678,20 @@
(base-controller request method-and-path-components #t) (base-controller request method-and-path-components #t)
(match method-and-path-components (match method-and-path-components
(('GET) (('GET)
(render-html (parameterize ((thread-pool-channel
#:sxml (index (reserved-thread-pool-channel)))
(parallel-via-thread-pool-channel (render-html
(with-thread-postgresql-connection #:sxml (index
(lambda (conn) (parallel-via-thread-pool-channel
(map (with-thread-postgresql-connection
(lambda (git-repository-details) (lambda (conn)
(cons (map
git-repository-details (lambda (git-repository-details)
(all-branches-with-most-recent-commit (cons
conn (first git-repository-details)))) git-repository-details
(all-git-repositories conn)))))))) (all-branches-with-most-recent-commit
conn (first git-repository-details))))
(all-git-repositories conn)))))))))
(('GET "builds") (('GET "builds")
(delegate-to build-controller)) (delegate-to build-controller))
(('GET "statistics") (('GET "statistics")
@ -687,7 +704,9 @@
#:sxml (view-statistics guix-revisions-count #:sxml (view-statistics guix-revisions-count
count-derivations)))) count-derivations))))
(('GET "metrics") (('GET "metrics")
(render-metrics)) (parameterize ((thread-pool-channel
(reserved-thread-pool-channel)))
(render-metrics)))
(('GET "revision" args ...) (('GET "revision" args ...)
(delegate-to revision-controller)) (delegate-to revision-controller))
(('GET "repositories") (('GET "repositories")
@ -697,12 +716,14 @@
(('GET "package" _ ...) (('GET "package" _ ...)
(delegate-to package-controller)) (delegate-to package-controller))
(('GET "gnu" "store" filename) (('GET "gnu" "store" filename)
;; These routes are a little special, as the extensions aren't used for (parameterize ((thread-pool-channel
;; content negotiation, so just use the path from the request (reserved-thread-pool-channel)))
(let ((path (uri-path (request-uri request)))) ;; These routes are a little special, as the extensions aren't used for
(if (string-suffix? ".drv" path) ;; content negotiation, so just use the path from the request
(render-derivation (uri-decode path)) (let ((path (uri-path (request-uri request))))
(render-store-item (uri-decode path))))) (if (string-suffix? ".drv" path)
(render-derivation (uri-decode path))
(render-store-item (uri-decode path))))))
(('GET "gnu" "store" filename "formatted") (('GET "gnu" "store" filename "formatted")
(if (string-suffix? ".drv" filename) (if (string-suffix? ".drv" filename)
(render-formatted-derivation (string-append "/gnu/store/" filename)) (render-formatted-derivation (string-append "/gnu/store/" filename))
@ -731,16 +752,20 @@
(render-json-derivation (string-append "/gnu/store/" filename)) (render-json-derivation (string-append "/gnu/store/" filename))
(render-json-store-item (string-append "/gnu/store/" filename)))) (render-json-store-item (string-append "/gnu/store/" filename))))
(('GET "build-servers") (('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" _ ...) (('GET "dumps" _ ...)
(delegate-to dumps-controller)) (delegate-to dumps-controller))
(((or 'GET 'POST) "build-server" _ ...) (((or 'GET 'POST) "build-server" _ ...)
(delegate-to-with-secret-key-base build-server-controller)) (delegate-to-with-secret-key-base build-server-controller))
(('GET "compare" _ ...) (delegate-to compare-controller)) (('GET "compare" _ ...) (delegate-to compare-controller))
(('GET "compare-by-datetime" _ ...) (delegate-to compare-controller)) (('GET "compare-by-datetime" _ ...) (delegate-to compare-controller))
(('GET "jobs" _ ...) (delegate-to jobs-controller)) (('GET "jobs" _ ...) (delegate-to jobs-controller
(('GET "job" job-id) (delegate-to jobs-controller)) #:use-reserved-thread-pool? #t))
(('GET _ ...) (delegate-to nar-controller)) (('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 ...) ((method path ...)
(render-html (render-html
#:sxml (general-not-found #:sxml (general-not-found

37
scripts/guix-data-service.in
View file

@ -180,16 +180,7 @@
(current-error-port)) (current-error-port))
#f))) #f)))
(%show-error-details (%show-error-details
(assoc-ref opts '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))))
(let* ((startup-completed (let* ((startup-completed
(make-atomic-box (make-atomic-box
@ -208,11 +199,27 @@
(assq-ref opts 'host) (assq-ref opts 'host)
(assq-ref opts 'port)) (assq-ref opts 'port))
(start-guix-data-service-web-server (parameterize
(assq-ref opts 'port) ((thread-pool-channel
(assq-ref opts 'host) (make-thread-pool-channel
(assq-ref opts 'secret-key-base) (floor (/ (assoc-ref opts 'thread-pool-threads)
startup-completed)) 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)))
#:statement-timeout #:statement-timeout
(assq-ref opts 'postgresql-statement-timeout))))) (assq-ref opts 'postgresql-statement-timeout)))))