guix
/
data-service
mirror of git://git.savannah.gnu.org/guix/data-service.git
2
0
Fork 0
Code Issues Releases Wiki Activity

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:
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
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)

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

@ -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

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

@ -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))
(start-guix-data-service-web-server
(assq-ref opts 'port)
(assq-ref opts 'host)
(assq-ref opts 'secret-key-base)
startup-completed))
(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)))
#:statement-timeout
(assq-ref opts 'postgresql-statement-timeout)))))