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

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.
This commit is contained in:
Christopher Baines 2023-07-09 16:52:35 +01:00
parent 672ee6216e
commit 7251c7d653
15 changed files with 1292 additions and 1310 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
.dir-locals.el
View File

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

86
guix-data-service/data-deletion.scm
View File

@ -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* ((connection-pool
(make-resource-pool
(lambda ()
(open-postgresql-connection "data-deletion" #f))
8)))
(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))))))))))))
(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)))))))))))

1
guix-data-service/database.scm
View File

@ -28,6 +28,7 @@
run-sqitch
with-postgresql-connection
open-postgresql-connection
with-postgresql-connection-per-thread
with-thread-postgresql-connection

346
guix-data-service/utils.scm
View File

@ -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))
(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))
(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))))))
(((? 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))
(define &thread-pool-request-timeout
(make-exception-type '&thread-pool-request-timeout
(define resource-pool-default-timeout
(make-parameter #f))
(define &resource-pool-timeout
(make-exception-type '&recource-pool-timeout
&error
'()))
(define make-thread-pool-request-timeout-error
(record-constructor &thread-pool-request-timeout))
(define make-resource-pool-timeout-error
(record-constructor &resource-pool-timeout))
(define thread-pool-request-timeout-error?
(record-predicate &thread-pool-request-timeout))
(define resource-pool-timeout-error?
(record-predicate &resource-pool-timeout))
(define thread-pool-channel
(make-parameter #f))
(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 thread-pool-request-timeout
(make-parameter #f))
(define timeout-or-default
(if (eq? timeout 'default)
(resource-pool-default-timeout)
timeout))
(define (defer-to-thread-pool-channel thunk)
(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))))))

130
guix-data-service/web/build-server/controller.scm
View File

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

60
guix-data-service/web/build/controller.scm
View File

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

512
guix-data-service/web/compare/controller.scm
View File

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

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

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

51
guix-data-service/web/jobs/controller.scm
View File

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

51
guix-data-service/web/nar/controller.scm
View File

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

14
guix-data-service/web/package/controller.scm
View File

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

215
guix-data-service/web/repository/controller.scm
View File

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

694
guix-data-service/web/revision/controller.scm
View File

File diff suppressed because it is too large Load Diff

65
guix-data-service/web/server.scm
View File

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

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

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