[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
01/09: Stop using a pool of threads for database operations
|
From: |
Christopher Baines |
|
Subject: |
01/09: Stop using a pool of threads for database operations |
|
Date: |
Wed, 19 Jul 2023 08:37:11 -0400 (EDT) |
cbaines pushed a commit to branch master
in repository data-service.
commit 7251c7d653de29f36d50b33badf05a5db983b8e7
Author: Christopher Baines <mail@cbaines.net>
AuthorDate: Sun Jul 9 16:52:35 2023 +0100
Stop using a pool of threads for database operations
Now that squee cooperates with suspendable ports, this is unnecessary. Use a
connection pool to still support running queries in parallel using multiple
connections.
---
.dir-locals.el | 4 +-
guix-data-service/data-deletion.scm | 88 +--
guix-data-service/database.scm | 1 +
guix-data-service/utils.scm | 358 +++++++----
guix-data-service/web/build-server/controller.scm | 130 ++--
guix-data-service/web/build/controller.scm | 60 +-
guix-data-service/web/compare/controller.scm | 512 ++++++++--------
guix-data-service/web/controller.scm | 300 ++++------
guix-data-service/web/jobs/controller.scm | 51 +-
guix-data-service/web/nar/controller.scm | 51 +-
guix-data-service/web/package/controller.scm | 14 +-
guix-data-service/web/repository/controller.scm | 215 ++++---
guix-data-service/web/revision/controller.scm | 694 ++++++++++------------
guix-data-service/web/server.scm | 65 +-
scripts/guix-data-service.in | 73 +--
15 files changed, 1299 insertions(+), 1317 deletions(-)
diff --git a/.dir-locals.el b/.dir-locals.el
index f7cbfb5..8269f39 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -9,7 +9,9 @@
(eval put 'with-time-logging 'scheme-indent-function 1)
(eval put 'make-parameter 'scheme-indent-function 1)
(eval put 'letpar 'scheme-indent-function 1)
- (eval put 'letpar& 'scheme-indent-function 1))
+ (eval put 'letpar& 'scheme-indent-function 1)
+ (eval put 'call-with-resource-from-pool 'scheme-indent-function 1)
+ (eval put 'with-resource-from-pool 'scheme-indent-function 2))
(texinfo-mode
(indent-tabs-mode)
(fill-column . 72)))
diff --git a/guix-data-service/data-deletion.scm
b/guix-data-service/data-deletion.scm
index 35ce39f..241b899 100644
--- a/guix-data-service/data-deletion.scm
+++ b/guix-data-service/data-deletion.scm
@@ -538,7 +538,7 @@ DELETE FROM derivations WHERE id = $1"
1)))
- (define (delete-batch conn)
+ (define (delete-batch conn connection-pool)
(let* ((derivations
(with-time-logging "fetching batch of derivations"
(map car
@@ -580,29 +580,29 @@ WHERE NOT EXISTS (
derivation-id)))
(let ((val
- (with-thread-postgresql-connection
- (lambda (conn)
- (catch 'psql-query-error
- (lambda ()
- (with-postgresql-transaction
- conn
- (lambda (conn)
- (exec-query
- conn
- "
+ (call-with-resource-from-pool connection-pool
+ (lambda (conn)
+ (catch 'psql-query-error
+ (lambda ()
+ (with-postgresql-transaction
+ conn
+ (lambda (conn)
+ (exec-query
+ conn
+ "
SET CONSTRAINTS derivations_by_output_details_set_derivation_id_fkey DEFERRED")
- (exec-query conn "SET LOCAL lock_timeout =
'5s';")
+ (exec-query conn "SET LOCAL lock_timeout =
'5s';")
- (maybe-delete-derivation conn
- derivation-id))))
- (lambda (key . args)
- (simple-format
- (current-error-port)
- "error when attempting to delete derivation: ~A
~A\n"
- key args)
+ (maybe-delete-derivation conn
+ derivation-id))))
+ (lambda (key . args)
+ (simple-format
+ (current-error-port)
+ "error when attempting to delete derivation: ~A
~A\n"
+ key args)
- 0))))))
+ 0))))))
(monitor
(set! deleted-count
(+ val deleted-count)))))
@@ -613,26 +613,30 @@ SET CONSTRAINTS
derivations_by_output_details_set_derivation_id_fkey DEFERRED")
deleted-count)
deleted-count)))
- (with-postgresql-connection-per-thread
- "data-deletion-thread"
+ (run-fibers
(lambda ()
- (run-fibers
- (lambda ()
- (with-thread-postgresql-connection
- (lambda (conn)
- (obtain-advisory-transaction-lock
- conn
- 'delete-unreferenced-derivations)
-
- (let loop ((total-deleted 0))
- (let ((batch-deleted-count (delete-batch conn)))
- (if (eq? 0 batch-deleted-count)
- (begin
- (with-time-logging
- "Deleting unused derivation_source_files entries"
- (delete-unreferenced-derivations-source-files conn))
- (simple-format
- (current-output-port)
- "Finished deleting derivations, deleted ~A in total\n"
- total-deleted))
- (loop (+ total-deleted batch-deleted-count))))))))))))
+ (let* ((connection-pool
+ (make-resource-pool
+ (lambda ()
+ (open-postgresql-connection "data-deletion" #f))
+ 8)))
+
+ (with-postgresql-connection
+ "data-deletion"
+ (lambda (conn)
+ (obtain-advisory-transaction-lock
+ conn
+ 'delete-unreferenced-derivations)
+
+ (let loop ((total-deleted 0))
+ (let ((batch-deleted-count (delete-batch conn connection-pool)))
+ (if (eq? 0 batch-deleted-count)
+ (begin
+ (with-time-logging
+ "Deleting unused derivation_source_files entries"
+ (delete-unreferenced-derivations-source-files conn))
+ (simple-format
+ (current-output-port)
+ "Finished deleting derivations, deleted ~A in total\n"
+ total-deleted))
+ (loop (+ total-deleted batch-deleted-count)))))))))))
diff --git a/guix-data-service/database.scm b/guix-data-service/database.scm
index d087e60..e768d55 100644
--- a/guix-data-service/database.scm
+++ b/guix-data-service/database.scm
@@ -28,6 +28,7 @@
run-sqitch
with-postgresql-connection
+ open-postgresql-connection
with-postgresql-connection-per-thread
with-thread-postgresql-connection
diff --git a/guix-data-service/utils.scm b/guix-data-service/utils.scm
index b7124d5..ec974e3 100644
--- a/guix-data-service/utils.scm
+++ b/guix-data-service/utils.scm
@@ -31,10 +31,12 @@
with-time-logging
prevent-inlining-for-tests
- thread-pool-channel
- thread-pool-request-timeout
- make-thread-pool-channel
- parallel-via-thread-pool-channel
+ resource-pool-default-timeout
+ make-resource-pool
+ call-with-resource-from-pool
+ with-resource-from-pool
+
+ parallel-via-fibers
par-map&
letpar&
@@ -44,7 +46,10 @@
delete-duplicates/sort!
- get-gc-metrics-updater))
+ get-gc-metrics-updater
+
+ call-with-sigint
+ run-server/patched))
(define (call-with-time-logging action thunk)
(simple-format #t "debug: Starting ~A\n" action)
@@ -63,113 +68,206 @@
(define-syntax-rule (prevent-inlining-for-tests var)
(set! var var))
-(define* (make-thread-pool-channel threads
- #:key
- idle-thunk
- idle-seconds)
- (define (delay-logger seconds-delayed)
- (when (> seconds-delayed 1)
- (format
- (current-error-port)
- "warning: thread pool delayed by ~1,2f seconds~%"
- seconds-delayed)))
+(define* (make-resource-pool initializer max-size
+ #:key (min-size max-size)
+ (idle-duration #f)
+ (delay-logger (const #f))
+ (duration-logger (const #f))
+ destructor
+ lifetime
+ (name "unnamed"))
+ (define (initializer/safe)
+ (with-exception-handler
+ (lambda (exn)
+ (simple-format
+ (current-error-port)
+ "exception running ~A resource pool initializer: ~A:\n ~A\n"
+ name
+ initializer
+ exn)
+ #f)
+ (lambda ()
+ (with-throw-handler #t
+ initializer
+ (lambda args
+ (backtrace))))
+ #:unwind? #t))
(let ((channel (make-channel)))
- (for-each
- (lambda _
- (call-with-new-thread
- (lambda ()
- (let loop ()
- (match (if idle-seconds
+ (spawn-fiber
+ (lambda ()
+ (let loop ((resources '())
+ (available '())
+ (waiters '()))
+
+ (match (get-message channel)
+ (('checkout reply)
+ (if (null? available)
+ (if (= (length resources) max-size)
+ (loop resources
+ available
+ (cons reply waiters))
+ (let ((new-resource (initializer/safe)))
+ (if new-resource
+ (let ((checkout-success?
+ (perform-operation
+ (choice-operation
+ (wrap-operation
+ (put-operation reply new-resource)
+ (const #t))
+ (wrap-operation (sleep-operation 0.2)
+ (const #f))))))
+ (loop (cons new-resource resources)
+ (if checkout-success?
+ available
+ (cons new-resource available))
+ waiters))
+ (loop resources
+ available
+ (cons reply waiters)))))
+ (let ((checkout-success?
(perform-operation
(choice-operation
- (get-operation channel)
- (wrap-operation (sleep-operation idle-seconds)
- (const 'timeout))))
- (get-message channel))
- ('timeout
- (when idle-thunk
- (with-exception-handler
- (lambda (exn)
- (simple-format (current-error-port)
- "worker thread idle thunk exception:
~A\n"
- exn))
- idle-thunk
- #:unwind? #t))
-
- (loop))
-
- (((? channel? reply) sent-time (? procedure? proc))
- (let ((time-delay
- (- (get-internal-real-time)
- sent-time)))
- (delay-logger (/ time-delay
- internal-time-units-per-second))
- (put-message
- reply
- (with-exception-handler
- (lambda (exn)
- (cons 'worker-thread-error exn))
- (lambda ()
- (with-exception-handler
- (lambda (exn)
- (simple-format
- (current-error-port)
- "worker thread: exception: ~A\n"
- exn)
- (backtrace)
- (raise-exception exn))
- (lambda ()
- (call-with-values
- proc
- (lambda vals
- vals)))))
- #:unwind? #t)))
- (loop))
- (_ #f))))))
- (iota threads))
- channel))
+ (wrap-operation
+ (put-operation reply (car available))
+ (const #t))
+ (wrap-operation (sleep-operation 0.2)
+ (const #f))))))
+ (if checkout-success?
+ (loop resources
+ (cdr available)
+ waiters)
+ (loop resources
+ available
+ waiters)))))
+ (('return resource)
+ ;; When a resource is returned, prompt all the waiters to request
+ ;; again. This is to avoid the pool waiting on channels that may
+ ;; be dead.
+ (for-each
+ (lambda (waiter)
+ (spawn-fiber
+ (lambda ()
+ (perform-operation
+ (choice-operation
+ (put-operation waiter 'resource-pool-retry-checkout)
+ (sleep-operation 0.2))))))
+ waiters)
+
+ (loop resources
+ (cons resource available)
+ ;; clear waiters, as they've been notified
+ '()))
+ (unknown
+ (simple-format
+ (current-error-port)
+ "unrecognised message to ~A resource pool channel: ~A\n"
+ name
+ unknown)
+ (loop resources
+ available
+ waiters))))))
-(define &thread-pool-request-timeout
- (make-exception-type '&thread-pool-request-timeout
- &error
- '()))
-
-(define make-thread-pool-request-timeout-error
- (record-constructor &thread-pool-request-timeout))
-
-(define thread-pool-request-timeout-error?
- (record-predicate &thread-pool-request-timeout))
+ channel))
-(define thread-pool-channel
+(define resource-pool-default-timeout
(make-parameter #f))
-(define thread-pool-request-timeout
- (make-parameter #f))
+(define &resource-pool-timeout
+ (make-exception-type '&recource-pool-timeout
+ &error
+ '()))
-(define (defer-to-thread-pool-channel thunk)
+(define make-resource-pool-timeout-error
+ (record-constructor &resource-pool-timeout))
+
+(define resource-pool-timeout-error?
+ (record-predicate &resource-pool-timeout))
+
+(define* (call-with-resource-from-pool pool proc #:key (timeout 'default))
+ "Call PROC with a resource from POOL, blocking until a resource becomes
+available. Return the resource once PROC has returned."
+
+ (define timeout-or-default
+ (if (eq? timeout 'default)
+ (resource-pool-default-timeout)
+ timeout))
+
+ (let ((resource
+ (let ((reply (make-channel)))
+ (if timeout-or-default
+ (let loop ((start-time (get-internal-real-time)))
+ (perform-operation
+ (choice-operation
+ (wrap-operation
+ (put-operation pool `(checkout ,reply))
+ (const #t))
+ (wrap-operation (sleep-operation timeout-or-default)
+ (const #f))))
+
+ (let ((time-remaining
+ (- timeout-or-default
+ (/ (- (get-internal-real-time)
+ start-time)
+ internal-time-units-per-second))))
+ (if (> time-remaining 0)
+ (let ((response
+ (perform-operation
+ (choice-operation
+ (get-operation reply)
+ (wrap-operation (sleep-operation
time-remaining)
+ (const #f))))))
+ (if (or (not response)
+ (eq? response 'resource-pool-retry-checkout))
+ (if (> (- timeout-or-default
+ (/ (- (get-internal-real-time)
+ start-time)
+ internal-time-units-per-second))
+ 0)
+ (loop start-time)
+ #f)
+ response))
+ #f)))
+ (begin
+ (put-message pool `(checkout ,reply))
+ (get-message reply))))))
+
+ (when (or (not resource)
+ (eq? resource 'resource-pool-retry-checkout))
+ (raise-exception
+ (make-resource-pool-timeout-error)))
+
+ (with-exception-handler
+ (lambda (exception)
+ (put-message pool `(return ,resource))
+ (raise-exception exception))
+ (lambda ()
+ (call-with-values
+ (lambda ()
+ (proc resource))
+ (lambda vals
+ (put-message pool `(return ,resource))
+ (apply values vals))))
+ #:unwind? #t)))
+
+(define-syntax-rule (with-resource-from-pool pool resource exp ...)
+ (call-with-resource-from-pool
+ pool
+ (lambda (resource) exp ...)))
+
+(define (defer-to-parallel-fiber thunk)
(let ((reply (make-channel)))
(spawn-fiber
(lambda ()
- (let ((val
- (perform-operation
- (let ((put
- (wrap-operation
- (put-operation (thread-pool-channel)
- (list reply
- (get-internal-real-time)
- thunk))
- (const 'success))))
- (or
- (and=> (thread-pool-request-timeout)
- (lambda (timeout)
- (choice-operation
- put
- (wrap-operation (sleep-operation timeout)
- (const 'request-timeout)))))
- put)))))
- (when (eq? val 'request-timeout)
- (put-message reply val)))))
+ (with-exception-handler
+ (lambda (exn)
+ (put-message reply (cons 'exception exn)))
+ (lambda ()
+ (call-with-values thunk
+ (lambda vals
+ (put-message reply vals))))
+ #:unwind? #t))
+ #:parallel? #t)
reply))
(define (fetch-result-of-defered-thunks . reply-channels)
@@ -177,21 +275,18 @@
reply-channels)))
(map
(match-lambda
- ('request-timeout
- (raise-exception
- (make-thread-pool-request-timeout-error)))
- (('worker-thread-error . exn)
+ (('exception . exn)
(raise-exception exn))
(result
(apply values result)))
responses)))
-(define-syntax parallel-via-thread-pool-channel
+(define-syntax parallel-via-fibers
(lambda (x)
(syntax-case x ()
((_ e0 ...)
(with-syntax (((tmp0 ...) (generate-temporaries (syntax (e0 ...)))))
- #'(let ((tmp0 (defer-to-thread-pool-channel
+ #'(let ((tmp0 (defer-to-parallel-fiber
(lambda ()
e0)))
...)
@@ -199,7 +294,7 @@
(define-syntax-rule (letpar& ((v e) ...) b0 b1 ...)
(call-with-values
- (lambda () (parallel-via-thread-pool-channel e ...))
+ (lambda () (parallel-via-fibers e ...))
(lambda (v ...)
b0 b1 ...)))
@@ -209,7 +304,7 @@
(match lists
(((heads tails ...) ...)
(let ((tail (loop tails))
- (head (defer-to-thread-pool-channel
+ (head (defer-to-parallel-fiber
(lambda ()
(apply proc heads)))))
(cons (fetch-result-of-defered-thunks head) tail)))
@@ -311,3 +406,50 @@
(metric-set metric value))))
metrics))))
+;; This variant of run-server from the fibers library supports running
+;; multiple servers within one process.
+(define run-server/patched
+ (let ((fibers-web-server-module
+ (resolve-module '(fibers web server))))
+
+ (define set-nonblocking!
+ (module-ref fibers-web-server-module 'set-nonblocking!))
+
+ (define make-default-socket
+ (module-ref fibers-web-server-module 'make-default-socket))
+
+ (define socket-loop
+ (module-ref fibers-web-server-module 'socket-loop))
+
+ (lambda* (handler
+ #:key
+ (host #f)
+ (family AF_INET)
+ (addr (if host
+ (inet-pton family host)
+ INADDR_LOOPBACK))
+ (port 8080)
+ (socket (make-default-socket family addr port)))
+ ;; We use a large backlog by default. If the server is suddenly hit
+ ;; with a number of connections on a small backlog, clients won't
+ ;; receive confirmation for their SYN, leading them to retry --
+ ;; probably successfully, but with a large latency.
+ (listen socket 1024)
+ (set-nonblocking! socket)
+ (sigaction SIGPIPE SIG_IGN)
+ (spawn-fiber (lambda () (socket-loop socket handler))))))
+
+;; Copied from (fibers web server)
+(define (call-with-sigint thunk cvar)
+ (let ((handler #f))
+ (dynamic-wind
+ (lambda ()
+ (set! handler
+ (sigaction SIGINT (lambda (sig) (signal-condition! cvar)))))
+ thunk
+ (lambda ()
+ (if handler
+ ;; restore Scheme handler, SIG_IGN or SIG_DFL.
+ (sigaction SIGINT (car handler) (cdr handler))
+ ;; restore original C handler.
+ (sigaction SIGINT #f))))))
diff --git a/guix-data-service/web/build-server/controller.scm
b/guix-data-service/web/build-server/controller.scm
index 7c31cf1..ca03284 100644
--- a/guix-data-service/web/build-server/controller.scm
+++ b/guix-data-service/web/build-server/controller.scm
@@ -26,6 +26,7 @@
#:use-module (guix-data-service substitutes)
#:use-module (guix-data-service web render)
#:use-module (guix-data-service web query-parameters)
+ #:use-module (guix-data-service web controller)
#:use-module (guix-data-service jobs load-new-guix-revision)
#:use-module (guix-data-service model utils)
#:use-module (guix-data-service model build)
@@ -60,18 +61,16 @@
(build-server-build-id
(assq-ref query-parameters 'build_server_build_id))
(build
- (parallel-via-thread-pool-channel
- (with-thread-postgresql-connection
- (lambda (conn)
- (if build-server-build-id
- (select-build-by-build-server-and-build-server-build-id
- conn
- build-server-id
- build-server-build-id)
- (select-build-by-build-server-and-derivation-file-name
- conn
- build-server-id
- derivation-file-name)))))))
+ (with-resource-from-pool (connection-pool) conn
+ (if build-server-build-id
+ (select-build-by-build-server-and-build-server-build-id
+ conn
+ build-server-id
+ build-server-build-id)
+ (select-build-by-build-server-and-derivation-file-name
+ conn
+ build-server-id
+ derivation-file-name)))))
(if build
(render-html
#:sxml
@@ -88,13 +87,11 @@
; guix-build-coordinator
; doesn't mark builds as
; failed-dependency
- (parallel-via-thread-pool-channel
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-required-builds-that-failed
- conn
- build-server-id
- derivation-file-name))))
+ (with-resource-from-pool (connection-pool) conn
+ (select-required-builds-that-failed
+ conn
+ build-server-id
+ derivation-file-name))
#f)))))
(render-html
#:sxml (general-not-found
@@ -121,27 +118,26 @@
(define build-server-id
(string->number build-server-id-string))
- (define (call-via-thread-pool-channel handler)
+ (define (spawn-fiber-for-handler handler)
(spawn-fiber
(lambda ()
- (parallel-via-thread-pool-channel
- (with-postgresql-connection
- "build-event-handler-conn"
- (lambda (conn)
- (with-exception-handler
- (lambda (exn)
- (simple-format
- (current-error-port)
- "exception in build event handler: ~A\n"
- exn))
- (lambda ()
- (with-throw-handler #t
- (lambda ()
- (handler conn))
- (lambda _
- (display (backtrace) (current-error-port))
- (display "\n" (current-error-port)))))
- #:unwind? #t)))))))
+ (with-postgresql-connection
+ "build-event-handler-conn"
+ (lambda (conn)
+ (with-exception-handler
+ (lambda (exn)
+ (simple-format
+ (current-error-port)
+ "exception in build event handler: ~A\n"
+ exn))
+ (lambda ()
+ (with-throw-handler #t
+ (lambda ()
+ (handler conn))
+ (lambda _
+ (display (backtrace) (current-error-port))
+ (display "\n" (current-error-port)))))
+ #:unwind? #t))))))
(define (with-build-ids-for-status data
build-ids
@@ -217,24 +213,24 @@
#f))))
items))
- (letpar& ((build-ids
- (with-thread-postgresql-connection
- (lambda (conn)
- (with-postgresql-transaction
- conn
- (lambda (conn)
- (handle-derivation-events
- conn
- filtered-items)))))))
+ (let ((build-ids
+ (with-resource-from-pool (reserved-connection-pool) conn
+ (with-postgresql-transaction
+ conn
+ (lambda (conn)
+ (handle-derivation-events
+ conn
+ filtered-items))))))
(with-build-ids-for-status
items
build-ids
'("succeeded")
(lambda (ids)
- (call-via-thread-pool-channel
+ (spawn-fiber-for-handler
(lambda (conn)
- (handle-removing-blocking-build-entries-for-successful-builds conn
ids)))
+ (handle-removing-blocking-build-entries-for-successful-builds
+ conn ids)))
(request-query-of-build-server-substitutes build-server-id
ids)))
@@ -244,7 +240,7 @@
build-ids
'("scheduled")
(lambda (ids)
- (call-via-thread-pool-channel
+ (spawn-fiber-for-handler
(lambda (conn)
(handle-blocked-builds-entries-for-scheduled-builds conn ids)))))
@@ -253,7 +249,7 @@
build-ids
'("failed" "failed-dependency" "canceled")
(lambda (ids)
- (call-via-thread-pool-channel
+ (spawn-fiber-for-handler
(lambda (conn)
(handle-populating-blocked-builds-for-build-failures conn
ids)))))))
@@ -263,12 +259,10 @@
#:code 400)
(let ((provided-token (assq-ref parsed-query-parameters 'token))
(permitted-tokens
- (parallel-via-thread-pool-channel
- (with-thread-postgresql-connection
- (lambda (conn)
- (compute-tokens-for-build-server conn
- secret-key-base
- build-server-id))))))
+ (with-resource-from-pool (reserved-connection-pool) conn
+ (compute-tokens-for-build-server conn
+ secret-key-base
+ build-server-id))))
(if (member provided-token
(map cdr permitted-tokens)
string=?)
@@ -317,10 +311,8 @@
(define (handle-signing-key-request id)
(render-html
#:sxml (view-signing-key
- (parallel-via-thread-pool-channel
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-signing-key conn id)))))))
+ (with-resource-from-pool (connection-pool) conn
+ (select-signing-key conn id)))))
(define (build-server-controller request
method-and-path-components
@@ -329,17 +321,17 @@
secret-key-base)
(match method-and-path-components
(('GET "build-servers")
- (letpar& ((build-servers
- (with-thread-postgresql-connection
- select-build-servers)))
+ (let ((build-servers
+ (with-resource-from-pool (connection-pool) conn
+ select-build-servers)))
(render-build-servers mime-types
build-servers)))
(('GET "build-server" build-server-id)
- (letpar& ((build-server
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-build-server conn (string->number
- build-server-id))))))
+ (let ((build-server
+ (with-resource-from-pool (connection-pool) conn
+ (lambda (conn)
+ (select-build-server conn (string->number
+ build-server-id))))))
(if build-server
(render-build-server mime-types
build-server)
diff --git a/guix-data-service/web/build/controller.scm
b/guix-data-service/web/build/controller.scm
index 9e3b943..44b3380 100644
--- a/guix-data-service/web/build/controller.scm
+++ b/guix-data-service/web/build/controller.scm
@@ -21,6 +21,7 @@
#:use-module (guix-data-service utils)
#:use-module (guix-data-service database)
#:use-module (guix-data-service web render)
+ #:use-module (guix-data-service web controller)
#:use-module (guix-data-service web query-parameters)
#:use-module (guix-data-service model build)
#:use-module (guix-data-service model system)
@@ -41,7 +42,7 @@
(define parse-build-server
(lambda (v)
(letpar& ((build-servers
- (with-thread-postgresql-connection
+ (with-resource-from-pool (connection-pool) conn
select-build-servers)))
(or (any (match-lambda
((id url lookup-all-derivations? lookup-builds?)
@@ -88,39 +89,38 @@
(let ((system (assq-ref parsed-query-parameters 'system))
(target (assq-ref parsed-query-parameters 'target)))
(letpar& ((build-server-options
- (with-thread-postgresql-connection
- (lambda (conn)
- (map (match-lambda
- ((id url lookup-all-derivations
- lookup-builds)
- (cons url id)))
- (select-build-servers conn)))))
+ (with-resource-from-pool (connection-pool) conn
+ (map (match-lambda
+ ((id url lookup-all-derivations
+ lookup-builds)
+ (cons url id)))
+ (select-build-servers conn))))
(build-stats
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-build-stats
- conn
- (assq-ref parsed-query-parameters
- 'build_server)
- #:system system
- #:target target))))
+ (with-resource-from-pool (connection-pool) conn
+ (select-build-stats
+ conn
+ (assq-ref parsed-query-parameters
+ 'build_server)
+ #:system system
+ #:target target)))
(builds-with-context
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-builds-with-context
- conn
- (assq-ref parsed-query-parameters
- 'build_status)
- (assq-ref parsed-query-parameters
- 'build_server)
- #:system system
- #:target target
- #:limit (assq-ref parsed-query-parameters
- 'limit_results)))))
+ (with-resource-from-pool (connection-pool) conn
+ (select-builds-with-context
+ conn
+ (assq-ref parsed-query-parameters
+ 'build_status)
+ (assq-ref parsed-query-parameters
+ 'build_server)
+ #:system system
+ #:target target
+ #:limit (assq-ref parsed-query-parameters
+ 'limit_results))))
(systems
- (with-thread-postgresql-connection list-systems))
+ (call-with-resource-from-pool (connection-pool)
+ list-systems))
(targets
- (with-thread-postgresql-connection valid-targets)))
+ (call-with-resource-from-pool (connection-pool)
+ valid-targets)))
(render-html
#:sxml (view-builds parsed-query-parameters
diff --git a/guix-data-service/web/compare/controller.scm
b/guix-data-service/web/compare/controller.scm
index 3d96aa4..6380651 100644
--- a/guix-data-service/web/compare/controller.scm
+++ b/guix-data-service/web/compare/controller.scm
@@ -30,6 +30,7 @@
#:use-module (guix-data-service web util)
#:use-module (guix-data-service web render)
#:use-module (guix-data-service web query-parameters)
+ #:use-module (guix-data-service web controller)
#:use-module (guix-data-service model utils)
#:use-module (guix-data-service comparison)
#:use-module (guix-data-service jobs load-new-guix-revision)
@@ -55,42 +56,38 @@
s)
(define (parse-commit s)
- (parallel-via-thread-pool-channel
- (with-thread-postgresql-connection
- (lambda (conn)
- (let* ((job-details
- (select-job-for-commit conn s))
- (job-state
- (assq-ref job-details 'state)))
- (if job-details
- (cond
- ((string=? job-state "succeeded")
- s)
- ((string=? job-state "queued")
- (make-invalid-query-parameter
- s
- `("data unavailable, "
- (a (@ (href ,(string-append
- "/revision/" s)))
- "yet to process revision"))))
- ((string=? job-state "failed")
- (make-invalid-query-parameter
- s
- `("data unavailable, "
- (a (@ (href ,(string-append
- "/revision/" s)))
- "failed to process revision"))))
- (else
- (make-invalid-query-parameter
- s "unknown job state")))
+ (with-resource-from-pool (connection-pool) conn
+ (let* ((job-details
+ (select-job-for-commit conn s))
+ (job-state
+ (assq-ref job-details 'state)))
+ (if job-details
+ (cond
+ ((string=? job-state "succeeded")
+ s)
+ ((string=? job-state "queued")
(make-invalid-query-parameter
- s "unknown commit")))))))
+ s
+ `("data unavailable, "
+ (a (@ (href ,(string-append
+ "/revision/" s)))
+ "yet to process revision"))))
+ ((string=? job-state "failed")
+ (make-invalid-query-parameter
+ s
+ `("data unavailable, "
+ (a (@ (href ,(string-append
+ "/revision/" s)))
+ "failed to process revision"))))
+ (else
+ (make-invalid-query-parameter
+ s "unknown job state")))
+ (make-invalid-query-parameter
+ s "unknown commit")))))
(define (parse-derivation file-name)
- (if (parallel-via-thread-pool-channel
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-derivation-by-file-name conn file-name))))
+ (if (with-resource-from-pool (connection-pool) conn
+ (select-derivation-by-file-name conn file-name))
file-name
(make-invalid-query-parameter
file-name "unknown derivation")))
@@ -235,18 +232,16 @@
(letpar& ((base-job
(match (assq-ref query-parameters 'base_commit)
(($ <invalid-query-parameter> value)
- (with-thread-postgresql-connection
- (lambda (conn)
- (and (string? value)
- (select-job-for-commit conn value)))))
+ (with-resource-from-pool (connection-pool) conn
+ (and (string? value)
+ (select-job-for-commit conn value))))
(_ #f)))
(target-job
(match (assq-ref query-parameters 'target_commit)
(($ <invalid-query-parameter> value)
- (with-thread-postgresql-connection
- (lambda (conn)
- (and (string? value)
- (select-job-for-commit conn value)))))
+ (with-resource-from-pool (connection-pool) conn
+ (and (string? value)
+ (select-job-for-commit conn value))))
(_ #f))))
(case (most-appropriate-mime-type
'(application/json text/html)
@@ -281,28 +276,24 @@
#f
#f)))))
(letpar& ((base-revision-id
- (with-thread-postgresql-connection
- (lambda (conn)
- (commit->revision-id
- conn
- (assq-ref query-parameters 'base_commit)))))
+ (with-resource-from-pool (connection-pool) conn
+ (commit->revision-id
+ conn
+ (assq-ref query-parameters 'base_commit))))
(target-revision-id
- (with-thread-postgresql-connection
- (lambda (conn)
- (commit->revision-id
- conn
- (assq-ref query-parameters 'target_commit)))))
+ (with-resource-from-pool (connection-pool) conn
+ (commit->revision-id
+ conn
+ (assq-ref query-parameters 'target_commit))))
(locale
(assq-ref query-parameters 'locale)))
(let-values
(((base-packages-vhash target-packages-vhash)
(package-data->package-data-vhashes
- (parallel-via-thread-pool-channel
- (with-thread-postgresql-connection
- (lambda (conn)
- (package-differences-data conn
- base-revision-id
- target-revision-id)))))))
+ (with-resource-from-pool (connection-pool) conn
+ (package-differences-data conn
+ base-revision-id
+ target-revision-id)))))
(let ((new-packages
(package-data-vhashes->new-packages base-packages-vhash
target-packages-vhash))
@@ -313,20 +304,18 @@
(package-data-version-changes base-packages-vhash
target-packages-vhash)))
(letpar& ((lint-warnings-data
- (with-thread-postgresql-connection
- (lambda (conn)
- (group-list-by-first-n-fields
- 2
- (lint-warning-differences-data conn
- base-revision-id
- target-revision-id
- locale)))))
- (channel-news-data
- (with-thread-postgresql-connection
- (lambda (conn)
- (channel-news-differences-data conn
+ (with-resource-from-pool (connection-pool) conn
+ (group-list-by-first-n-fields
+ 2
+ (lint-warning-differences-data conn
base-revision-id
-
target-revision-id)))))
+ target-revision-id
+ locale))))
+ (channel-news-data
+ (with-resource-from-pool (connection-pool) conn
+ (channel-news-differences-data conn
+ base-revision-id
+ target-revision-id))))
(case (most-appropriate-mime-type
'(application/json text/html)
mime-types)
@@ -412,18 +401,16 @@
(match-lambda
((locale)
locale))
- (with-thread-postgresql-connection
- (lambda (conn)
- (lint-warning-message-locales-for-revision
- conn
- (assq-ref query-parameters
'target_commit))))))
- (cgit-url-bases
- (with-thread-postgresql-connection
- (lambda (conn)
- (guix-revisions-cgit-url-bases
+ (with-resource-from-pool (connection-pool) conn
+ (lint-warning-message-locales-for-revision
conn
- (list base-revision-id
- target-revision-id))))))
+ (assq-ref query-parameters 'target_commit)))))
+ (cgit-url-bases
+ (with-resource-from-pool (connection-pool) conn
+ (guix-revisions-cgit-url-bases
+ conn
+ (list base-revision-id
+ target-revision-id)))))
(render-html
#:sxml (compare query-parameters
'revision
@@ -463,29 +450,26 @@
(target-datetime (assq-ref query-parameters 'target_datetime))
(locale (assq-ref query-parameters 'locale)))
(letpar& ((base-revision-details
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-guix-revision-for-branch-and-datetime
- conn
- base-branch
- base-datetime))))
+ (with-resource-from-pool (connection-pool) conn
+ (select-guix-revision-for-branch-and-datetime
+ conn
+ base-branch
+ base-datetime)))
(target-revision-details
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-guix-revision-for-branch-and-datetime
- conn
- target-branch
- target-datetime)))))
- (letpar& ((lint-warnings-locale-options
- (map
- (match-lambda
- ((locale)
- locale))
- (with-thread-postgresql-connection
- (lambda (conn)
- (lint-warning-message-locales-for-revision
- conn
- (second base-revision-details)))))))
+ (with-resource-from-pool (connection-pool) conn
+ (select-guix-revision-for-branch-and-datetime
+ conn
+ target-branch
+ target-datetime))))
+ (let ((lint-warnings-locale-options
+ (map
+ (match-lambda
+ ((locale)
+ locale))
+ (with-resource-from-pool (connection-pool) conn
+ (lint-warning-message-locales-for-revision
+ conn
+ (second base-revision-details))))))
(let ((base-revision-id
(first base-revision-details))
(target-revision-id
@@ -493,12 +477,10 @@
(let-values
(((base-packages-vhash target-packages-vhash)
(package-data->package-data-vhashes
- (parallel-via-thread-pool-channel
- (with-thread-postgresql-connection
- (lambda (conn)
- (package-differences-data conn
- base-revision-id
- target-revision-id)))))))
+ (with-resource-from-pool (connection-pool) conn
+ (package-differences-data conn
+ base-revision-id
+ target-revision-id)))))
(let* ((new-packages
(package-data-vhashes->new-packages base-packages-vhash
target-packages-vhash))
@@ -509,12 +491,10 @@
(package-data-version-changes base-packages-vhash
target-packages-vhash))
(channel-news-data
- (parallel-via-thread-pool-channel
- (with-thread-postgresql-connection
- (lambda (conn)
- (channel-news-differences-data conn
- base-revision-id
-
target-revision-id))))))
+ (with-resource-from-pool (connection-pool) conn
+ (channel-news-differences-data conn
+ base-revision-id
+ target-revision-id))))
(case (most-appropriate-mime-type
'(application/json text/html)
mime-types)
@@ -567,32 +547,29 @@
#:extra-headers http-headers-for-unchanging-content))
(else
(render-html
- #:sxml (compare `(,@query-parameters
- (base_commit . ,(second
base-revision-details))
- (target_commit . ,(second
target-revision-details)))
- 'datetime
- (parallel-via-thread-pool-channel
- (with-thread-postgresql-connection
- (lambda (conn)
- (guix-revisions-cgit-url-bases
- conn
- (list base-revision-id
- target-revision-id)))))
- new-packages
- removed-packages
- version-changes
- (parallel-via-thread-pool-channel
- (group-list-by-first-n-fields
- 2
- (with-thread-postgresql-connection
- (lambda (conn)
- (lint-warning-differences-data
- conn
- base-revision-id
- target-revision-id
- locale)))))
- lint-warnings-locale-options
- channel-news-data)
+ #:sxml (compare
+ `(,@query-parameters
+ (base_commit . ,(second base-revision-details))
+ (target_commit . ,(second
target-revision-details)))
+ 'datetime
+ (with-resource-from-pool (connection-pool) conn
+ (guix-revisions-cgit-url-bases
+ conn
+ (list base-revision-id
+ target-revision-id)))
+ new-packages
+ removed-packages
+ version-changes
+ (group-list-by-first-n-fields
+ 2
+ (with-resource-from-pool (connection-pool) conn
+ (lint-warning-differences-data
+ conn
+ base-revision-id
+ target-revision-id
+ locale)))
+ lint-warnings-locale-options
+ channel-news-data)
#:extra-headers
http-headers-for-unchanging-content)))))))))))
(define (render-compare/derivation mime-types
@@ -612,12 +589,11 @@
(let ((base-derivation (assq-ref query-parameters 'base_derivation))
(target-derivation (assq-ref query-parameters
'target_derivation)))
- (letpar& ((data
- (with-thread-postgresql-connection
- (lambda (conn)
- (derivation-differences-data conn
- base-derivation
- target-derivation)))))
+ (let ((data
+ (with-resource-from-pool (connection-pool) conn
+ (derivation-differences-data conn
+ base-derivation
+ target-derivation))))
(case (most-appropriate-mime-type
'(application/json text/html)
mime-types)
@@ -655,9 +631,8 @@
((? string? value) value)
(_ #f))
(lambda (commit)
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-job-for-commit conn commit))))))
+ (with-resource-from-pool (connection-pool) conn
+ (select-job-for-commit conn commit)))))
(target-job
(and=> (match (assq-ref query-parameters 'target_commit)
(($ <invalid-query-parameter> value)
@@ -665,9 +640,8 @@
((? string? value) value)
(_ #f))
(lambda (commit)
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-job-for-commit conn commit)))))))
+ (with-resource-from-pool (connection-pool) conn
+ (select-job-for-commit conn commit))))))
(render-json
`((error . "invalid query")
(query_parameters
@@ -690,14 +664,14 @@
(target_job . ,target-job)))))
(else
(letpar& ((systems
- (with-thread-postgresql-connection
- list-systems))
+ (call-with-resource-from-pool (connection-pool)
+ list-systems))
(targets
- (with-thread-postgresql-connection
- valid-targets))
+ (call-with-resource-from-pool (connection-pool)
+ valid-targets))
(build-server-urls
- (with-thread-postgresql-connection
- select-build-server-urls-by-id)))
+ (call-with-resource-from-pool (connection-pool)
+ select-build-server-urls-by-id)))
(render-html
#:sxml (compare/package-derivations
query-parameters
@@ -718,19 +692,18 @@
(after-name (assq-ref query-parameters 'after_name))
(limit-results (assq-ref query-parameters 'limit_results)))
(letpar& ((data
- (with-thread-postgresql-connection
- (lambda (conn)
- (package-derivation-differences-data
- conn
- (commit->revision-id conn base-commit)
- (commit->revision-id conn target-commit)
- #:systems systems
- #:targets targets
- #:build-change build-change
- #:after-name after-name
- #:limit-results limit-results))))
+ (with-resource-from-pool (connection-pool) conn
+ (package-derivation-differences-data
+ conn
+ (commit->revision-id conn base-commit)
+ (commit->revision-id conn target-commit)
+ #:systems systems
+ #:targets targets
+ #:build-change build-change
+ #:after-name after-name
+ #:limit-results limit-results)))
(build-server-urls
- (with-thread-postgresql-connection
+ (with-resource-from-pool (connection-pool) conn
select-build-server-urls-by-id)))
(let ((names-and-versions
(package-derivation-data->names-and-versions data)))
@@ -755,11 +728,11 @@
. ,derivation-changes))))
(else
(letpar& ((systems
- (with-thread-postgresql-connection
- list-systems))
+ (call-with-resource-from-pool (connection-pool)
+ list-systems))
(targets
- (with-thread-postgresql-connection
- valid-targets)))
+ (call-with-resource-from-pool (connection-pool)
+ valid-targets)))
(render-html
#:sxml (compare/package-derivations
query-parameters
@@ -784,11 +757,11 @@
#:sxml (compare/package-derivations
query-parameters
'datetime
- (parallel-via-thread-pool-channel
- (with-thread-postgresql-connection list-systems))
+ (call-with-resource-from-pool (connection-pool)
+ list-systems)
(valid-targets->options
- (parallel-via-thread-pool-channel
- (with-thread-postgresql-connection valid-targets)))
+ (call-with-resource-from-pool (connection-pool)
+ valid-targets))
build-status-strings
'()
'()
@@ -807,30 +780,27 @@
(limit-results (assq-ref query-parameters 'limit_results)))
(letpar&
((base-revision-details
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-guix-revision-for-branch-and-datetime conn
- base-branch
-
base-datetime))))
+ (with-resource-from-pool (connection-pool) conn
+ (select-guix-revision-for-branch-and-datetime conn
+ base-branch
+ base-datetime)))
(target-revision-details
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-guix-revision-for-branch-and-datetime conn
- target-branch
-
target-datetime)))))
+ (with-resource-from-pool (connection-pool) conn
+ (select-guix-revision-for-branch-and-datetime conn
+ target-branch
+
target-datetime))))
(letpar&
((data
- (with-thread-postgresql-connection
- (lambda (conn)
- (package-derivation-differences-data
- conn
- (first base-revision-details)
- (first target-revision-details)
- #:systems systems
- #:targets targets
- #:build-change build-change
- #:after-name after-name
- #:limit-results limit-results)))))
+ (with-resource-from-pool (connection-pool) conn
+ (package-derivation-differences-data
+ conn
+ (first base-revision-details)
+ (first target-revision-details)
+ #:systems systems
+ #:targets targets
+ #:build-change build-change
+ #:after-name after-name
+ #:limit-results limit-results))))
(let ((names-and-versions
(package-derivation-data->names-and-versions data)))
(let-values
@@ -859,15 +829,17 @@
#:sxml (compare/package-derivations
query-parameters
'datetime
- (parallel-via-thread-pool-channel
- (with-thread-postgresql-connection
list-systems))
+ (call-with-resource-from-pool
+ (connection-pool)
+ list-systems)
(valid-targets->options
- (parallel-via-thread-pool-channel
- (with-thread-postgresql-connection
valid-targets)))
+ (call-with-resource-from-pool
+ (connection-pool)
+ valid-targets))
build-status-strings
- (parallel-via-thread-pool-channel
- (with-thread-postgresql-connection
- select-build-server-urls-by-id))
+ (call-with-resource-from-pool
+ (connection-pool)
+ select-build-server-urls-by-id)
derivation-changes
base-revision-details
target-revision-details))))))))))))
@@ -894,16 +866,14 @@
(letpar& ((base-job
(match (assq-ref query-parameters 'base_commit)
(($ <invalid-query-parameter> value)
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-job-for-commit conn value))))
+ (with-resource-from-pool (connection-pool) conn
+ (select-job-for-commit conn value)))
(_ #f)))
(target-job
(match (assq-ref query-parameters 'target_commit)
(($ <invalid-query-parameter> value)
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-job-for-commit conn value))))
+ (with-resource-from-pool (connection-pool) conn
+ (select-job-for-commit conn value)))
(_ #f))))
(render-html
#:sxml (compare-invalid-parameters
@@ -914,26 +884,22 @@
(let ((base-commit (assq-ref query-parameters 'base_commit))
(target-commit (assq-ref query-parameters 'target_commit)))
(letpar& ((base-revision-id
- (with-thread-postgresql-connection
- (lambda (conn)
- (commit->revision-id
- conn
- base-commit))))
+ (with-resource-from-pool (connection-pool) conn
+ (commit->revision-id
+ conn
+ base-commit)))
(target-revision-id
- (with-thread-postgresql-connection
- (lambda (conn)
- (commit->revision-id
- conn
- target-commit)))))
+ (with-resource-from-pool (connection-pool) conn
+ (commit->revision-id
+ conn
+ target-commit))))
(let-values
(((base-packages-vhash target-packages-vhash)
(package-data->package-data-vhashes
- (parallel-via-thread-pool-channel
- (with-thread-postgresql-connection
- (lambda (conn)
- (package-differences-data conn
- base-revision-id
- target-revision-id)))))))
+ (with-resource-from-pool (connection-pool) conn
+ (package-differences-data conn
+ base-revision-id
+ target-revision-id)))))
(case (most-appropriate-mime-type
'(application/json text/html)
mime-types)
@@ -967,10 +933,10 @@
'((error . "invalid query"))))
(else
(letpar& ((systems
- (with-thread-postgresql-connection
+ (with-resource-from-pool (connection-pool) conn
list-systems))
(build-server-urls
- (with-thread-postgresql-connection
+ (with-resource-from-pool (connection-pool) conn
select-build-server-urls-by-id)))
(render-html
#:sxml (compare/system-test-derivations
@@ -986,26 +952,23 @@
(target-commit (assq-ref query-parameters 'target_commit))
(system (assq-ref query-parameters 'system)))
(letpar& ((data
- (with-thread-postgresql-connection
- (lambda (conn)
- (system-test-derivations-differences-data
- conn
- (commit->revision-id conn base-commit)
- (commit->revision-id conn target-commit)
- system))))
+ (with-resource-from-pool (connection-pool) conn
+ (system-test-derivations-differences-data
+ conn
+ (commit->revision-id conn base-commit)
+ (commit->revision-id conn target-commit)
+ system)))
(build-server-urls
- (with-thread-postgresql-connection
+ (with-resource-from-pool (connection-pool) conn
select-build-server-urls-by-id))
(base-git-repositories
- (with-thread-postgresql-connection
- (lambda (conn)
- (git-repositories-containing-commit conn base-commit))))
+ (with-resource-from-pool (connection-pool) conn
+ (git-repositories-containing-commit conn base-commit)))
(target-git-repositories
- (with-thread-postgresql-connection
- (lambda (conn)
- (git-repositories-containing-commit conn
target-commit))))
+ (with-resource-from-pool (connection-pool) conn
+ (git-repositories-containing-commit conn target-commit)))
(systems
- (with-thread-postgresql-connection
+ (with-resource-from-pool (connection-pool) conn
list-systems)))
(case (most-appropriate-mime-type
'(application/json text/html)
@@ -1040,10 +1003,10 @@
'((error . "invalid query"))))
(else
(letpar& ((systems
- (with-thread-postgresql-connection
+ (with-resource-from-pool (connection-pool) conn
list-systems))
(build-server-urls
- (with-thread-postgresql-connection
+ (with-resource-from-pool (connection-pool) conn
select-build-server-urls-by-id)))
(render-html
#:sxml (compare/system-test-derivations
@@ -1062,42 +1025,37 @@
(system (assq-ref query-parameters 'system)))
(letpar&
((base-revision-details
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-guix-revision-for-branch-and-datetime conn
- base-branch
-
base-datetime))))
+ (with-resource-from-pool (connection-pool) conn
+ (select-guix-revision-for-branch-and-datetime conn
+ base-branch
+ base-datetime)))
(target-revision-details
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-guix-revision-for-branch-and-datetime conn
- target-branch
-
target-datetime)))))
+ (with-resource-from-pool (connection-pool) conn
+ (select-guix-revision-for-branch-and-datetime conn
+ target-branch
+
target-datetime))))
(letpar& ((data
- (with-thread-postgresql-connection
- (lambda (conn)
- (system-test-derivations-differences-data
- conn
- (first base-revision-details)
- (first target-revision-details)
- system))))
+ (with-resource-from-pool (connection-pool) conn
+ (system-test-derivations-differences-data
+ conn
+ (first base-revision-details)
+ (first target-revision-details)
+ system)))
(build-server-urls
- (with-thread-postgresql-connection
+ (with-resource-from-pool (connection-pool) conn
select-build-server-urls-by-id))
(base-git-repositories
- (with-thread-postgresql-connection
- (lambda (conn)
- (git-repositories-containing-commit
- conn
- (second base-revision-details)))))
+ (with-resource-from-pool (connection-pool) conn
+ (git-repositories-containing-commit
+ conn
+ (second base-revision-details))))
(target-git-repositories
- (with-thread-postgresql-connection
- (lambda (conn)
- (git-repositories-containing-commit
- conn
- (second target-revision-details)))))
+ (with-resource-from-pool (connection-pool) conn
+ (git-repositories-containing-commit
+ conn
+ (second target-revision-details))))
(systems
- (with-thread-postgresql-connection
+ (with-resource-from-pool (connection-pool) conn
list-systems)))
(case (most-appropriate-mime-type
'(application/json text/html)
diff --git a/guix-data-service/web/controller.scm
b/guix-data-service/web/controller.scm
index 2b8d2b5..c9a6a04 100644
--- a/guix-data-service/web/controller.scm
+++ b/guix-data-service/web/controller.scm
@@ -75,9 +75,13 @@
make-render-metrics
controller
- reserved-thread-pool-channel))
+ connection-pool
+ reserved-connection-pool))
-(define reserved-thread-pool-channel
+(define connection-pool
+ (make-parameter #f))
+
+(define reserved-connection-pool
(make-parameter #f))
(define cache-control-default-max-age
@@ -186,22 +190,28 @@
(lambda ()
(letpar& ((metric-values
- (with-thread-postgresql-connection
+ (call-with-resource-from-pool
+ (reserved-connection-pool)
fetch-high-level-table-size-metrics))
(guix-revisions-count
- (with-thread-postgresql-connection
+ (call-with-resource-from-pool
+ (reserved-connection-pool)
count-guix-revisions))
(pg-stat-user-tables-metrics
- (with-thread-postgresql-connection
+ (call-with-resource-from-pool
+ (reserved-connection-pool)
fetch-pg-stat-user-tables-metrics))
(pg-stat-user-indexes-metrics
- (with-thread-postgresql-connection
+ (call-with-resource-from-pool
+ (reserved-connection-pool)
fetch-pg-stat-user-indexes-metrics))
(pg-stats-metric-values
- (with-thread-postgresql-connection
+ (call-with-resource-from-pool
+ (reserved-connection-pool)
fetch-pg-stats-metrics))
(load-new-guix-revision-job-metrics
- (with-thread-postgresql-connection
+ (call-with-resource-from-pool
+ (reserved-connection-pool)
select-load-new-guix-revision-job-metrics)))
(for-each (match-lambda
@@ -301,29 +311,25 @@
(define (render-derivation derivation-file-name)
(letpar& ((derivation
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-derivation-by-file-name conn derivation-file-name)))))
+ (with-resource-from-pool (reserved-connection-pool) conn
+ (select-derivation-by-file-name conn derivation-file-name))))
(if derivation
(letpar& ((derivation-inputs
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-derivation-inputs-by-derivation-id
- conn
- (first derivation)))))
+ (with-resource-from-pool (reserved-connection-pool) conn
+ (select-derivation-inputs-by-derivation-id
+ conn
+ (first derivation))))
(derivation-outputs
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-derivation-outputs-by-derivation-id
- conn
- (first derivation)))))
+ (with-resource-from-pool (reserved-connection-pool) conn
+ (select-derivation-outputs-by-derivation-id
+ conn
+ (first derivation))))
(builds
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-builds-with-context-by-derivation-file-name
- conn
- (second derivation))))))
+ (with-resource-from-pool (reserved-connection-pool) conn
+ (select-builds-with-context-by-derivation-file-name
+ conn
+ (second derivation)))))
(render-html
#:sxml (view-derivation derivation
derivation-inputs
@@ -339,30 +345,25 @@
(define (render-json-derivation derivation-file-name)
(let ((derivation
- (parallel-via-thread-pool-channel
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-derivation-by-file-name conn
- derivation-file-name))))))
+ (with-resource-from-pool (reserved-connection-pool) conn
+ (select-derivation-by-file-name conn
+ derivation-file-name))))
(if derivation
(letpar& ((derivation-inputs
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-derivation-inputs-by-derivation-id
- conn
- (first derivation)))))
+ (with-resource-from-pool (connection-pool) conn
+ (select-derivation-inputs-by-derivation-id
+ conn
+ (first derivation))))
(derivation-outputs
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-derivation-outputs-by-derivation-id
- conn
- (first derivation)))))
+ (with-resource-from-pool (connection-pool) conn
+ (select-derivation-outputs-by-derivation-id
+ conn
+ (first derivation))))
(derivation-sources
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-derivation-sources-by-derivation-id
- conn
- (first derivation))))))
+ (with-resource-from-pool (connection-pool) conn
+ (select-derivation-sources-by-derivation-id
+ conn
+ (first derivation)))))
(render-json
`((inputs . ,(list->vector
(map
@@ -400,30 +401,25 @@
(define (render-formatted-derivation derivation-file-name)
(let ((derivation
- (parallel-via-thread-pool-channel
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-derivation-by-file-name conn
- derivation-file-name))))))
+ (with-resource-from-pool (connection-pool) conn
+ (select-derivation-by-file-name conn
+ derivation-file-name))))
(if derivation
(letpar& ((derivation-inputs
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-derivation-inputs-by-derivation-id
- conn
- (first derivation)))))
+ (with-resource-from-pool (connection-pool) conn
+ (select-derivation-inputs-by-derivation-id
+ conn
+ (first derivation))))
(derivation-outputs
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-derivation-outputs-by-derivation-id
- conn
- (first derivation)))))
+ (with-resource-from-pool (connection-pool) conn
+ (select-derivation-outputs-by-derivation-id
+ conn
+ (first derivation))))
(derivation-sources
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-derivation-sources-by-derivation-id
- conn
- (first derivation))))))
+ (with-resource-from-pool (connection-pool) conn
+ (select-derivation-sources-by-derivation-id
+ conn
+ (first derivation)))))
(render-html
#:sxml (view-formatted-derivation derivation
derivation-inputs
@@ -439,12 +435,10 @@
(define (render-narinfos filename)
(let ((narinfos
- (parallel-via-thread-pool-channel
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-nars-for-output
- conn
- (string-append "/gnu/store/" filename)))))))
+ (with-resource-from-pool (connection-pool) conn
+ (select-nars-for-output
+ conn
+ (string-append "/gnu/store/" filename)))))
(if (null? narinfos)
(render-html
#:sxml (general-not-found
@@ -457,15 +451,12 @@
(define (render-store-item filename)
(letpar& ((derivation
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-derivation-by-output-filename conn filename)))))
+ (with-resource-from-pool (reserved-connection-pool) conn
+ (select-derivation-by-output-filename conn filename))))
(match derivation
(()
- (match (parallel-via-thread-pool-channel
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-derivation-source-file-by-store-path conn
filename))))
+ (match (with-resource-from-pool (reserved-connection-pool) conn
+ (select-derivation-source-file-by-store-path conn filename))
(()
(render-html
#:sxml (general-not-found
@@ -476,24 +467,20 @@
(render-html
#:sxml (view-derivation-source-file
filename
- (parallel-via-thread-pool-channel
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-derivation-source-file-nar-details-by-file-name
- conn
- filename)))))
+ (with-resource-from-pool (reserved-connection-pool) conn
+ (select-derivation-source-file-nar-details-by-file-name
+ conn
+ filename)))
#:extra-headers http-headers-for-unchanging-content))))
(derivations
(letpar& ((nars
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-nars-for-output conn filename))))
+ (with-resource-from-pool (reserved-connection-pool) conn
+ (select-nars-for-output conn filename)))
(builds
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-builds-with-context-by-derivation-output
- conn
- filename)))))
+ (with-resource-from-pool (reserved-connection-pool) conn
+ (select-builds-with-context-by-derivation-output
+ conn
+ filename))))
(render-html
#:sxml (view-store-item filename
derivations
@@ -502,16 +489,12 @@
(define (render-json-store-item filename)
(let ((derivation
- (parallel-via-thread-pool-channel
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-derivation-by-output-filename conn filename))))))
+ (with-resource-from-pool (connection-pool) conn
+ (select-derivation-by-output-filename conn filename))))
(match derivation
(()
- (match (parallel-via-thread-pool-channel
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-derivation-source-file-by-store-path conn
filename))))
+ (match (with-resource-from-pool (connection-pool) conn
+ (select-derivation-source-file-by-store-path conn filename))
(()
(render-json '((error . "store item not found"))))
((id)
@@ -522,17 +505,14 @@
(match-lambda
((key . value)
`((,key . ,value))))
- (parallel-via-thread-pool-channel
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-derivation-source-file-nar-details-by-file-name
- conn
- filename))))))))))))
+ (with-resource-from-pool (connection-pool) conn
+ (select-derivation-source-file-nar-details-by-file-name
+ conn
+ filename))))))))))
(derivations
(letpar& ((nars
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-nars-for-output conn filename)))))
+ (with-resource-from-pool (connection-pool) conn
+ (select-nars-for-output conn filename))))
(render-json
`((nars . ,(list->vector
(map
@@ -653,33 +633,23 @@
(define path
(uri-path (request-uri 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))
+ (define* (delegate-to f)
+ (or (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 #: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))
+ (define* (delegate-to-with-secret-key-base f)
+ (or (f request
+ method-and-path-components
+ mime-types
+ body
+ secret-key-base)
(render-html
#:sxml (general-not-found
"Page not found"
@@ -690,35 +660,29 @@
(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
- (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)))))))))
+ (render-html
+ #:sxml (index
+ (with-resource-from-pool (reserved-connection-pool) 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")
(letpar& ((guix-revisions-count
- (with-thread-postgresql-connection count-guix-revisions))
+ (with-resource-from-pool (connection-pool) conn
count-guix-revisions))
(count-derivations
- (with-thread-postgresql-connection count-derivations)))
+ (with-resource-from-pool (connection-pool) conn
count-derivations)))
(render-html
#:sxml (view-statistics guix-revisions-count
count-derivations))))
(('GET "metrics")
- (parameterize ((thread-pool-channel
- (reserved-thread-pool-channel)))
- (render-metrics)))
+ (render-metrics))
(('GET "revision" args ...)
(delegate-to revision-controller))
(('GET "repositories")
@@ -728,14 +692,12 @@
(('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))))))
+ ;; 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))
@@ -747,12 +709,10 @@
(('GET "gnu" "store" filename "plain")
(if (string-suffix? ".drv" filename)
(let ((raw-drv
- (parallel-via-thread-pool-channel
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-serialized-derivation-by-file-name
- conn
- (string-append "/gnu/store/" filename)))))))
+ (with-resource-from-pool (connection-pool) conn
+ (select-serialized-derivation-by-file-name
+ conn
+ (string-append "/gnu/store/" filename)))))
(if raw-drv
(render-text raw-drv)
(not-found (request-uri request))))
@@ -764,20 +724,16 @@
(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
- #:use-reserved-thread-pool? #t))
+ (delegate-to-with-secret-key-base build-server-controller))
(('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
- #: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))
+ (('GET "jobs" _ ...) (delegate-to jobs-controller))
+ (('GET "job" job-id) (delegate-to jobs-controller))
+ (('GET _ ...) (delegate-to nar-controller))
((method path ...)
(render-html
#:sxml (general-not-found
diff --git a/guix-data-service/web/jobs/controller.scm
b/guix-data-service/web/jobs/controller.scm
index 47034ee..b8b494d 100644
--- a/guix-data-service/web/jobs/controller.scm
+++ b/guix-data-service/web/jobs/controller.scm
@@ -20,6 +20,7 @@
#:use-module (guix-data-service utils)
#:use-module (guix-data-service database)
#:use-module (guix-data-service web render)
+ #:use-module (guix-data-service web controller)
#:use-module (guix-data-service web query-parameters)
#:use-module (guix-data-service web util)
#:use-module (guix-data-service jobs load-new-guix-revision)
@@ -73,14 +74,14 @@
(define limit-results (assq-ref query-parameters 'limit_results))
(letpar& ((jobs
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-jobs-and-events
- conn
- (assq-ref query-parameters 'before_id)
- limit-results))))
+ (with-resource-from-pool (connection-pool) conn
+ (select-jobs-and-events
+ conn
+ (assq-ref query-parameters 'before_id)
+ limit-results)))
(recent-events
- (with-thread-postgresql-connection
+ (call-with-resource-from-pool
+ (connection-pool)
select-recent-job-events)))
(case (most-appropriate-mime-type
'(application/json text/html)
@@ -116,14 +117,13 @@
limit-results))))))))
(define (render-job-events mime-types query-parameters)
- (letpar& ((recent-events
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-recent-job-events
- conn
- ;; TODO Ideally there wouldn't be a limit
- #:limit (or (assq-ref query-parameters 'limit_results)
- 1000000))))))
+ (let ((recent-events
+ (with-resource-from-pool (connection-pool) conn
+ (select-recent-job-events
+ conn
+ ;; TODO Ideally there wouldn't be a limit
+ #:limit (or (assq-ref query-parameters 'limit_results)
+ 1000000)))))
(render-html
#:sxml (view-job-events
query-parameters
@@ -132,19 +132,18 @@
(define (render-job-queue mime-types)
(render-html
#:sxml (view-job-queue
- (parallel-via-thread-pool-channel
- (with-thread-postgresql-connection
- select-unprocessed-jobs-and-events)))))
+ (call-with-resource-from-pool
+ (connection-pool)
+ select-unprocessed-jobs-and-events))))
(define (render-job mime-types job-id query-parameters)
- (letpar& ((log-text
- (with-thread-postgresql-connection
- (lambda (conn)
- (log-for-job conn job-id
- #:character-limit
- (assq-ref query-parameters 'characters)
- #:start-character
- (assq-ref query-parameters 'start_character))))))
+ (let ((log-text
+ (with-resource-from-pool (connection-pool) conn
+ (log-for-job conn job-id
+ #:character-limit
+ (assq-ref query-parameters 'characters)
+ #:start-character
+ (assq-ref query-parameters 'start_character)))))
(case (most-appropriate-mime-type
'(text/plain text/html)
mime-types)
diff --git a/guix-data-service/web/nar/controller.scm
b/guix-data-service/web/nar/controller.scm
index 2164860..e2ace7a 100644
--- a/guix-data-service/web/nar/controller.scm
+++ b/guix-data-service/web/nar/controller.scm
@@ -34,6 +34,7 @@
#:use-module (guix-data-service utils)
#:use-module (guix-data-service database)
#:use-module (guix-data-service web render)
+ #:use-module (guix-data-service web controller)
#:use-module (guix-data-service web nar html)
#:use-module (guix-data-service model derivation)
#:export (nar-controller
@@ -99,11 +100,9 @@
mime-types
file-name)
(or
- (and=> (parallel-via-thread-pool-channel
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-serialized-derivation-by-file-name conn
- file-name))))
+ (and=> (with-resource-from-pool (reserved-connection-pool) conn
+ (select-serialized-derivation-by-file-name conn
+ file-name))
(lambda (derivation-text)
(let ((derivation-bytevector
(string->bytevector derivation-text
@@ -130,11 +129,9 @@
mime-types
file-name)
(or
- (and=> (parallel-via-thread-pool-channel
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-derivation-source-file-nar-data-by-file-name conn
-
file-name))))
+ (and=> (with-resource-from-pool (reserved-connection-pool) conn
+ (select-derivation-source-file-nar-data-by-file-name conn
+ file-name))
(lambda (data)
(list (build-response
#:code 200
@@ -150,11 +147,9 @@
(define (render-narinfo request
hash)
(or
- (and=> (parallel-via-thread-pool-channel
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-derivation-by-file-name-hash conn
- hash))))
+ (and=> (with-resource-from-pool (reserved-connection-pool) conn
+ (select-derivation-by-file-name-hash conn
+ hash))
(lambda (derivation)
(list (build-response
#:code 200
@@ -162,17 +157,15 @@
(let ((derivation-file-name (second derivation)))
(letpar&
((derivation-text
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-serialized-derivation-by-file-name
- conn
- derivation-file-name))))
+ (with-resource-from-pool (reserved-connection-pool)
conn
+ (select-serialized-derivation-by-file-name
+ conn
+ derivation-file-name)))
(derivation-references
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-derivation-references-by-derivation-id
- conn
- (first derivation))))))
+ (with-resource-from-pool (reserved-connection-pool)
conn
+ (select-derivation-references-by-derivation-id
+ conn
+ (first derivation)))))
(let* ((derivation-bytevector
(string->bytevector derivation-text
"ISO-8859-1"))
@@ -195,11 +188,9 @@
(narinfo-string derivation-file-name
nar-bytevector
derivation-references)))))))
- (and=> (parallel-via-thread-pool-channel
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-derivation-source-file-data-by-file-name-hash conn
- hash))))
+ (and=> (with-resource-from-pool (reserved-connection-pool) conn
+ (select-derivation-source-file-data-by-file-name-hash conn
+ hash))
(match-lambda
((store-path compression compressed-size
hash-algorithm hash uncompressed-size)
diff --git a/guix-data-service/web/package/controller.scm
b/guix-data-service/web/package/controller.scm
index 465c2a3..8dc6b0f 100644
--- a/guix-data-service/web/package/controller.scm
+++ b/guix-data-service/web/package/controller.scm
@@ -22,6 +22,7 @@
#:use-module (guix-data-service utils)
#:use-module (guix-data-service database)
#:use-module (guix-data-service web render)
+ #:use-module (guix-data-service web controller)
#:use-module (guix-data-service web query-parameters)
#:use-module (guix-data-service web util)
#:use-module (guix-data-service model package)
@@ -40,13 +41,12 @@
`((system ,parse-system #:default "x86_64-linux")
(target ,parse-target #:default "")))))
(letpar& ((package-versions-with-branches
- (with-thread-postgresql-connection
- (lambda (conn)
- (branches-by-package-version conn name
- (assq-ref
parsed-query-parameters
- 'system)
- (assq-ref
parsed-query-parameters
- 'target))))))
+ (with-resource-from-pool (connection-pool) conn
+ (branches-by-package-version conn name
+ (assq-ref
parsed-query-parameters
+ 'system)
+ (assq-ref
parsed-query-parameters
+ 'target)))))
(case (most-appropriate-mime-type
'(application/json text/html)
mime-types)
diff --git a/guix-data-service/web/repository/controller.scm
b/guix-data-service/web/repository/controller.scm
index cf6d07f..6724d6f 100644
--- a/guix-data-service/web/repository/controller.scm
+++ b/guix-data-service/web/repository/controller.scm
@@ -34,6 +34,7 @@
#:use-module (guix-data-service model git-repository)
#:use-module (guix-data-service web view html)
#:use-module (guix-data-service web revision controller)
+ #:use-module (guix-data-service web controller)
#:use-module (guix-data-service web repository html)
#:export (repository-controller))
@@ -47,7 +48,7 @@
(match method-and-path-components
(('GET "repositories")
(letpar& ((git-repositories
- (with-thread-postgresql-connection
+ (with-resource-from-pool (connection-pool) conn
all-git-repositories)))
(case (most-appropriate-mime-type
'(application/json text/html)
@@ -67,17 +68,14 @@
#:sxml
(view-git-repositories git-repositories))))))
(('GET "repository" id)
- (match (parallel-via-thread-pool-channel
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-git-repository conn id))))
+ (match (with-resource-from-pool (connection-pool) conn
+ (select-git-repository conn id))
((label url cgit-url-base fetch-with-authentication?)
(letpar& ((branches
- (with-thread-postgresql-connection
- (lambda (conn)
- (all-branches-with-most-recent-commit
- conn
- (string->number id))))))
+ (with-resource-from-pool (connection-pool) conn
+ (all-branches-with-most-recent-commit
+ conn
+ (string->number id)))))
(case (most-appropriate-mime-type
'(application/json text/html)
mime-types)
@@ -122,17 +120,16 @@
(before_date ,parse-datetime)
(limit_results ,parse-result-limit #:default 100)))))
(letpar& ((revisions
- (with-thread-postgresql-connection
- (lambda (conn)
- (most-recent-commits-for-branch
- conn
- (string->number repository-id)
- branch-name
- #:limit (assq-ref parsed-query-parameters 'limit_results)
- #:after-date (assq-ref parsed-query-parameters
- 'after_date)
- #:before-date (assq-ref parsed-query-parameters
- 'before_date))))))
+ (with-resource-from-pool (connection-pool) conn
+ (most-recent-commits-for-branch
+ conn
+ (string->number repository-id)
+ branch-name
+ #:limit (assq-ref parsed-query-parameters 'limit_results)
+ #:after-date (assq-ref parsed-query-parameters
+ 'after_date)
+ #:before-date (assq-ref parsed-query-parameters
+ 'before_date)))))
(case (most-appropriate-mime-type
'(application/json text/html)
mime-types)
@@ -164,12 +161,11 @@
revisions)))))))))
(('GET "repository" repository-id "branch" branch-name "package"
package-name)
(letpar& ((package-versions
- (with-thread-postgresql-connection
- (lambda (conn)
- (package-versions-for-branch conn
- (string->number repository-id)
- branch-name
- package-name)))))
+ (with-resource-from-pool (connection-pool) conn
+ (package-versions-for-branch conn
+ (string->number repository-id)
+ branch-name
+ package-name))))
(case (most-appropriate-mime-type
'(application/json text/html)
mime-types)
@@ -216,17 +212,17 @@
request
`((system ,parse-system #:default "x86_64-linux")))))
(letpar& ((system-test-history
- (with-thread-postgresql-connection
- (lambda (conn)
- (system-test-derivations-for-branch
- conn
- (string->number repository-id)
- branch-name
- (assq-ref parsed-query-parameters
- 'system)
- system-test-name))))
+ (with-resource-from-pool (connection-pool) conn
+ (system-test-derivations-for-branch
+ conn
+ (string->number repository-id)
+ branch-name
+ (assq-ref parsed-query-parameters
+ 'system)
+ system-test-name)))
(valid-systems
- (with-thread-postgresql-connection list-systems)))
+ (call-with-resource-from-pool (connection-pool)
+ list-systems)))
(case (most-appropriate-mime-type
'(application/json text/html)
mime-types)
@@ -261,11 +257,10 @@
system-test-history)))))))
(('GET "repository" repository-id "branch" branch-name
"latest-processed-revision")
(letpar& ((commit-hash
- (with-thread-postgresql-connection
- (lambda (conn)
- (latest-processed-commit-for-branch conn
- repository-id
- branch-name)))))
+ (with-resource-from-pool (connection-pool) conn
+ (latest-processed-commit-for-branch conn
+ repository-id
+ branch-name))))
(if commit-hash
(render-view-revision mime-types
commit-hash
@@ -278,11 +273,10 @@
branch-name))))
(('GET "repository" repository-id "branch" branch-name
"latest-processed-revision" "packages")
(letpar& ((commit-hash
- (with-thread-postgresql-connection
- (lambda (conn)
- (latest-processed-commit-for-branch conn
- repository-id
- branch-name)))))
+ (with-resource-from-pool (connection-pool) conn
+ (latest-processed-commit-for-branch conn
+ repository-id
+ branch-name))))
(if commit-hash
(let ((parsed-query-parameters
(guard-against-mutually-exclusive-query-parameters
@@ -319,11 +313,10 @@
branch-name))))
(('GET "repository" repository-id "branch" branch-name
"latest-processed-revision" "package-derivations")
(letpar& ((commit-hash
- (with-thread-postgresql-connection
- (lambda (conn)
- (latest-processed-commit-for-branch conn
- repository-id
- branch-name)))))
+ (with-resource-from-pool (connection-pool) conn
+ (latest-processed-commit-for-branch conn
+ repository-id
+ branch-name))))
(if commit-hash
(let ((parsed-query-parameters
(guard-against-mutually-exclusive-query-parameters
@@ -353,12 +346,11 @@
branch-name))))
(('GET "repository" repository-id "branch" branch-name
"latest-processed-revision" "fixed-output-package-derivations")
- (letpar& ((commit-hash
- (with-thread-postgresql-connection
- (lambda (conn)
- (latest-processed-commit-for-branch conn
- repository-id
- branch-name)))))
+ (let ((commit-hash
+ (with-resource-from-pool (connection-pool) conn
+ (latest-processed-commit-for-branch conn
+ repository-id
+ branch-name))))
(if commit-hash
(let ((parsed-query-parameters
(guard-against-mutually-exclusive-query-parameters
@@ -383,12 +375,11 @@
repository-id
branch-name))))
(('GET "repository" repository-id "branch" branch-name
"latest-processed-revision" "package-derivation-outputs")
- (letpar& ((commit-hash
- (with-thread-postgresql-connection
- (lambda (conn)
- (latest-processed-commit-for-branch conn
- repository-id
- branch-name)))))
+ (let ((commit-hash
+ (with-resource-from-pool (connection-pool) conn
+ (latest-processed-commit-for-branch conn
+ repository-id
+ branch-name))))
(if commit-hash
(let ((parsed-query-parameters
(guard-against-mutually-exclusive-query-parameters
@@ -431,11 +422,10 @@
(('GET "repository" repository-id "branch" branch-name
"latest-processed-revision" "system-tests")
(letpar& ((commit-hash
- (with-thread-postgresql-connection
- (lambda (conn)
- (latest-processed-commit-for-branch conn
- repository-id
- branch-name)))))
+ (with-resource-from-pool (connection-pool) conn
+ (latest-processed-commit-for-branch conn
+ repository-id
+ branch-name))))
(if commit-hash
(let ((parsed-query-parameters
(parse-query-parameters
@@ -450,11 +440,10 @@
branch-name))))
(('GET "repository" repository-id "branch" branch-name
"latest-processed-revision" "package-reproducibility")
(letpar& ((commit-hash
- (with-thread-postgresql-connection
- (lambda (conn)
- (latest-processed-commit-for-branch conn
- repository-id
- branch-name)))))
+ (with-resource-from-pool (connection-pool) conn
+ (latest-processed-commit-for-branch conn
+ repository-id
+ branch-name))))
(if commit-hash
(render-revision-package-reproduciblity
mime-types
@@ -473,11 +462,10 @@
branch-name))))
(('GET "repository" repository-id "branch" branch-name
"latest-processed-revision" "package-substitute-availability")
(letpar& ((commit-hash
- (with-thread-postgresql-connection
- (lambda (conn)
- (latest-processed-commit-for-branch conn
- repository-id
- branch-name)))))
+ (with-resource-from-pool (connection-pool) conn
+ (latest-processed-commit-for-branch conn
+ repository-id
+ branch-name))))
(if commit-hash
(render-revision-package-substitute-availability mime-types
commit-hash
@@ -488,11 +476,10 @@
(('GET "repository" repository-id "branch" branch-name
"latest-processed-revision"
"lint-warnings")
(letpar& ((commit-hash
- (with-thread-postgresql-connection
- (lambda (conn)
- (latest-processed-commit-for-branch conn
- repository-id
- branch-name)))))
+ (with-resource-from-pool (connection-pool) conn
+ (latest-processed-commit-for-branch conn
+ repository-id
+ branch-name))))
(if commit-hash
(let ((parsed-query-parameters
(parse-query-parameters
@@ -523,11 +510,10 @@
branch-name))))
(('GET "repository" repository-id "branch" branch-name
"latest-processed-revision" "package" name version)
(letpar& ((commit-hash
- (with-thread-postgresql-connection
- (lambda (conn)
- (latest-processed-commit-for-branch conn
- repository-id
- branch-name)))))
+ (with-resource-from-pool (connection-pool) conn
+ (latest-processed-commit-for-branch conn
+ repository-id
+ branch-name))))
(let ((parsed-query-parameters
(parse-query-parameters
request
@@ -558,9 +544,9 @@
(define (parse-build-system)
(let ((systems
- (parallel-via-thread-pool-channel
- (with-thread-postgresql-connection
- list-systems))))
+ (call-with-resource-from-pool
+ (connection-pool)
+ list-systems)))
(lambda (s)
(if (member s systems)
s
@@ -598,16 +584,15 @@
(assq-ref parsed-query-parameters 'target)))
(letpar&
((package-derivations
- (with-thread-postgresql-connection
- (lambda (conn)
- (package-derivations-for-branch conn
- (string->number repository-id)
- branch-name
- system
- target
- package-name))))
+ (with-resource-from-pool (connection-pool) conn
+ (package-derivations-for-branch conn
+ (string->number repository-id)
+ branch-name
+ system
+ target
+ package-name)))
(build-server-urls
- (with-thread-postgresql-connection
+ (call-with-resource-from-pool (connection-pool)
select-build-server-urls-by-id)))
(case (most-appropriate-mime-type
'(application/json text/html)
@@ -635,10 +620,10 @@
package-derivations))))))
(else
(letpar& ((systems
- (with-thread-postgresql-connection
+ (with-resource-from-pool (connection-pool) conn
list-systems))
(targets
- (with-thread-postgresql-connection
+ (with-resource-from-pool (connection-pool) conn
valid-targets)))
(render-html
#:sxml (view-branch-package-derivations
@@ -673,17 +658,17 @@
(assq-ref parsed-query-parameters 'output)))
(letpar&
((package-outputs
- (with-thread-postgresql-connection
- (lambda (conn)
- (package-outputs-for-branch conn
- (string->number repository-id)
- branch-name
- system
- target
- package-name
- output-name))))
+ (with-resource-from-pool (connection-pool) conn
+ (package-outputs-for-branch conn
+ (string->number repository-id)
+ branch-name
+ system
+ target
+ package-name
+ output-name)))
(build-server-urls
- (with-thread-postgresql-connection
+ (call-with-resource-from-pool
+ (connection-pool)
select-build-server-urls-by-id)))
(case (most-appropriate-mime-type
'(application/json text/html)
@@ -711,10 +696,10 @@
package-outputs))))))
(else
(letpar& ((systems
- (with-thread-postgresql-connection
+ (with-resource-from-pool (connection-pool) conn
list-systems))
(targets
- (with-thread-postgresql-connection
+ (with-resource-from-pool (connection-pool) conn
valid-targets)))
(render-html
#:sxml (view-branch-package-outputs
diff --git a/guix-data-service/web/revision/controller.scm
b/guix-data-service/web/revision/controller.scm
index 1cb4528..9cfddd4 100644
--- a/guix-data-service/web/revision/controller.scm
+++ b/guix-data-service/web/revision/controller.scm
@@ -30,6 +30,7 @@
#:use-module (guix-data-service web sxml)
#:use-module (guix-data-service web query-parameters)
#:use-module (guix-data-service web util)
+ #:use-module (guix-data-service web controller)
#:use-module (guix-data-service model utils)
#:use-module (guix-data-service jobs load-new-guix-revision)
#:use-module (guix-data-service model build)
@@ -84,7 +85,7 @@
(define (parse-build-server v)
(letpar& ((build-servers
- (with-thread-postgresql-connection select-build-servers)))
+ (with-resource-from-pool (connection-pool) conn
select-build-servers)))
(or (any (match-lambda
((id url lookup-all-derivations? lookup-builds?)
(if (eq? (string->number v)
@@ -105,20 +106,16 @@
(match method-and-path-components
(('GET "revision" commit-hash)
- (if (parallel-via-thread-pool-channel
- (with-thread-postgresql-connection
- (lambda (conn)
- (guix-revision-loaded-successfully? conn commit-hash))))
+ (if (with-resource-from-pool (connection-pool) conn
+ (guix-revision-loaded-successfully? conn commit-hash))
(render-view-revision mime-types
commit-hash
#:path-base path)
(render-unknown-revision mime-types
commit-hash)))
(('GET "revision" commit-hash "news")
- (if (parallel-via-thread-pool-channel
- (with-thread-postgresql-connection
- (lambda (conn)
- (guix-revision-loaded-successfully? conn commit-hash))))
+ (if (with-resource-from-pool (connection-pool) conn
+ (guix-revision-loaded-successfully? conn commit-hash))
(let ((parsed-query-parameters
(parse-query-parameters
request
@@ -129,10 +126,8 @@
(render-unprocessed-revision mime-types
commit-hash)))
(('GET "revision" commit-hash "packages")
- (if (parallel-via-thread-pool-channel
- (with-thread-postgresql-connection
- (lambda (conn)
- (guix-revision-loaded-successfully? conn commit-hash))))
+ (if (with-resource-from-pool (connection-pool) conn
+ (guix-revision-loaded-successfully? conn commit-hash))
(let ((parsed-query-parameters
(guard-against-mutually-exclusive-query-parameters
(parse-query-parameters
@@ -158,30 +153,24 @@
(render-unprocessed-revision mime-types
commit-hash)))
(('GET "revision" commit-hash "packages-translation-availability")
- (if (parallel-via-thread-pool-channel
- (with-thread-postgresql-connection
- (lambda (conn)
- (guix-revision-loaded-successfully? conn commit-hash))))
+ (if (with-resource-from-pool (connection-pool) conn
+ (guix-revision-loaded-successfully? conn commit-hash))
(render-revision-packages-translation-availability mime-types
commit-hash
#:path-base path)
(render-unprocessed-revision mime-types
commit-hash)))
(('GET "revision" commit-hash "package" name)
- (if (parallel-via-thread-pool-channel
- (with-thread-postgresql-connection
- (lambda (conn)
- (guix-revision-loaded-successfully? conn commit-hash))))
+ (if (with-resource-from-pool (connection-pool) conn
+ (guix-revision-loaded-successfully? conn commit-hash))
(render-revision-package mime-types
commit-hash
name)
(render-unprocessed-revision mime-types
commit-hash)))
(('GET "revision" commit-hash "package" name version)
- (if (parallel-via-thread-pool-channel
- (with-thread-postgresql-connection
- (lambda (conn)
- (guix-revision-loaded-successfully? conn commit-hash))))
+ (if (with-resource-from-pool (connection-pool) conn
+ (guix-revision-loaded-successfully? conn commit-hash))
(let ((parsed-query-parameters
(parse-query-parameters
request
@@ -194,10 +183,8 @@
(render-unprocessed-revision mime-types
commit-hash)))
(('GET "revision" commit-hash "package-derivations")
- (if (parallel-via-thread-pool-channel
- (with-thread-postgresql-connection
- (lambda (conn)
- (guix-revision-loaded-successfully? conn commit-hash))))
+ (if (with-resource-from-pool (connection-pool) conn
+ (guix-revision-loaded-successfully? conn commit-hash))
(let ((parsed-query-parameters
(guard-against-mutually-exclusive-query-parameters
(parse-query-parameters
@@ -228,10 +215,8 @@
(render-unprocessed-revision mime-types
commit-hash)))
(('GET "revision" commit-hash "fixed-output-package-derivations")
- (if (parallel-via-thread-pool-channel
- (with-thread-postgresql-connection
- (lambda (conn)
- (guix-revision-loaded-successfully? conn commit-hash))))
+ (if (with-resource-from-pool (connection-pool) conn
+ (guix-revision-loaded-successfully? conn commit-hash))
(let ((parsed-query-parameters
(guard-against-mutually-exclusive-query-parameters
(parse-query-parameters
@@ -254,10 +239,8 @@
(render-unprocessed-revision mime-types
commit-hash)))
(('GET "revision" commit-hash "package-derivation-outputs")
- (if (parallel-via-thread-pool-channel
- (with-thread-postgresql-connection
- (lambda (conn)
- (guix-revision-loaded-successfully? conn commit-hash))))
+ (if (with-resource-from-pool (connection-pool) conn
+ (guix-revision-loaded-successfully? conn commit-hash))
(let ((parsed-query-parameters
(guard-against-mutually-exclusive-query-parameters
(parse-query-parameters
@@ -287,10 +270,8 @@
(render-unprocessed-revision mime-types
commit-hash)))
(('GET "revision" commit-hash "system-tests")
- (if (parallel-via-thread-pool-channel
- (with-thread-postgresql-connection
- (lambda (conn)
- (guix-revision-loaded-successfully? conn commit-hash))))
+ (if (with-resource-from-pool (connection-pool) conn
+ (guix-revision-loaded-successfully? conn commit-hash))
(let ((parsed-query-parameters
(parse-query-parameters
request
@@ -302,40 +283,32 @@
(render-unprocessed-revision mime-types
commit-hash)))
(('GET "revision" commit-hash "channel-instances")
- (if (parallel-via-thread-pool-channel
- (with-thread-postgresql-connection
- (lambda (conn)
- (channel-instances-exist-for-guix-revision? conn commit-hash))))
+ (if (with-resource-from-pool (connection-pool) conn
+ (channel-instances-exist-for-guix-revision? conn commit-hash))
(render-revision-channel-instances mime-types
commit-hash
#:path-base path)
(render-unprocessed-revision mime-types
commit-hash)))
(('GET "revision" commit-hash "package-substitute-availability")
- (if (parallel-via-thread-pool-channel
- (with-thread-postgresql-connection
- (lambda (conn)
- (guix-revision-loaded-successfully? conn commit-hash))))
+ (if (with-resource-from-pool (connection-pool) conn
+ (guix-revision-loaded-successfully? conn commit-hash))
(render-revision-package-substitute-availability mime-types
commit-hash
#:path-base path)
(render-unprocessed-revision mime-types
commit-hash)))
(('GET "revision" commit-hash "package-reproducibility")
- (if (parallel-via-thread-pool-channel
- (with-thread-postgresql-connection
- (lambda (conn)
- (guix-revision-loaded-successfully? conn commit-hash))))
+ (if (with-resource-from-pool (connection-pool) conn
+ (guix-revision-loaded-successfully? conn commit-hash))
(render-revision-package-reproduciblity mime-types
commit-hash
#:path-base path)
(render-unprocessed-revision mime-types
commit-hash)))
(('GET "revision" commit-hash "builds")
- (if (parallel-via-thread-pool-channel
- (with-thread-postgresql-connection
- (lambda (conn)
- (guix-revision-loaded-successfully? conn commit-hash))))
+ (if (with-resource-from-pool (connection-pool) conn
+ (guix-revision-loaded-successfully? conn commit-hash))
(let ((parsed-query-parameters
(guard-against-mutually-exclusive-query-parameters
(parse-query-parameters
@@ -357,10 +330,8 @@
(render-unprocessed-revision mime-types
commit-hash)))
(('GET "revision" commit-hash "blocking-builds")
- (if (parallel-via-thread-pool-channel
- (with-thread-postgresql-connection
- (lambda (conn)
- (guix-revision-loaded-successfully? conn commit-hash))))
+ (if (with-resource-from-pool (connection-pool) conn
+ (guix-revision-loaded-successfully? conn commit-hash))
(let ((parsed-query-parameters
(guard-against-mutually-exclusive-query-parameters
(parse-query-parameters
@@ -381,10 +352,8 @@
(render-unprocessed-revision mime-types
commit-hash)))
(('GET "revision" commit-hash "lint-warnings")
- (if (parallel-via-thread-pool-channel
- (with-thread-postgresql-connection
- (lambda (conn)
- (guix-revision-loaded-successfully? conn commit-hash))))
+ (if (with-resource-from-pool (connection-pool) conn
+ (guix-revision-loaded-successfully? conn commit-hash))
(let ((parsed-query-parameters
(parse-query-parameters
request
@@ -424,18 +393,15 @@
#:code 404))
(else
(letpar& ((job
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-job-for-commit conn commit-hash))))
+ (with-resource-from-pool (connection-pool) conn
+ (select-job-for-commit conn commit-hash)))
(git-repositories-and-branches
- (with-thread-postgresql-connection
- (lambda (conn)
- (git-branches-with-repository-details-for-commit conn
-
commit-hash))))
+ (with-resource-from-pool (connection-pool) conn
+ (git-branches-with-repository-details-for-commit conn
+
commit-hash)))
(jobs-and-events
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-jobs-and-events-for-commit conn commit-hash)))))
+ (with-resource-from-pool (connection-pool) conn
+ (select-jobs-and-events-for-commit conn commit-hash))))
(render-html
#:code 404
@@ -455,18 +421,15 @@
#:code 404))
(else
(letpar& ((job
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-job-for-commit conn commit-hash))))
+ (with-resource-from-pool (connection-pool) conn
+ (select-job-for-commit conn commit-hash)))
(git-repositories-and-branches
- (with-thread-postgresql-connection
- (lambda (conn)
- (git-branches-with-repository-details-for-commit conn
-
commit-hash))))
+ (with-resource-from-pool (connection-pool) conn
+ (git-branches-with-repository-details-for-commit conn
+
commit-hash)))
(jobs-and-events
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-jobs-and-events-for-commit conn commit-hash)))))
+ (with-resource-from-pool (connection-pool) conn
+ (select-jobs-and-events-for-commit conn commit-hash))))
(render-html
#:code 404
@@ -482,27 +445,22 @@
(header-text
`("Revision " (samp ,commit-hash))))
(letpar& ((packages-count
- (with-thread-postgresql-connection
- (lambda (conn)
- (count-packages-in-revision conn commit-hash))))
+ (with-resource-from-pool (connection-pool) conn
+ (count-packages-in-revision conn commit-hash)))
(git-repositories-and-branches
- (with-thread-postgresql-connection
- (lambda (conn)
- (git-branches-with-repository-details-for-commit conn
-
commit-hash))))
+ (with-resource-from-pool (connection-pool) conn
+ (git-branches-with-repository-details-for-commit conn
+ commit-hash)))
(derivations-counts
- (with-thread-postgresql-connection
- (lambda (conn)
- (count-packages-derivations-in-revision conn commit-hash))))
+ (with-resource-from-pool (connection-pool) conn
+ (count-packages-derivations-in-revision conn commit-hash)))
(jobs-and-events
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-jobs-and-events-for-commit conn commit-hash))))
+ (with-resource-from-pool (connection-pool) conn
+ (select-jobs-and-events-for-commit conn commit-hash)))
(lint-warning-counts
- (with-thread-postgresql-connection
- (lambda (conn)
- (lint-warning-count-by-lint-checker-for-revision conn
-
commit-hash)))))
+ (with-resource-from-pool (connection-pool) conn
+ (lint-warning-count-by-lint-checker-for-revision conn
+ commit-hash))))
(case (most-appropriate-mime-type
'(application/json text/html)
mime-types)
@@ -547,12 +505,11 @@
(header-link
(string-append "/revision/"
commit-hash)))
(letpar& ((system-tests
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-system-tests-for-guix-revision
- conn
- (assq-ref query-parameters 'system)
- commit-hash)))))
+ (with-resource-from-pool (connection-pool) conn
+ (select-system-tests-for-guix-revision
+ conn
+ (assq-ref query-parameters 'system)
+ commit-hash))))
(case (most-appropriate-mime-type
'(application/json text/html)
mime-types)
@@ -576,12 +533,11 @@
system-tests))))))
(else
(letpar& ((git-repositories
- (with-thread-postgresql-connection
- (lambda (conn)
- (git-repositories-containing-commit conn
- commit-hash))))
+ (with-resource-from-pool (connection-pool) conn
+ (git-repositories-containing-commit conn
+ commit-hash)))
(systems
- (with-thread-postgresql-connection list-systems)))
+ (with-resource-from-pool (connection-pool) conn
list-systems)))
(render-html
#:sxml (view-revision-system-tests
commit-hash
@@ -603,9 +559,8 @@
(string-append "/revision/"
commit-hash)))
(letpar& ((channel-instances
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-channel-instances-for-guix-revision conn
commit-hash)))))
+ (with-resource-from-pool (connection-pool) conn
+ (select-channel-instances-for-guix-revision conn commit-hash))))
(case (most-appropriate-mime-type
'(application/json text/html)
mime-types)
@@ -632,12 +587,12 @@
commit-hash
#:key path-base)
(letpar& ((substitute-availability
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-package-output-availability-for-revision conn
-
commit-hash))))
+ (with-resource-from-pool (connection-pool) conn
+ (select-package-output-availability-for-revision conn
+ commit-hash)))
(build-server-urls
- (with-thread-postgresql-connection
+ (call-with-resource-from-pool
+ (connection-pool)
select-build-server-urls-by-id)))
(case (most-appropriate-mime-type
'(application/json text/html)
@@ -678,9 +633,8 @@
(string-append "/revision/"
commit-hash)))
(letpar& ((output-consistency
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-output-consistency-for-revision conn commit-hash)))))
+ (with-resource-from-pool (connection-pool) conn
+ (select-output-consistency-for-revision conn commit-hash))))
(case (most-appropriate-mime-type
'(application/json text/html)
mime-types)
@@ -713,11 +667,10 @@
query-parameters
'()))))
(letpar& ((news-entries
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-channel-news-entries-contained-in-guix-revision
- conn
- commit-hash)))))
+ (with-resource-from-pool (connection-pool) conn
+ (select-channel-news-entries-contained-in-guix-revision
+ conn
+ commit-hash))))
(case (most-appropriate-mime-type
'(application/json text/html)
mime-types)
@@ -774,26 +727,24 @@
(locale (assq-ref query-parameters 'locale)))
(letpar&
((packages
- (with-thread-postgresql-connection
- (lambda (conn)
- (if search-query
- (search-packages-in-revision
- conn
- commit-hash
- search-query
- #:limit-results limit-results
- #:locale locale)
- (select-packages-in-revision
- conn
- commit-hash
- #:limit-results limit-results
- #:after-name (assq-ref query-parameters 'after_name)
- #:locale (assq-ref query-parameters 'locale))))))
+ (with-resource-from-pool (connection-pool) conn
+ (if search-query
+ (search-packages-in-revision
+ conn
+ commit-hash
+ search-query
+ #:limit-results limit-results
+ #:locale locale)
+ (select-packages-in-revision
+ conn
+ commit-hash
+ #:limit-results limit-results
+ #:after-name (assq-ref query-parameters 'after_name)
+ #:locale (assq-ref query-parameters 'locale)))))
(git-repositories
- (with-thread-postgresql-connection
- (lambda (conn)
- (git-repositories-containing-commit conn
- commit-hash)))))
+ (with-resource-from-pool (connection-pool) conn
+ (git-repositories-containing-commit conn
+ commit-hash))))
(let ((show-next-page?
(and (not search-query)
(>= (length packages)
@@ -843,14 +794,12 @@
packages))))
#:extra-headers http-headers-for-unchanging-content))
(else
- (letpar&
- ((locale-options
- (with-thread-postgresql-connection
- (lambda (conn)
+ (let ((locale-options
+ (with-resource-from-pool (connection-pool) conn
(description-and-synopsis-locale-options
(package-description-and-synopsis-locale-options-guix-revision
conn
- (commit->revision-id conn commit-hash)))))))
+ (commit->revision-id conn commit-hash))))))
(render-html
#:sxml (view-revision-packages commit-hash
query-parameters
@@ -874,19 +823,17 @@
(header-text
`("Revision "
(samp ,commit-hash))))
(letpar& ((package-synopsis-counts
- (with-thread-postgresql-connection
- (lambda (conn)
- (synopsis-counts-by-locale conn
- (commit->revision-id
- conn
- commit-hash)))))
+ (with-resource-from-pool (connection-pool) conn
+ (synopsis-counts-by-locale conn
+ (commit->revision-id
+ conn
+ commit-hash))))
(package-description-counts
- (with-thread-postgresql-connection
- (lambda (conn)
- (description-counts-by-locale conn
- (commit->revision-id
- conn
- commit-hash))))))
+ (with-resource-from-pool (connection-pool) conn
+ (description-counts-by-locale conn
+ (commit->revision-id
+ conn
+ commit-hash)))))
(case (most-appropriate-mime-type
'(application/json text/html)
mime-types)
@@ -916,16 +863,14 @@
(string-append
"/revision/" commit-hash)))
(letpar& ((package-versions
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-package-versions-for-revision conn
- commit-hash
- name))))
+ (with-resource-from-pool (connection-pool) conn
+ (select-package-versions-for-revision conn
+ commit-hash
+ name)))
(git-repositories-and-branches
- (with-thread-postgresql-connection
- (lambda (conn)
- (git-branches-with-repository-details-for-commit conn
-
commit-hash)))))
+ (with-resource-from-pool (connection-pool) conn
+ (git-branches-with-repository-details-for-commit conn
+ commit-hash))))
(case (most-appropriate-mime-type
'(application/json text/html)
mime-types)
@@ -963,48 +908,42 @@
(match-lambda
((locale)
locale))
- (parallel-via-thread-pool-channel
- (with-thread-postgresql-connection
- (lambda (conn)
- (delete-duplicates
- (append
- (package-description-and-synopsis-locale-options-guix-revision
- conn (commit->revision-id conn commit-hash))
- (lint-warning-message-locales-for-revision conn commit-hash))))))))
+ (with-resource-from-pool (connection-pool) conn
+ (delete-duplicates
+ (append
+ (package-description-and-synopsis-locale-options-guix-revision
+ conn (commit->revision-id conn commit-hash))
+ (lint-warning-message-locales-for-revision conn commit-hash))))))
(define locale (assq-ref query-parameters 'locale))
(letpar& ((metadata
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-package-metadata-by-revision-name-and-version
- conn
- commit-hash
- name
- version
- locale))))
+ (with-resource-from-pool (connection-pool) conn
+ (select-package-metadata-by-revision-name-and-version
+ conn
+ commit-hash
+ name
+ version
+ locale)))
(derivations
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-derivations-by-revision-name-and-version
- conn
- commit-hash
- name
- version))))
+ (with-resource-from-pool (connection-pool) conn
+ (select-derivations-by-revision-name-and-version
+ conn
+ commit-hash
+ name
+ version)))
(git-repositories
- (with-thread-postgresql-connection
- (lambda (conn)
- (git-repositories-containing-commit conn
- commit-hash))))
+ (with-resource-from-pool (connection-pool) conn
+ (git-repositories-containing-commit conn
+ commit-hash)))
(lint-warnings
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-lint-warnings-by-revision-package-name-and-version
- conn
- commit-hash
- name
- version
- #:locale locale)))))
+ (with-resource-from-pool (connection-pool) conn
+ (select-lint-warnings-by-revision-package-name-and-version
+ conn
+ commit-hash
+ name
+ version
+ #:locale locale))))
(case (most-appropriate-mime-type
'(application/json text/html)
mime-types)
@@ -1062,9 +1001,11 @@
`((error . "invalid query"))))
(else
(letpar& ((systems
- (with-thread-postgresql-connection list-systems))
+ (call-with-resource-from-pool (connection-pool)
+ list-systems))
(targets
- (with-thread-postgresql-connection valid-targets)))
+ (call-with-resource-from-pool (connection-pool)
+ valid-targets)))
(render-html
#:sxml (view-revision-package-derivations commit-hash
query-parameters
@@ -1087,46 +1028,45 @@
(assq-ref query-parameters 'field)))
(letpar&
((derivations
- (with-thread-postgresql-connection
- (lambda (conn)
- (if search-query
- (search-package-derivations-in-revision
- conn
- commit-hash
- search-query
- #:systems (assq-ref query-parameters 'system)
- #:targets (assq-ref query-parameters 'target)
- #:maximum-builds (assq-ref query-parameters
'maximum_builds)
- #:minimum-builds (assq-ref query-parameters
'minimum_builds)
- #:build-from-build-servers (assq-ref query-parameters
-
'build_from_build_server)
- #:no-build-from-build-servers (assq-ref query-parameters
-
'no_build_from_build_server)
- #:build-status (and=> (assq-ref query-parameters
- 'build_status)
- string->symbol)
- #:limit-results limit-results
- #:after-name (assq-ref query-parameters 'after_name)
- #:include-builds? (member "builds" fields))
- (select-package-derivations-in-revision
- conn
- commit-hash
- #:systems (assq-ref query-parameters 'system)
- #:targets (assq-ref query-parameters 'target)
- #:maximum-builds (assq-ref query-parameters
'maximum_builds)
- #:minimum-builds (assq-ref query-parameters
'minimum_builds)
- #:build-from-build-servers (assq-ref query-parameters
-
'build_from_build_server)
- #:no-build-from-build-servers (assq-ref query-parameters
-
'no_build_from_build_server)
- #:build-status (and=> (assq-ref query-parameters
- 'build_status)
- string->symbol)
- #:limit-results limit-results
- #:after-name (assq-ref query-parameters 'after_name)
- #:include-builds? (member "builds" fields))))))
+ (with-resource-from-pool (connection-pool) conn
+ (if search-query
+ (search-package-derivations-in-revision
+ conn
+ commit-hash
+ search-query
+ #:systems (assq-ref query-parameters 'system)
+ #:targets (assq-ref query-parameters 'target)
+ #:maximum-builds (assq-ref query-parameters
'maximum_builds)
+ #:minimum-builds (assq-ref query-parameters
'minimum_builds)
+ #:build-from-build-servers (assq-ref query-parameters
+
'build_from_build_server)
+ #:no-build-from-build-servers (assq-ref query-parameters
+
'no_build_from_build_server)
+ #:build-status (and=> (assq-ref query-parameters
+ 'build_status)
+ string->symbol)
+ #:limit-results limit-results
+ #:after-name (assq-ref query-parameters 'after_name)
+ #:include-builds? (member "builds" fields))
+ (select-package-derivations-in-revision
+ conn
+ commit-hash
+ #:systems (assq-ref query-parameters 'system)
+ #:targets (assq-ref query-parameters 'target)
+ #:maximum-builds (assq-ref query-parameters
'maximum_builds)
+ #:minimum-builds (assq-ref query-parameters
'minimum_builds)
+ #:build-from-build-servers (assq-ref query-parameters
+
'build_from_build_server)
+ #:no-build-from-build-servers (assq-ref query-parameters
+
'no_build_from_build_server)
+ #:build-status (and=> (assq-ref query-parameters
+ 'build_status)
+ string->symbol)
+ #:limit-results limit-results
+ #:after-name (assq-ref query-parameters 'after_name)
+ #:include-builds? (member "builds" fields)))))
(build-server-urls
- (with-thread-postgresql-connection
+ (with-resource-from-pool (connection-pool) conn
select-build-server-urls-by-id)))
(let ((show-next-page?
(if all-results
@@ -1161,9 +1101,11 @@
derivations))))))
(else
(letpar& ((systems
- (with-thread-postgresql-connection list-systems))
+ (call-with-resource-from-pool (connection-pool)
+ list-systems))
(targets
- (with-thread-postgresql-connection valid-targets)))
+ (call-with-resource-from-pool (connection-pool)
+ valid-targets)))
(render-html
#:sxml (view-revision-package-derivations
commit-hash
@@ -1197,9 +1139,11 @@
`((error . "invalid query"))))
(else
(letpar& ((systems
- (with-thread-postgresql-connection list-systems))
+ (call-with-resource-from-pool (connection-pool)
+ list-systems))
(targets
- (with-thread-postgresql-connection valid-targets)))
+ (call-with-resource-from-pool (connection-pool)
+ valid-targets)))
(render-html
#:sxml (view-revision-fixed-output-package-derivations
commit-hash
@@ -1222,20 +1166,19 @@
(assq-ref query-parameters 'field)))
(letpar&
((derivations
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-fixed-output-package-derivations-in-revision
- conn
- commit-hash
- (assq-ref query-parameters 'system)
- (assq-ref query-parameters 'target)
- #:latest-build-status (assq-ref query-parameters
- 'latest_build_status)
- #:limit-results limit-results
- #:after-derivation-file-name
- (assq-ref query-parameters 'after_name)))))
+ (with-resource-from-pool (connection-pool) conn
+ (select-fixed-output-package-derivations-in-revision
+ conn
+ commit-hash
+ (assq-ref query-parameters 'system)
+ (assq-ref query-parameters 'target)
+ #:latest-build-status (assq-ref query-parameters
+ 'latest_build_status)
+ #:limit-results limit-results
+ #:after-derivation-file-name
+ (assq-ref query-parameters 'after_name))))
(build-server-urls
- (with-thread-postgresql-connection
+ (with-resource-from-pool (connection-pool) conn
select-build-server-urls-by-id)))
(let ((show-next-page?
(if all-results
@@ -1251,9 +1194,11 @@
`((derivations . ,(list->vector derivations)))))
(else
(letpar& ((systems
- (with-thread-postgresql-connection list-systems))
+ (call-with-resource-from-pool (connection-pool)
+ list-systems))
(targets
- (with-thread-postgresql-connection valid-targets)))
+ (call-with-resource-from-pool (connection-pool)
+ valid-targets)))
(render-html
#:sxml (view-revision-fixed-output-package-derivations
commit-hash
@@ -1278,8 +1223,9 @@
(header-link
(string-append "/revision/" commit-hash)))
(define build-server-urls
- (parallel-via-thread-pool-channel
- (with-thread-postgresql-connection select-build-server-urls-by-id)))
+ (call-with-resource-from-pool
+ (connection-pool)
+ select-build-server-urls-by-id))
(if (any-invalid-query-parameters? query-parameters)
(case (most-appropriate-mime-type
@@ -1290,9 +1236,11 @@
`((error . "invalid query"))))
(else
(letpar& ((systems
- (with-thread-postgresql-connection list-systems))
+ (call-with-resource-from-pool (connection-pool)
+ list-systems))
(targets
- (with-thread-postgresql-connection valid-targets)))
+ (call-with-resource-from-pool (connection-pool)
+ valid-targets)))
(render-html
#:sxml (view-revision-package-derivation-outputs
commit-hash
@@ -1313,23 +1261,22 @@
(assq-ref query-parameters 'field)))
(letpar&
((derivation-outputs
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-derivation-outputs-in-revision
- conn
- commit-hash
- #:search-query (assq-ref query-parameters 'search_query)
- #:nars-from-build-servers
- (assq-ref query-parameters 'substitutes_available_from)
- #:no-nars-from-build-servers
- (assq-ref query-parameters 'substitutes_not_available_from)
- #:output-consistency
- (assq-ref query-parameters 'output_consistency)
- #:system (assq-ref query-parameters 'system)
- #:target (assq-ref query-parameters 'target)
- #:include-nars? (member "nars" fields)
- #:limit-results limit-results
- #:after-path (assq-ref query-parameters 'after_path))))))
+ (with-resource-from-pool (connection-pool) conn
+ (select-derivation-outputs-in-revision
+ conn
+ commit-hash
+ #:search-query (assq-ref query-parameters 'search_query)
+ #:nars-from-build-servers
+ (assq-ref query-parameters 'substitutes_available_from)
+ #:no-nars-from-build-servers
+ (assq-ref query-parameters 'substitutes_not_available_from)
+ #:output-consistency
+ (assq-ref query-parameters 'output_consistency)
+ #:system (assq-ref query-parameters 'system)
+ #:target (assq-ref query-parameters 'target)
+ #:include-nars? (member "nars" fields)
+ #:limit-results limit-results
+ #:after-path (assq-ref query-parameters 'after_path)))))
(let ((show-next-page?
(if all-results
#f
@@ -1395,9 +1342,11 @@
derivation-outputs))))))
(else
(letpar& ((systems
- (with-thread-postgresql-connection list-systems))
+ (call-with-resource-from-pool (connection-pool)
+ list-systems))
(targets
- (with-thread-postgresql-connection valid-targets)))
+ (call-with-resource-from-pool (connection-pool)
+ valid-targets)))
(render-html
#:sxml (view-revision-package-derivation-outputs
commit-hash
@@ -1422,9 +1371,11 @@
(string-append "/revision/" commit-hash)))
(if (any-invalid-query-parameters? query-parameters)
(letpar& ((systems
- (with-thread-postgresql-connection list-systems))
+ (call-with-resource-from-pool (connection-pool)
+ list-systems))
(targets
- (with-thread-postgresql-connection valid-targets)))
+ (call-with-resource-from-pool (connection-pool)
+ valid-targets)))
(render-html
#:sxml
(view-revision-builds query-parameters
@@ -1438,41 +1389,40 @@
(let ((system (assq-ref query-parameters 'system))
(target (assq-ref query-parameters 'target)))
(letpar& ((systems
- (with-thread-postgresql-connection list-systems))
+ (call-with-resource-from-pool (connection-pool)
+ list-systems))
(targets
- (with-thread-postgresql-connection valid-targets))
+ (call-with-resource-from-pool (connection-pool)
+ valid-targets))
(build-server-options
- (with-thread-postgresql-connection
- (lambda (conn)
- (map (match-lambda
- ((id url lookup-all-derivations
- lookup-builds)
- (cons url id)))
- (select-build-servers conn)))))
+ (with-resource-from-pool (connection-pool) conn
+ (map (match-lambda
+ ((id url lookup-all-derivations
+ lookup-builds)
+ (cons url id)))
+ (select-build-servers conn))))
(stats
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-build-stats
- conn
- (assq-ref query-parameters
- 'build_server)
- #:revision-commit commit-hash
- #:system system
- #:target target))))
+ (with-resource-from-pool (connection-pool) conn
+ (select-build-stats
+ conn
+ (assq-ref query-parameters
+ 'build_server)
+ #:revision-commit commit-hash
+ #:system system
+ #:target target)))
(builds
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-builds-with-context
- conn
- (assq-ref query-parameters
- 'build_status)
- (assq-ref query-parameters
- 'build_server)
- #:revision-commit commit-hash
- #:system system
- #:target target
- #:limit (assq-ref query-parameters
- 'limit_results))))))
+ (with-resource-from-pool (connection-pool) conn
+ (select-builds-with-context
+ conn
+ (assq-ref query-parameters
+ 'build_status)
+ (assq-ref query-parameters
+ 'build_server)
+ #:revision-commit commit-hash
+ #:system system
+ #:target target
+ #:limit (assq-ref query-parameters
+ 'limit_results)))))
(render-html
#:sxml (view-revision-builds query-parameters
commit-hash
@@ -1494,9 +1444,11 @@
(string-append "/revision/"
commit-hash)))
(if (any-invalid-query-parameters? query-parameters)
(letpar& ((systems
- (with-thread-postgresql-connection list-systems))
+ (call-with-resource-from-pool (connection-pool)
+ list-systems))
(targets
- (with-thread-postgresql-connection valid-targets)))
+ (call-with-resource-from-pool (connection-pool)
+ valid-targets)))
(render-html
#:sxml
(view-revision-blocking-builds query-parameters
@@ -1509,29 +1461,29 @@
(let ((system (assq-ref query-parameters 'system))
(target (assq-ref query-parameters 'target)))
(letpar& ((systems
- (with-thread-postgresql-connection list-systems))
+ (call-with-resource-from-pool (connection-pool)
+ list-systems))
(targets
- (with-thread-postgresql-connection valid-targets))
+ (call-with-resource-from-pool (connection-pool)
+ valid-targets))
(build-server-options
- (with-thread-postgresql-connection
- (lambda (conn)
- (map (match-lambda
- ((id url lookup-all-derivations
- lookup-builds)
- (cons url id)))
- (select-build-servers conn)))))
+ (with-resource-from-pool (connection-pool) conn
+ (map (match-lambda
+ ((id url lookup-all-derivations
+ lookup-builds)
+ (cons url id)))
+ (select-build-servers conn))))
(blocking-builds
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-blocking-builds
- conn
- commit-hash
- #:build-server-ids
- (assq-ref query-parameters 'build_server)
- #:system system
- #:target target
- #:limit (assq-ref query-parameters
- 'limit_results))))))
+ (with-resource-from-pool (connection-pool) conn
+ (select-blocking-builds
+ conn
+ commit-hash
+ #:build-server-ids
+ (assq-ref query-parameters 'build_server)
+ #:system system
+ #:target target
+ #:limit (assq-ref query-parameters
+ 'limit_results)))))
(render-html
#:sxml (view-revision-blocking-builds query-parameters
commit-hash
@@ -1551,24 +1503,20 @@
(header-link
(string-append "/revision/"
commit-hash)))
(define lint-checker-options
- (parallel-via-thread-pool-channel
- (with-thread-postgresql-connection
- (lambda (conn)
- (map (match-lambda
- ((name description network-dependent)
- (cons (string-append name ": " description )
- name)))
- (lint-checkers-for-revision conn commit-hash))))))
+ (with-resource-from-pool (connection-pool) conn
+ (map (match-lambda
+ ((name description network-dependent)
+ (cons (string-append name ": " description )
+ name)))
+ (lint-checkers-for-revision conn commit-hash))))
(define lint-warnings-locale-options
- (parallel-via-thread-pool-channel
- (with-thread-postgresql-connection
- (lambda (conn)
- (map
- (match-lambda
- ((locale)
- locale))
- (lint-warning-message-locales-for-revision conn commit-hash))))))
+ (with-resource-from-pool (connection-pool) conn
+ (map
+ (match-lambda
+ ((locale)
+ locale))
+ (lint-warning-message-locales-for-revision conn commit-hash))))
(if (any-invalid-query-parameters? query-parameters)
(case (most-appropriate-mime-type
@@ -1597,18 +1545,16 @@
(fields (assq-ref query-parameters 'field)))
(letpar&
((git-repositories
- (with-thread-postgresql-connection
- (lambda (conn)
- (git-repositories-containing-commit conn
- commit-hash))))
+ (with-resource-from-pool (connection-pool) conn
+ (git-repositories-containing-commit conn
+ commit-hash)))
(lint-warnings
- (with-thread-postgresql-connection
- (lambda (conn)
- (lint-warnings-for-guix-revision conn commit-hash
- #:locale locale
- #:package-query package-query
- #:linters linters
- #:message-query
message-query)))))
+ (with-resource-from-pool (connection-pool) conn
+ (lint-warnings-for-guix-revision conn commit-hash
+ #:locale locale
+ #:package-query package-query
+ #:linters linters
+ #:message-query
message-query))))
(let ((any-translated-lint-warnings?
(any-translated-lint-warnings? lint-warnings locale)))
(case (most-appropriate-mime-type
diff --git a/guix-data-service/web/server.scm b/guix-data-service/web/server.scm
index 6570c1a..84a0e6b 100644
--- a/guix-data-service/web/server.scm
+++ b/guix-data-service/web/server.scm
@@ -25,8 +25,10 @@
#:use-module (web uri)
#:use-module (system repl error-handling)
#:use-module (ice-9 atomic)
- #:use-module (fibers web server)
+ #:use-module (fibers)
+ #:use-module (fibers conditions)
#:use-module (prometheus)
+ #:use-module (guix-data-service utils)
#:use-module (guix-data-service database)
#:use-module (guix-data-service web controller)
#:use-module (guix-data-service web util)
@@ -60,7 +62,9 @@
render-metrics))))
(define* (start-guix-data-service-web-server port host secret-key-base
- startup-completed)
+ startup-completed
+ #:key postgresql-statement-timeout
+ postgresql-connections)
(define registry
(make-metrics-registry #:namespace "guixdataservice"))
@@ -69,25 +73,50 @@
(%database-metrics-registry registry)
- (call-with-error-handling
- (lambda ()
- (run-server (lambda (request body)
+ (let ((finished? (make-condition)))
+ (call-with-sigint
+ (lambda ()
+ (run-fibers
+ (lambda ()
+ (parameterize
+ ((connection-pool
+ (make-resource-pool
+ (lambda ()
+ (open-postgresql-connection
+ "web"
+ postgresql-statement-timeout))
+ (floor (/ postgresql-connections 2))))
+
+ (reserved-connection-pool
+ (make-resource-pool
+ (lambda ()
+ (open-postgresql-connection
+ "web-reserved"
+ postgresql-statement-timeout))
+ (floor (/ postgresql-connections 2))))
+
+ (resource-pool-default-timeout 10))
+
+ (with-exception-handler
+ (lambda (exn)
+ (simple-format
+ (current-error-port)
+ "\n
+error: guix-data-service could not start: ~A
+
+Check if it's already running, or whether another process is using that
+port. Also, the port used can be changed by passing the --port option.\n"
+ exn)
+ (primitive-exit 1))
+ (lambda ()
+ (run-server/patched
+ (lambda (request body)
(handler request body controller
secret-key-base
startup-completed
render-metrics))
#:host host
#:port port))
- #:on-error 'backtrace
- #:post-error (lambda (key . args)
- (when (eq? key 'system-error)
- (match args
- (("bind" "~A" ("Address already in use") _)
- (simple-format
- (current-error-port)
- "\n
-error: guix-data-service could not start, as it could not bind to port ~A
-
-Check if it's already running, or whether another process is using that
-port. Also, the port used can be changed by passing the --port option.\n"
- port)))))))
+ #:unwind? #t))
+ (wait finished?))))
+ finished?)))
diff --git a/scripts/guix-data-service.in b/scripts/guix-data-service.in
index 6a41413..1a41bd4 100644
--- a/scripts/guix-data-service.in
+++ b/scripts/guix-data-service.in
@@ -93,11 +93,11 @@
(alist-cons 'host
arg
(alist-delete 'host result))))
- (option '("thread-pool-threads") #t #f
+ (option '("postgresql-connections") #t #f
(lambda (opt name arg result)
- (alist-cons 'thread-pool-threads
+ (alist-cons 'postgresql-connections
(string->number arg)
- (alist-delete 'thread-pool-threads
+ (alist-delete 'postgresql-connections
result))))
(option '("postgresql-statement-timeout") #t #f
(lambda (opt name arg result)
@@ -119,7 +119,7 @@
(_ #t)))
(port . 8765)
(host . "0.0.0.0")
- (thread-pool-threads . 16)
+ (postgresql-connections . 16)
(postgresql-statement-timeout . 60000)))
@@ -187,44 +187,6 @@
(if (assoc-ref opts 'update-database)
#f
#t)))
- (server-thread
- (call-with-new-thread
- (lambda ()
- (with-postgresql-connection-per-thread
- "web"
- (lambda ()
- ;; Provide some visual space between the startup output and
the server
- ;; starting
- (simple-format #t "\n\nStarting the server on
http://~A:~A/\n\n";
- (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))
-
- (thread-pool-request-timeout 10))
-
- (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)))))
(pid-file (assq-ref opts 'pid-file)))
@@ -233,11 +195,6 @@
(lambda (port)
(simple-format port "~A\n" (getpid)))))
- (when (assoc-ref opts 'update-database)
- (run-sqitch)
-
- (atomic-box-set! startup-completed #t))
-
(call-with-new-thread
(lambda ()
(with-postgresql-connection-per-thread
@@ -247,4 +204,24 @@
(start-substitute-query-threads)
- (join-thread server-thread))))
+ (when (assoc-ref opts 'update-database)
+ (call-with-new-thread
+ (lambda ()
+ (run-sqitch)
+
+ (atomic-box-set! startup-completed #t))))
+
+ ;; Provide some visual space between the startup output and the
+ ;; server starting
+ (simple-format #t "\n\nStarting the server on http://~A:~A/\n\n";
+ (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
+ #:postgresql-statement-timeout
+ (assq-ref opts 'postgresql-statement-timeout)
+ #:postgresql-connections
+ (assq-ref opts 'postgresql-connections)))))
- branch master updated (672ee62 -> de6d380), Christopher Baines, 2023/07/19
- 06/09: Drop the resource pool timeout, Christopher Baines, 2023/07/19
- 02/09: Support getting resource pool stats, Christopher Baines, 2023/07/19
- 03/09: Expose resource pool stats, Christopher Baines, 2023/07/19
- 05/09: Reduce the number of threads used by fibers, Christopher Baines, 2023/07/19
- 07/09: Make fetching metrics work even when having database problems, Christopher Baines, 2023/07/19
- 01/09: Stop using a pool of threads for database operations,
Christopher Baines <=
- 04/09: Set thread names, Christopher Baines, 2023/07/19
- 08/09: Tweak loading package derivations, Christopher Baines, 2023/07/19
- 09/09: Tweak which duplicate packages to select, Christopher Baines, 2023/07/19