cbaines/guix-data-service
1
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Stop using a pool of threads for database operations

Browse source 
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
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 'with-time-logging 'scheme-indent-function 1)
(eval put 'make-parameter '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 '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 (texinfo-mode
(indent-tabs-mode) (indent-tabs-mode)
(fill-column . 72))) (fill-column . 72)))

20
guix-data-service/data-deletion.scm
View file

@ -538,7 +538,7 @@ DELETE FROM derivations WHERE id = $1"
1))) 1)))
(define (delete-batch conn) (define (delete-batch conn connection-pool)
(let* ((derivations (let* ((derivations
(with-time-logging "fetching batch of derivations" (with-time-logging "fetching batch of derivations"
(map car (map car
@ -580,7 +580,7 @@ WHERE NOT EXISTS (
derivation-id))) derivation-id)))
(let ((val (let ((val
(with-thread-postgresql-connection (call-with-resource-from-pool connection-pool
(lambda (conn) (lambda (conn)
(catch 'psql-query-error (catch 'psql-query-error
(lambda () (lambda ()
@ -613,19 +613,23 @@ SET CONSTRAINTS derivations_by_output_details_set_derivation_id_fkey DEFERRED")
deleted-count) deleted-count)
deleted-count))) deleted-count)))
(with-postgresql-connection-per-thread
"data-deletion-thread"
(lambda ()
(run-fibers (run-fibers
(lambda () (lambda ()
(with-thread-postgresql-connection (let* ((connection-pool
(make-resource-pool
(lambda ()
(open-postgresql-connection "data-deletion" #f))
8)))
(with-postgresql-connection
"data-deletion"
(lambda (conn) (lambda (conn)
(obtain-advisory-transaction-lock (obtain-advisory-transaction-lock
conn conn
'delete-unreferenced-derivations) 'delete-unreferenced-derivations)
(let loop ((total-deleted 0)) (let loop ((total-deleted 0))
(let ((batch-deleted-count (delete-batch conn))) (let ((batch-deleted-count (delete-batch conn connection-pool)))
(if (eq? 0 batch-deleted-count) (if (eq? 0 batch-deleted-count)
(begin (begin
(with-time-logging (with-time-logging
@ -635,4 +639,4 @@ SET CONSTRAINTS derivations_by_output_details_set_derivation_id_fkey DEFERRED")
(current-output-port) (current-output-port)
"Finished deleting derivations, deleted ~A in total\n" "Finished deleting derivations, deleted ~A in total\n"
total-deleted)) total-deleted))
(loop (+ total-deleted batch-deleted-count)))))))))))) (loop (+ total-deleted batch-deleted-count)))))))))))

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

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

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

@ -31,10 +31,12 @@
with-time-logging with-time-logging
prevent-inlining-for-tests prevent-inlining-for-tests
thread-pool-channel resource-pool-default-timeout
thread-pool-request-timeout make-resource-pool
make-thread-pool-channel call-with-resource-from-pool
parallel-via-thread-pool-channel with-resource-from-pool
parallel-via-fibers
par-map& par-map&
letpar& letpar&
@ -44,7 +46,10 @@
delete-duplicates/sort! delete-duplicates/sort!
get-gc-metrics-updater)) get-gc-metrics-updater
call-with-sigint
run-server/patched))
(define (call-with-time-logging action thunk) (define (call-with-time-logging action thunk)
(simple-format #t "debug: Starting ~A\n" action) (simple-format #t "debug: Starting ~A\n" action)
@ -63,113 +68,206 @@
(define-syntax-rule (prevent-inlining-for-tests var) (define-syntax-rule (prevent-inlining-for-tests var)
(set! var var)) (set! var var))
(define* (make-thread-pool-channel threads (define* (make-resource-pool initializer max-size
#:key #:key (min-size max-size)
idle-thunk (idle-duration #f)
idle-seconds) (delay-logger (const #f))
(define (delay-logger seconds-delayed) (duration-logger (const #f))
(when (> seconds-delayed 1) destructor
(format lifetime
(current-error-port) (name "unnamed"))
"warning: thread pool delayed by ~1,2f seconds~%" (define (initializer/safe)
seconds-delayed)))
(let ((channel (make-channel)))
(for-each
(lambda _
(call-with-new-thread
(lambda ()
(let loop ()
(match (if idle-seconds
(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 (with-exception-handler
(lambda (exn) (lambda (exn)
(simple-format (simple-format
(current-error-port) (current-error-port)
"worker thread: exception: ~A\n" "exception running ~A resource pool initializer: ~A:\n ~A\n"
name
initializer
exn) exn)
(backtrace) #f)
(raise-exception exn))
(lambda () (lambda ()
(call-with-values (with-throw-handler #t
proc initializer
(lambda vals (lambda args
vals))))) (backtrace))))
#:unwind? #t))) #:unwind? #t))
(loop))
(_ #f)))))) (let ((channel (make-channel)))
(iota threads)) (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
(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))))))
channel)) channel))
(define &thread-pool-request-timeout (define resource-pool-default-timeout
(make-exception-type '&thread-pool-request-timeout (make-parameter #f))
(define &resource-pool-timeout
(make-exception-type '&recource-pool-timeout
&error &error
'())) '()))
(define make-thread-pool-request-timeout-error (define make-resource-pool-timeout-error
(record-constructor &thread-pool-request-timeout)) (record-constructor &resource-pool-timeout))
(define thread-pool-request-timeout-error? (define resource-pool-timeout-error?
(record-predicate &thread-pool-request-timeout)) (record-predicate &resource-pool-timeout))
(define thread-pool-channel (define* (call-with-resource-from-pool pool proc #:key (timeout 'default))
(make-parameter #f)) "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 (define timeout-or-default
(make-parameter #f)) (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))) (let ((reply (make-channel)))
(spawn-fiber (spawn-fiber
(lambda () (lambda ()
(let ((val (with-exception-handler
(perform-operation (lambda (exn)
(let ((put (put-message reply (cons 'exception exn)))
(wrap-operation (lambda ()
(put-operation (thread-pool-channel) (call-with-values thunk
(list reply (lambda vals
(get-internal-real-time) (put-message reply vals))))
thunk)) #:unwind? #t))
(const 'success)))) #:parallel? #t)
(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)))))
reply)) reply))
(define (fetch-result-of-defered-thunks . reply-channels) (define (fetch-result-of-defered-thunks . reply-channels)
@ -177,21 +275,18 @@
reply-channels))) reply-channels)))
(map (map
(match-lambda (match-lambda
('request-timeout (('exception . exn)
(raise-exception
(make-thread-pool-request-timeout-error)))
(('worker-thread-error . exn)
(raise-exception exn)) (raise-exception exn))
(result (result
(apply values result))) (apply values result)))
responses))) responses)))
(define-syntax parallel-via-thread-pool-channel (define-syntax parallel-via-fibers
(lambda (x) (lambda (x)
(syntax-case x () (syntax-case x ()
((_ e0 ...) ((_ e0 ...)
(with-syntax (((tmp0 ...) (generate-temporaries (syntax (e0 ...))))) (with-syntax (((tmp0 ...) (generate-temporaries (syntax (e0 ...)))))
#'(let ((tmp0 (defer-to-thread-pool-channel #'(let ((tmp0 (defer-to-parallel-fiber
(lambda () (lambda ()
e0))) e0)))
...) ...)
@ -199,7 +294,7 @@
(define-syntax-rule (letpar& ((v e) ...) b0 b1 ...) (define-syntax-rule (letpar& ((v e) ...) b0 b1 ...)
(call-with-values (call-with-values
(lambda () (parallel-via-thread-pool-channel e ...)) (lambda () (parallel-via-fibers e ...))
(lambda (v ...) (lambda (v ...)
b0 b1 ...))) b0 b1 ...)))
@ -209,7 +304,7 @@
(match lists (match lists
(((heads tails ...) ...) (((heads tails ...) ...)
(let ((tail (loop tails)) (let ((tail (loop tails))
(head (defer-to-thread-pool-channel (head (defer-to-parallel-fiber
(lambda () (lambda ()
(apply proc heads))))) (apply proc heads)))))
(cons (fetch-result-of-defered-thunks head) tail))) (cons (fetch-result-of-defered-thunks head) tail)))
@ -311,3 +406,50 @@
(metric-set metric value)))) (metric-set metric value))))
metrics)))) 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))))))

54
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 substitutes)
#:use-module (guix-data-service web render) #:use-module (guix-data-service web render)
#:use-module (guix-data-service web query-parameters) #: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 jobs load-new-guix-revision)
#:use-module (guix-data-service model utils) #:use-module (guix-data-service model utils)
#:use-module (guix-data-service model build) #:use-module (guix-data-service model build)
@ -60,9 +61,7 @@
(build-server-build-id (build-server-build-id
(assq-ref query-parameters 'build_server_build_id)) (assq-ref query-parameters 'build_server_build_id))
(build (build
(parallel-via-thread-pool-channel (with-resource-from-pool (connection-pool) conn
(with-thread-postgresql-connection
(lambda (conn)
(if build-server-build-id (if build-server-build-id
(select-build-by-build-server-and-build-server-build-id (select-build-by-build-server-and-build-server-build-id
conn conn
@ -71,7 +70,7 @@
(select-build-by-build-server-and-derivation-file-name (select-build-by-build-server-and-derivation-file-name
conn conn
build-server-id build-server-id
derivation-file-name))))))) derivation-file-name)))))
(if build (if build
(render-html (render-html
#:sxml #:sxml
@ -88,13 +87,11 @@
; guix-build-coordinator ; guix-build-coordinator
; doesn't mark builds as ; doesn't mark builds as
; failed-dependency ; failed-dependency
(parallel-via-thread-pool-channel (with-resource-from-pool (connection-pool) conn
(with-thread-postgresql-connection
(lambda (conn)
(select-required-builds-that-failed (select-required-builds-that-failed
conn conn
build-server-id build-server-id
derivation-file-name)))) derivation-file-name))
#f))))) #f)))))
(render-html (render-html
#:sxml (general-not-found #:sxml (general-not-found
@ -121,10 +118,9 @@
(define build-server-id (define build-server-id
(string->number build-server-id-string)) (string->number build-server-id-string))
(define (call-via-thread-pool-channel handler) (define (spawn-fiber-for-handler handler)
(spawn-fiber (spawn-fiber
(lambda () (lambda ()
(parallel-via-thread-pool-channel
(with-postgresql-connection (with-postgresql-connection
"build-event-handler-conn" "build-event-handler-conn"
(lambda (conn) (lambda (conn)
@ -141,7 +137,7 @@
(lambda _ (lambda _
(display (backtrace) (current-error-port)) (display (backtrace) (current-error-port))
(display "\n" (current-error-port))))) (display "\n" (current-error-port)))))
#:unwind? #t))))))) #:unwind? #t))))))
(define (with-build-ids-for-status data (define (with-build-ids-for-status data
build-ids build-ids
@ -217,24 +213,24 @@
#f)))) #f))))
items)) items))
(letpar& ((build-ids (let ((build-ids
(with-thread-postgresql-connection (with-resource-from-pool (reserved-connection-pool) conn
(lambda (conn)
(with-postgresql-transaction (with-postgresql-transaction
conn conn
(lambda (conn) (lambda (conn)
(handle-derivation-events (handle-derivation-events
conn conn
filtered-items))))))) filtered-items))))))
(with-build-ids-for-status (with-build-ids-for-status
items items
build-ids build-ids
'("succeeded") '("succeeded")
(lambda (ids) (lambda (ids)
(call-via-thread-pool-channel (spawn-fiber-for-handler
(lambda (conn) (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 (request-query-of-build-server-substitutes build-server-id
ids))) ids)))
@ -244,7 +240,7 @@
build-ids build-ids
'("scheduled") '("scheduled")
(lambda (ids) (lambda (ids)
(call-via-thread-pool-channel (spawn-fiber-for-handler
(lambda (conn) (lambda (conn)
(handle-blocked-builds-entries-for-scheduled-builds conn ids))))) (handle-blocked-builds-entries-for-scheduled-builds conn ids)))))
@ -253,7 +249,7 @@
build-ids build-ids
'("failed" "failed-dependency" "canceled") '("failed" "failed-dependency" "canceled")
(lambda (ids) (lambda (ids)
(call-via-thread-pool-channel (spawn-fiber-for-handler
(lambda (conn) (lambda (conn)
(handle-populating-blocked-builds-for-build-failures conn ids))))))) (handle-populating-blocked-builds-for-build-failures conn ids)))))))
@ -263,12 +259,10 @@
#:code 400) #:code 400)
(let ((provided-token (assq-ref parsed-query-parameters 'token)) (let ((provided-token (assq-ref parsed-query-parameters 'token))
(permitted-tokens (permitted-tokens
(parallel-via-thread-pool-channel (with-resource-from-pool (reserved-connection-pool) conn
(with-thread-postgresql-connection
(lambda (conn)
(compute-tokens-for-build-server conn (compute-tokens-for-build-server conn
secret-key-base secret-key-base
build-server-id)))))) build-server-id))))
(if (member provided-token (if (member provided-token
(map cdr permitted-tokens) (map cdr permitted-tokens)
string=?) string=?)
@ -317,10 +311,8 @@
(define (handle-signing-key-request id) (define (handle-signing-key-request id)
(render-html (render-html
#:sxml (view-signing-key #:sxml (view-signing-key
(parallel-via-thread-pool-channel (with-resource-from-pool (connection-pool) conn
(with-thread-postgresql-connection (select-signing-key conn id)))))
(lambda (conn)
(select-signing-key conn id)))))))
(define (build-server-controller request (define (build-server-controller request
method-and-path-components method-and-path-components
@ -329,14 +321,14 @@
secret-key-base) secret-key-base)
(match method-and-path-components (match method-and-path-components
(('GET "build-servers") (('GET "build-servers")
(letpar& ((build-servers (let ((build-servers
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
select-build-servers))) select-build-servers)))
(render-build-servers mime-types (render-build-servers mime-types
build-servers))) build-servers)))
(('GET "build-server" build-server-id) (('GET "build-server" build-server-id)
(letpar& ((build-server (let ((build-server
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn) (lambda (conn)
(select-build-server conn (string->number (select-build-server conn (string->number
build-server-id)))))) build-server-id))))))

24
guix-data-service/web/build/controller.scm
View file

@ -21,6 +21,7 @@
#:use-module (guix-data-service utils) #:use-module (guix-data-service utils)
#:use-module (guix-data-service database) #:use-module (guix-data-service database)
#:use-module (guix-data-service web render) #: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 query-parameters)
#:use-module (guix-data-service model build) #:use-module (guix-data-service model build)
#:use-module (guix-data-service model system) #:use-module (guix-data-service model system)
@ -41,7 +42,7 @@
(define parse-build-server (define parse-build-server
(lambda (v) (lambda (v)
(letpar& ((build-servers (letpar& ((build-servers
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
select-build-servers))) select-build-servers)))
(or (any (match-lambda (or (any (match-lambda
((id url lookup-all-derivations? lookup-builds?) ((id url lookup-all-derivations? lookup-builds?)
@ -88,25 +89,22 @@
(let ((system (assq-ref parsed-query-parameters 'system)) (let ((system (assq-ref parsed-query-parameters 'system))
(target (assq-ref parsed-query-parameters 'target))) (target (assq-ref parsed-query-parameters 'target)))
(letpar& ((build-server-options (letpar& ((build-server-options
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(map (match-lambda (map (match-lambda
((id url lookup-all-derivations ((id url lookup-all-derivations
lookup-builds) lookup-builds)
(cons url id))) (cons url id)))
(select-build-servers conn))))) (select-build-servers conn))))
(build-stats (build-stats
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(select-build-stats (select-build-stats
conn conn
(assq-ref parsed-query-parameters (assq-ref parsed-query-parameters
'build_server) 'build_server)
#:system system #:system system
#:target target)))) #:target target)))
(builds-with-context (builds-with-context
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(select-builds-with-context (select-builds-with-context
conn conn
(assq-ref parsed-query-parameters (assq-ref parsed-query-parameters
@ -116,11 +114,13 @@
#:system system #:system system
#:target target #:target target
#:limit (assq-ref parsed-query-parameters #:limit (assq-ref parsed-query-parameters
'limit_results))))) 'limit_results))))
(systems (systems
(with-thread-postgresql-connection list-systems)) (call-with-resource-from-pool (connection-pool)
list-systems))
(targets (targets
(with-thread-postgresql-connection valid-targets))) (call-with-resource-from-pool (connection-pool)
valid-targets)))
(render-html (render-html
#:sxml (view-builds parsed-query-parameters #:sxml (view-builds parsed-query-parameters

258
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 util)
#:use-module (guix-data-service web render) #:use-module (guix-data-service web render)
#:use-module (guix-data-service web query-parameters) #: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 model utils)
#:use-module (guix-data-service comparison) #:use-module (guix-data-service comparison)
#:use-module (guix-data-service jobs load-new-guix-revision) #:use-module (guix-data-service jobs load-new-guix-revision)
@ -55,9 +56,7 @@
s) s)
(define (parse-commit s) (define (parse-commit s)
(parallel-via-thread-pool-channel (with-resource-from-pool (connection-pool) conn
(with-thread-postgresql-connection
(lambda (conn)
(let* ((job-details (let* ((job-details
(select-job-for-commit conn s)) (select-job-for-commit conn s))
(job-state (job-state
@ -84,13 +83,11 @@
(make-invalid-query-parameter (make-invalid-query-parameter
s "unknown job state"))) s "unknown job state")))
(make-invalid-query-parameter (make-invalid-query-parameter
s "unknown commit"))))))) s "unknown commit")))))
(define (parse-derivation file-name) (define (parse-derivation file-name)
(if (parallel-via-thread-pool-channel (if (with-resource-from-pool (connection-pool) conn
(with-thread-postgresql-connection (select-derivation-by-file-name conn file-name))
(lambda (conn)
(select-derivation-by-file-name conn file-name))))
file-name file-name
(make-invalid-query-parameter (make-invalid-query-parameter
file-name "unknown derivation"))) file-name "unknown derivation")))
@ -235,18 +232,16 @@
(letpar& ((base-job (letpar& ((base-job
(match (assq-ref query-parameters 'base_commit) (match (assq-ref query-parameters 'base_commit)
(($ <invalid-query-parameter> value) (($ <invalid-query-parameter> value)
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(and (string? value) (and (string? value)
(select-job-for-commit conn value))))) (select-job-for-commit conn value))))
(_ #f))) (_ #f)))
(target-job (target-job
(match (assq-ref query-parameters 'target_commit) (match (assq-ref query-parameters 'target_commit)
(($ <invalid-query-parameter> value) (($ <invalid-query-parameter> value)
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(and (string? value) (and (string? value)
(select-job-for-commit conn value))))) (select-job-for-commit conn value))))
(_ #f)))) (_ #f))))
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
'(application/json text/html) '(application/json text/html)
@ -281,28 +276,24 @@
#f #f
#f))))) #f)))))
(letpar& ((base-revision-id (letpar& ((base-revision-id
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(commit->revision-id (commit->revision-id
conn conn
(assq-ref query-parameters 'base_commit))))) (assq-ref query-parameters 'base_commit))))
(target-revision-id (target-revision-id
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(commit->revision-id (commit->revision-id
conn conn
(assq-ref query-parameters 'target_commit))))) (assq-ref query-parameters 'target_commit))))
(locale (locale
(assq-ref query-parameters 'locale))) (assq-ref query-parameters 'locale)))
(let-values (let-values
(((base-packages-vhash target-packages-vhash) (((base-packages-vhash target-packages-vhash)
(package-data->package-data-vhashes (package-data->package-data-vhashes
(parallel-via-thread-pool-channel (with-resource-from-pool (connection-pool) conn
(with-thread-postgresql-connection
(lambda (conn)
(package-differences-data conn (package-differences-data conn
base-revision-id base-revision-id
target-revision-id))))))) target-revision-id)))))
(let ((new-packages (let ((new-packages
(package-data-vhashes->new-packages base-packages-vhash (package-data-vhashes->new-packages base-packages-vhash
target-packages-vhash)) target-packages-vhash))
@ -313,20 +304,18 @@
(package-data-version-changes base-packages-vhash (package-data-version-changes base-packages-vhash
target-packages-vhash))) target-packages-vhash)))
(letpar& ((lint-warnings-data (letpar& ((lint-warnings-data
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(group-list-by-first-n-fields (group-list-by-first-n-fields
2 2
(lint-warning-differences-data conn (lint-warning-differences-data conn
base-revision-id base-revision-id
target-revision-id target-revision-id
locale))))) locale))))
(channel-news-data (channel-news-data
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(channel-news-differences-data conn (channel-news-differences-data conn
base-revision-id base-revision-id
target-revision-id))))) target-revision-id))))
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
'(application/json text/html) '(application/json text/html)
mime-types) mime-types)
@ -412,18 +401,16 @@
(match-lambda (match-lambda
((locale) ((locale)
locale)) locale))
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(lint-warning-message-locales-for-revision (lint-warning-message-locales-for-revision
conn conn
(assq-ref query-parameters 'target_commit)))))) (assq-ref query-parameters 'target_commit)))))
(cgit-url-bases (cgit-url-bases
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(guix-revisions-cgit-url-bases (guix-revisions-cgit-url-bases
conn conn
(list base-revision-id (list base-revision-id
target-revision-id)))))) target-revision-id)))))
(render-html (render-html
#:sxml (compare query-parameters #:sxml (compare query-parameters
'revision 'revision
@ -463,29 +450,26 @@
(target-datetime (assq-ref query-parameters 'target_datetime)) (target-datetime (assq-ref query-parameters 'target_datetime))
(locale (assq-ref query-parameters 'locale))) (locale (assq-ref query-parameters 'locale)))
(letpar& ((base-revision-details (letpar& ((base-revision-details
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(select-guix-revision-for-branch-and-datetime (select-guix-revision-for-branch-and-datetime
conn conn
base-branch base-branch
base-datetime)))) base-datetime)))
(target-revision-details (target-revision-details
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(select-guix-revision-for-branch-and-datetime (select-guix-revision-for-branch-and-datetime
conn conn
target-branch target-branch
target-datetime))))) target-datetime))))
(letpar& ((lint-warnings-locale-options (let ((lint-warnings-locale-options
(map (map
(match-lambda (match-lambda
((locale) ((locale)
locale)) locale))
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(lint-warning-message-locales-for-revision (lint-warning-message-locales-for-revision
conn conn
(second base-revision-details))))))) (second base-revision-details))))))
(let ((base-revision-id (let ((base-revision-id
(first base-revision-details)) (first base-revision-details))
(target-revision-id (target-revision-id
@ -493,12 +477,10 @@
(let-values (let-values
(((base-packages-vhash target-packages-vhash) (((base-packages-vhash target-packages-vhash)
(package-data->package-data-vhashes (package-data->package-data-vhashes
(parallel-via-thread-pool-channel (with-resource-from-pool (connection-pool) conn
(with-thread-postgresql-connection
(lambda (conn)
(package-differences-data conn (package-differences-data conn
base-revision-id base-revision-id
target-revision-id))))))) target-revision-id)))))
(let* ((new-packages (let* ((new-packages
(package-data-vhashes->new-packages base-packages-vhash (package-data-vhashes->new-packages base-packages-vhash
target-packages-vhash)) target-packages-vhash))
@ -509,12 +491,10 @@
(package-data-version-changes base-packages-vhash (package-data-version-changes base-packages-vhash
target-packages-vhash)) target-packages-vhash))
(channel-news-data (channel-news-data
(parallel-via-thread-pool-channel (with-resource-from-pool (connection-pool) conn
(with-thread-postgresql-connection
(lambda (conn)
(channel-news-differences-data conn (channel-news-differences-data conn
base-revision-id base-revision-id
target-revision-id)))))) target-revision-id))))
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
'(application/json text/html) '(application/json text/html)
mime-types) mime-types)
@ -567,30 +547,27 @@
#:extra-headers http-headers-for-unchanging-content)) #:extra-headers http-headers-for-unchanging-content))
(else (else
(render-html (render-html
#:sxml (compare `(,@query-parameters #:sxml (compare
`(,@query-parameters
(base_commit . ,(second base-revision-details)) (base_commit . ,(second base-revision-details))
(target_commit . ,(second target-revision-details))) (target_commit . ,(second target-revision-details)))
'datetime 'datetime
(parallel-via-thread-pool-channel (with-resource-from-pool (connection-pool) conn
(with-thread-postgresql-connection
(lambda (conn)
(guix-revisions-cgit-url-bases (guix-revisions-cgit-url-bases
conn conn
(list base-revision-id (list base-revision-id
target-revision-id))))) target-revision-id)))
new-packages new-packages
removed-packages removed-packages
version-changes version-changes
(parallel-via-thread-pool-channel
(group-list-by-first-n-fields (group-list-by-first-n-fields
2 2
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(lint-warning-differences-data (lint-warning-differences-data
conn conn
base-revision-id base-revision-id
target-revision-id target-revision-id
locale))))) locale)))
lint-warnings-locale-options lint-warnings-locale-options
channel-news-data) channel-news-data)
#:extra-headers http-headers-for-unchanging-content))))))))))) #:extra-headers http-headers-for-unchanging-content)))))))))))
@ -612,12 +589,11 @@
(let ((base-derivation (assq-ref query-parameters 'base_derivation)) (let ((base-derivation (assq-ref query-parameters 'base_derivation))
(target-derivation (assq-ref query-parameters 'target_derivation))) (target-derivation (assq-ref query-parameters 'target_derivation)))
(letpar& ((data (let ((data
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(derivation-differences-data conn (derivation-differences-data conn
base-derivation base-derivation
target-derivation))))) target-derivation))))
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
'(application/json text/html) '(application/json text/html)
mime-types) mime-types)
@ -655,9 +631,8 @@
((? string? value) value) ((? string? value) value)
(_ #f)) (_ #f))
(lambda (commit) (lambda (commit)
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn) (select-job-for-commit conn commit)))))
(select-job-for-commit conn commit))))))
(target-job (target-job
(and=> (match (assq-ref query-parameters 'target_commit) (and=> (match (assq-ref query-parameters 'target_commit)
(($ <invalid-query-parameter> value) (($ <invalid-query-parameter> value)
@ -665,9 +640,8 @@
((? string? value) value) ((? string? value) value)
(_ #f)) (_ #f))
(lambda (commit) (lambda (commit)
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn) (select-job-for-commit conn commit))))))
(select-job-for-commit conn commit)))))))
(render-json (render-json
`((error . "invalid query") `((error . "invalid query")
(query_parameters (query_parameters
@ -690,13 +664,13 @@
(target_job . ,target-job))))) (target_job . ,target-job)))))
(else (else
(letpar& ((systems (letpar& ((systems
(with-thread-postgresql-connection (call-with-resource-from-pool (connection-pool)
list-systems)) list-systems))
(targets (targets
(with-thread-postgresql-connection (call-with-resource-from-pool (connection-pool)
valid-targets)) valid-targets))
(build-server-urls (build-server-urls
(with-thread-postgresql-connection (call-with-resource-from-pool (connection-pool)
select-build-server-urls-by-id))) select-build-server-urls-by-id)))
(render-html (render-html
#:sxml (compare/package-derivations #:sxml (compare/package-derivations
@ -718,8 +692,7 @@
(after-name (assq-ref query-parameters 'after_name)) (after-name (assq-ref query-parameters 'after_name))
(limit-results (assq-ref query-parameters 'limit_results))) (limit-results (assq-ref query-parameters 'limit_results)))
(letpar& ((data (letpar& ((data
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(package-derivation-differences-data (package-derivation-differences-data
conn conn
(commit->revision-id conn base-commit) (commit->revision-id conn base-commit)
@ -728,9 +701,9 @@
#:targets targets #:targets targets
#:build-change build-change #:build-change build-change
#:after-name after-name #:after-name after-name
#:limit-results limit-results)))) #:limit-results limit-results)))
(build-server-urls (build-server-urls
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
select-build-server-urls-by-id))) select-build-server-urls-by-id)))
(let ((names-and-versions (let ((names-and-versions
(package-derivation-data->names-and-versions data))) (package-derivation-data->names-and-versions data)))
@ -755,10 +728,10 @@
. ,derivation-changes)))) . ,derivation-changes))))
(else (else
(letpar& ((systems (letpar& ((systems
(with-thread-postgresql-connection (call-with-resource-from-pool (connection-pool)
list-systems)) list-systems))
(targets (targets
(with-thread-postgresql-connection (call-with-resource-from-pool (connection-pool)
valid-targets))) valid-targets)))
(render-html (render-html
#:sxml (compare/package-derivations #:sxml (compare/package-derivations
@ -784,11 +757,11 @@
#:sxml (compare/package-derivations #:sxml (compare/package-derivations
query-parameters query-parameters
'datetime 'datetime
(parallel-via-thread-pool-channel (call-with-resource-from-pool (connection-pool)
(with-thread-postgresql-connection list-systems)) list-systems)
(valid-targets->options (valid-targets->options
(parallel-via-thread-pool-channel (call-with-resource-from-pool (connection-pool)
(with-thread-postgresql-connection valid-targets))) valid-targets))
build-status-strings build-status-strings
'() '()
'() '()
@ -807,21 +780,18 @@
(limit-results (assq-ref query-parameters 'limit_results))) (limit-results (assq-ref query-parameters 'limit_results)))
(letpar& (letpar&
((base-revision-details ((base-revision-details
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(select-guix-revision-for-branch-and-datetime conn (select-guix-revision-for-branch-and-datetime conn
base-branch base-branch
base-datetime)))) base-datetime)))
(target-revision-details (target-revision-details
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(select-guix-revision-for-branch-and-datetime conn (select-guix-revision-for-branch-and-datetime conn
target-branch target-branch
target-datetime))))) target-datetime))))
(letpar& (letpar&
((data ((data
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(package-derivation-differences-data (package-derivation-differences-data
conn conn
(first base-revision-details) (first base-revision-details)
@ -830,7 +800,7 @@
#:targets targets #:targets targets
#:build-change build-change #:build-change build-change
#:after-name after-name #:after-name after-name
#:limit-results limit-results))))) #:limit-results limit-results))))
(let ((names-and-versions (let ((names-and-versions
(package-derivation-data->names-and-versions data))) (package-derivation-data->names-and-versions data)))
(let-values (let-values
@ -859,15 +829,17 @@
#:sxml (compare/package-derivations #:sxml (compare/package-derivations
query-parameters query-parameters
'datetime 'datetime
(parallel-via-thread-pool-channel (call-with-resource-from-pool
(with-thread-postgresql-connection list-systems)) (connection-pool)
list-systems)
(valid-targets->options (valid-targets->options
(parallel-via-thread-pool-channel (call-with-resource-from-pool
(with-thread-postgresql-connection valid-targets))) (connection-pool)
valid-targets))
build-status-strings build-status-strings
(parallel-via-thread-pool-channel (call-with-resource-from-pool
(with-thread-postgresql-connection (connection-pool)
select-build-server-urls-by-id)) select-build-server-urls-by-id)
derivation-changes derivation-changes
base-revision-details base-revision-details
target-revision-details)))))))))))) target-revision-details))))))))))))
@ -894,16 +866,14 @@
(letpar& ((base-job (letpar& ((base-job
(match (assq-ref query-parameters 'base_commit) (match (assq-ref query-parameters 'base_commit)
(($ <invalid-query-parameter> value) (($ <invalid-query-parameter> value)
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn) (select-job-for-commit conn value)))
(select-job-for-commit conn value))))
(_ #f))) (_ #f)))
(target-job (target-job
(match (assq-ref query-parameters 'target_commit) (match (assq-ref query-parameters 'target_commit)
(($ <invalid-query-parameter> value) (($ <invalid-query-parameter> value)
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn) (select-job-for-commit conn value)))
(select-job-for-commit conn value))))
(_ #f)))) (_ #f))))
(render-html (render-html
#:sxml (compare-invalid-parameters #:sxml (compare-invalid-parameters
@ -914,26 +884,22 @@
(let ((base-commit (assq-ref query-parameters 'base_commit)) (let ((base-commit (assq-ref query-parameters 'base_commit))
(target-commit (assq-ref query-parameters 'target_commit))) (target-commit (assq-ref query-parameters 'target_commit)))
(letpar& ((base-revision-id (letpar& ((base-revision-id
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(commit->revision-id (commit->revision-id
conn conn
base-commit)))) base-commit)))
(target-revision-id (target-revision-id
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(commit->revision-id (commit->revision-id
conn conn
target-commit))))) target-commit))))
(let-values (let-values
(((base-packages-vhash target-packages-vhash) (((base-packages-vhash target-packages-vhash)
(package-data->package-data-vhashes (package-data->package-data-vhashes
(parallel-via-thread-pool-channel (with-resource-from-pool (connection-pool) conn
(with-thread-postgresql-connection
(lambda (conn)
(package-differences-data conn (package-differences-data conn
base-revision-id base-revision-id
target-revision-id))))))) target-revision-id)))))
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
'(application/json text/html) '(application/json text/html)
mime-types) mime-types)
@ -967,10 +933,10 @@
'((error . "invalid query")))) '((error . "invalid query"))))
(else (else
(letpar& ((systems (letpar& ((systems
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
list-systems)) list-systems))
(build-server-urls (build-server-urls
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
select-build-server-urls-by-id))) select-build-server-urls-by-id)))
(render-html (render-html
#:sxml (compare/system-test-derivations #:sxml (compare/system-test-derivations
@ -986,26 +952,23 @@
(target-commit (assq-ref query-parameters 'target_commit)) (target-commit (assq-ref query-parameters 'target_commit))
(system (assq-ref query-parameters 'system))) (system (assq-ref query-parameters 'system)))
(letpar& ((data (letpar& ((data
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(system-test-derivations-differences-data (system-test-derivations-differences-data
conn conn
(commit->revision-id conn base-commit) (commit->revision-id conn base-commit)
(commit->revision-id conn target-commit) (commit->revision-id conn target-commit)
system)))) system)))
(build-server-urls (build-server-urls
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
select-build-server-urls-by-id)) select-build-server-urls-by-id))
(base-git-repositories (base-git-repositories
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn) (git-repositories-containing-commit conn base-commit)))
(git-repositories-containing-commit conn base-commit))))
(target-git-repositories (target-git-repositories
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn) (git-repositories-containing-commit conn target-commit)))
(git-repositories-containing-commit conn target-commit))))
(systems (systems
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
list-systems))) list-systems)))
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
'(application/json text/html) '(application/json text/html)
@ -1040,10 +1003,10 @@
'((error . "invalid query")))) '((error . "invalid query"))))
(else (else
(letpar& ((systems (letpar& ((systems
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
list-systems)) list-systems))
(build-server-urls (build-server-urls
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
select-build-server-urls-by-id))) select-build-server-urls-by-id)))
(render-html (render-html
#:sxml (compare/system-test-derivations #:sxml (compare/system-test-derivations
@ -1062,42 +1025,37 @@
(system (assq-ref query-parameters 'system))) (system (assq-ref query-parameters 'system)))
(letpar& (letpar&
((base-revision-details ((base-revision-details
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(select-guix-revision-for-branch-and-datetime conn (select-guix-revision-for-branch-and-datetime conn
base-branch base-branch
base-datetime)))) base-datetime)))
(target-revision-details (target-revision-details
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(select-guix-revision-for-branch-and-datetime conn (select-guix-revision-for-branch-and-datetime conn
target-branch target-branch
target-datetime))))) target-datetime))))
(letpar& ((data (letpar& ((data
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(system-test-derivations-differences-data (system-test-derivations-differences-data
conn conn
(first base-revision-details) (first base-revision-details)
(first target-revision-details) (first target-revision-details)
system)))) system)))
(build-server-urls (build-server-urls
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
select-build-server-urls-by-id)) select-build-server-urls-by-id))
(base-git-repositories (base-git-repositories
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(git-repositories-containing-commit (git-repositories-containing-commit
conn conn
(second base-revision-details))))) (second base-revision-details))))
(target-git-repositories (target-git-repositories
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(git-repositories-containing-commit (git-repositories-containing-commit
conn conn
(second target-revision-details))))) (second target-revision-details))))
(systems (systems
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
list-systems))) list-systems)))
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
'(application/json text/html) '(application/json text/html)

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

@ -75,9 +75,13 @@
make-render-metrics make-render-metrics
controller 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)) (make-parameter #f))
(define cache-control-default-max-age (define cache-control-default-max-age
@ -186,22 +190,28 @@
(lambda () (lambda ()
(letpar& ((metric-values (letpar& ((metric-values
(with-thread-postgresql-connection (call-with-resource-from-pool
(reserved-connection-pool)
fetch-high-level-table-size-metrics)) fetch-high-level-table-size-metrics))
(guix-revisions-count (guix-revisions-count
(with-thread-postgresql-connection (call-with-resource-from-pool
(reserved-connection-pool)
count-guix-revisions)) count-guix-revisions))
(pg-stat-user-tables-metrics (pg-stat-user-tables-metrics
(with-thread-postgresql-connection (call-with-resource-from-pool
(reserved-connection-pool)
fetch-pg-stat-user-tables-metrics)) fetch-pg-stat-user-tables-metrics))
(pg-stat-user-indexes-metrics (pg-stat-user-indexes-metrics
(with-thread-postgresql-connection (call-with-resource-from-pool
(reserved-connection-pool)
fetch-pg-stat-user-indexes-metrics)) fetch-pg-stat-user-indexes-metrics))
(pg-stats-metric-values (pg-stats-metric-values
(with-thread-postgresql-connection (call-with-resource-from-pool
(reserved-connection-pool)
fetch-pg-stats-metrics)) fetch-pg-stats-metrics))
(load-new-guix-revision-job-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))) select-load-new-guix-revision-job-metrics)))
(for-each (match-lambda (for-each (match-lambda
@ -301,29 +311,25 @@
(define (render-derivation derivation-file-name) (define (render-derivation derivation-file-name)
(letpar& ((derivation (letpar& ((derivation
(with-thread-postgresql-connection (with-resource-from-pool (reserved-connection-pool) conn
(lambda (conn) (select-derivation-by-file-name conn derivation-file-name))))
(select-derivation-by-file-name conn derivation-file-name)))))
(if derivation (if derivation
(letpar& ((derivation-inputs (letpar& ((derivation-inputs
(with-thread-postgresql-connection (with-resource-from-pool (reserved-connection-pool) conn
(lambda (conn)
(select-derivation-inputs-by-derivation-id (select-derivation-inputs-by-derivation-id
conn conn
(first derivation))))) (first derivation))))
(derivation-outputs (derivation-outputs
(with-thread-postgresql-connection (with-resource-from-pool (reserved-connection-pool) conn
(lambda (conn)
(select-derivation-outputs-by-derivation-id (select-derivation-outputs-by-derivation-id
conn conn
(first derivation))))) (first derivation))))
(builds (builds
(with-thread-postgresql-connection (with-resource-from-pool (reserved-connection-pool) conn
(lambda (conn)
(select-builds-with-context-by-derivation-file-name (select-builds-with-context-by-derivation-file-name
conn conn
(second derivation)))))) (second derivation)))))
(render-html (render-html
#:sxml (view-derivation derivation #:sxml (view-derivation derivation
derivation-inputs derivation-inputs
@ -339,30 +345,25 @@
(define (render-json-derivation derivation-file-name) (define (render-json-derivation derivation-file-name)
(let ((derivation (let ((derivation
(parallel-via-thread-pool-channel (with-resource-from-pool (reserved-connection-pool) conn
(with-thread-postgresql-connection
(lambda (conn)
(select-derivation-by-file-name conn (select-derivation-by-file-name conn
derivation-file-name)))))) derivation-file-name))))
(if derivation (if derivation
(letpar& ((derivation-inputs (letpar& ((derivation-inputs
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(select-derivation-inputs-by-derivation-id (select-derivation-inputs-by-derivation-id
conn conn
(first derivation))))) (first derivation))))
(derivation-outputs (derivation-outputs
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(select-derivation-outputs-by-derivation-id (select-derivation-outputs-by-derivation-id
conn conn
(first derivation))))) (first derivation))))
(derivation-sources (derivation-sources
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(select-derivation-sources-by-derivation-id (select-derivation-sources-by-derivation-id
conn conn
(first derivation)))))) (first derivation)))))
(render-json (render-json
`((inputs . ,(list->vector `((inputs . ,(list->vector
(map (map
@ -400,30 +401,25 @@
(define (render-formatted-derivation derivation-file-name) (define (render-formatted-derivation derivation-file-name)
(let ((derivation (let ((derivation
(parallel-via-thread-pool-channel (with-resource-from-pool (connection-pool) conn
(with-thread-postgresql-connection
(lambda (conn)
(select-derivation-by-file-name conn (select-derivation-by-file-name conn
derivation-file-name)))))) derivation-file-name))))
(if derivation (if derivation
(letpar& ((derivation-inputs (letpar& ((derivation-inputs
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(select-derivation-inputs-by-derivation-id (select-derivation-inputs-by-derivation-id
conn conn
(first derivation))))) (first derivation))))
(derivation-outputs (derivation-outputs
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(select-derivation-outputs-by-derivation-id (select-derivation-outputs-by-derivation-id
conn conn
(first derivation))))) (first derivation))))
(derivation-sources (derivation-sources
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(select-derivation-sources-by-derivation-id (select-derivation-sources-by-derivation-id
conn conn
(first derivation)))))) (first derivation)))))
(render-html (render-html
#:sxml (view-formatted-derivation derivation #:sxml (view-formatted-derivation derivation
derivation-inputs derivation-inputs
@ -439,12 +435,10 @@
(define (render-narinfos filename) (define (render-narinfos filename)
(let ((narinfos (let ((narinfos
(parallel-via-thread-pool-channel (with-resource-from-pool (connection-pool) conn
(with-thread-postgresql-connection
(lambda (conn)
(select-nars-for-output (select-nars-for-output
conn conn
(string-append "/gnu/store/" filename))))))) (string-append "/gnu/store/" filename)))))
(if (null? narinfos) (if (null? narinfos)
(render-html (render-html
#:sxml (general-not-found #:sxml (general-not-found
@ -457,15 +451,12 @@
(define (render-store-item filename) (define (render-store-item filename)
(letpar& ((derivation (letpar& ((derivation
(with-thread-postgresql-connection (with-resource-from-pool (reserved-connection-pool) conn
(lambda (conn) (select-derivation-by-output-filename conn filename))))
(select-derivation-by-output-filename conn filename)))))
(match derivation (match derivation
(() (()
(match (parallel-via-thread-pool-channel (match (with-resource-from-pool (reserved-connection-pool) conn
(with-thread-postgresql-connection (select-derivation-source-file-by-store-path conn filename))
(lambda (conn)
(select-derivation-source-file-by-store-path conn filename))))
(() (()
(render-html (render-html
#:sxml (general-not-found #:sxml (general-not-found
@ -476,24 +467,20 @@
(render-html (render-html
#:sxml (view-derivation-source-file #:sxml (view-derivation-source-file
filename filename
(parallel-via-thread-pool-channel (with-resource-from-pool (reserved-connection-pool) conn
(with-thread-postgresql-connection
(lambda (conn)
(select-derivation-source-file-nar-details-by-file-name (select-derivation-source-file-nar-details-by-file-name
conn conn
filename))))) filename)))
#:extra-headers http-headers-for-unchanging-content)))) #:extra-headers http-headers-for-unchanging-content))))
(derivations (derivations
(letpar& ((nars (letpar& ((nars
(with-thread-postgresql-connection (with-resource-from-pool (reserved-connection-pool) conn
(lambda (conn) (select-nars-for-output conn filename)))
(select-nars-for-output conn filename))))
(builds (builds
(with-thread-postgresql-connection (with-resource-from-pool (reserved-connection-pool) conn
(lambda (conn)
(select-builds-with-context-by-derivation-output (select-builds-with-context-by-derivation-output
conn conn
filename))))) filename))))
(render-html (render-html
#:sxml (view-store-item filename #:sxml (view-store-item filename
derivations derivations
@ -502,16 +489,12 @@
(define (render-json-store-item filename) (define (render-json-store-item filename)
(let ((derivation (let ((derivation
(parallel-via-thread-pool-channel (with-resource-from-pool (connection-pool) conn
(with-thread-postgresql-connection (select-derivation-by-output-filename conn filename))))
(lambda (conn)
(select-derivation-by-output-filename conn filename))))))
(match derivation (match derivation
(() (()
(match (parallel-via-thread-pool-channel (match (with-resource-from-pool (connection-pool) conn
(with-thread-postgresql-connection (select-derivation-source-file-by-store-path conn filename))
(lambda (conn)
(select-derivation-source-file-by-store-path conn filename))))
(() (()
(render-json '((error . "store item not found")))) (render-json '((error . "store item not found"))))
((id) ((id)
@ -522,17 +505,14 @@
(match-lambda (match-lambda
((key . value) ((key . value)
`((,key . ,value)))) `((,key . ,value))))
(parallel-via-thread-pool-channel (with-resource-from-pool (connection-pool) conn
(with-thread-postgresql-connection
(lambda (conn)
(select-derivation-source-file-nar-details-by-file-name (select-derivation-source-file-nar-details-by-file-name
conn conn
filename)))))))))))) filename))))))))))
(derivations (derivations
(letpar& ((nars (letpar& ((nars
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn) (select-nars-for-output conn filename))))
(select-nars-for-output conn filename)))))
(render-json (render-json
`((nars . ,(list->vector `((nars . ,(list->vector
(map (map
@ -653,33 +633,23 @@
(define path (define path
(uri-path (request-uri request))) (uri-path (request-uri request)))
(define* (delegate-to f #:key use-reserved-thread-pool?) (define* (delegate-to f)
(or (parameterize (or (f request
((thread-pool-channel
(if use-reserved-thread-pool?
(reserved-thread-pool-channel)
(thread-pool-channel))))
(f request
method-and-path-components method-and-path-components
mime-types mime-types
body)) body)
(render-html (render-html
#:sxml (general-not-found #:sxml (general-not-found
"Page not found" "Page not found"
"") "")
#:code 404))) #:code 404)))
(define* (delegate-to-with-secret-key-base f #:key use-reserved-thread-pool?) (define* (delegate-to-with-secret-key-base f)
(or (parameterize (or (f request
((thread-pool-channel
(if use-reserved-thread-pool?
(reserved-thread-pool-channel)
(thread-pool-channel))))
(f request
method-and-path-components method-and-path-components
mime-types mime-types
body body
secret-key-base)) secret-key-base)
(render-html (render-html
#:sxml (general-not-found #:sxml (general-not-found
"Page not found" "Page not found"
@ -690,35 +660,29 @@
(base-controller request method-and-path-components #t) (base-controller request method-and-path-components #t)
(match method-and-path-components (match method-and-path-components
(('GET) (('GET)
(parameterize ((thread-pool-channel
(reserved-thread-pool-channel)))
(render-html (render-html
#:sxml (index #:sxml (index
(parallel-via-thread-pool-channel (with-resource-from-pool (reserved-connection-pool) conn
(with-thread-postgresql-connection
(lambda (conn)
(map (map
(lambda (git-repository-details) (lambda (git-repository-details)
(cons (cons
git-repository-details git-repository-details
(all-branches-with-most-recent-commit (all-branches-with-most-recent-commit
conn (first git-repository-details)))) conn (first git-repository-details))))
(all-git-repositories conn))))))))) (all-git-repositories conn))))))
(('GET "builds") (('GET "builds")
(delegate-to build-controller)) (delegate-to build-controller))
(('GET "statistics") (('GET "statistics")
(letpar& ((guix-revisions-count (letpar& ((guix-revisions-count
(with-thread-postgresql-connection count-guix-revisions)) (with-resource-from-pool (connection-pool) conn count-guix-revisions))
(count-derivations (count-derivations
(with-thread-postgresql-connection count-derivations))) (with-resource-from-pool (connection-pool) conn count-derivations)))
(render-html (render-html
#:sxml (view-statistics guix-revisions-count #:sxml (view-statistics guix-revisions-count
count-derivations)))) count-derivations))))
(('GET "metrics") (('GET "metrics")
(parameterize ((thread-pool-channel (render-metrics))
(reserved-thread-pool-channel)))
(render-metrics)))
(('GET "revision" args ...) (('GET "revision" args ...)
(delegate-to revision-controller)) (delegate-to revision-controller))
(('GET "repositories") (('GET "repositories")
@ -728,14 +692,12 @@
(('GET "package" _ ...) (('GET "package" _ ...)
(delegate-to package-controller)) (delegate-to package-controller))
(('GET "gnu" "store" filename) (('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 ;; These routes are a little special, as the extensions aren't used for
;; content negotiation, so just use the path from the request ;; content negotiation, so just use the path from the request
(let ((path (uri-path (request-uri request)))) (let ((path (uri-path (request-uri request))))
(if (string-suffix? ".drv" path) (if (string-suffix? ".drv" path)
(render-derivation (uri-decode path)) (render-derivation (uri-decode path))
(render-store-item (uri-decode path)))))) (render-store-item (uri-decode path)))))
(('GET "gnu" "store" filename "formatted") (('GET "gnu" "store" filename "formatted")
(if (string-suffix? ".drv" filename) (if (string-suffix? ".drv" filename)
(render-formatted-derivation (string-append "/gnu/store/" filename)) (render-formatted-derivation (string-append "/gnu/store/" filename))
@ -747,12 +709,10 @@
(('GET "gnu" "store" filename "plain") (('GET "gnu" "store" filename "plain")
(if (string-suffix? ".drv" filename) (if (string-suffix? ".drv" filename)
(let ((raw-drv (let ((raw-drv
(parallel-via-thread-pool-channel (with-resource-from-pool (connection-pool) conn
(with-thread-postgresql-connection
(lambda (conn)
(select-serialized-derivation-by-file-name (select-serialized-derivation-by-file-name
conn conn
(string-append "/gnu/store/" filename))))))) (string-append "/gnu/store/" filename)))))
(if raw-drv (if raw-drv
(render-text raw-drv) (render-text raw-drv)
(not-found (request-uri request)))) (not-found (request-uri request))))
@ -764,20 +724,16 @@
(render-json-derivation (string-append "/gnu/store/" filename)) (render-json-derivation (string-append "/gnu/store/" filename))
(render-json-store-item (string-append "/gnu/store/" filename)))) (render-json-store-item (string-append "/gnu/store/" filename))))
(('GET "build-servers") (('GET "build-servers")
(delegate-to-with-secret-key-base build-server-controller (delegate-to-with-secret-key-base build-server-controller))
#:use-reserved-thread-pool? #t))
(('GET "dumps" _ ...) (('GET "dumps" _ ...)
(delegate-to dumps-controller)) (delegate-to dumps-controller))
(((or 'GET 'POST) "build-server" _ ...) (((or 'GET 'POST) "build-server" _ ...)
(delegate-to-with-secret-key-base build-server-controller)) (delegate-to-with-secret-key-base build-server-controller))
(('GET "compare" _ ...) (delegate-to compare-controller)) (('GET "compare" _ ...) (delegate-to compare-controller))
(('GET "compare-by-datetime" _ ...) (delegate-to compare-controller)) (('GET "compare-by-datetime" _ ...) (delegate-to compare-controller))
(('GET "jobs" _ ...) (delegate-to jobs-controller (('GET "jobs" _ ...) (delegate-to jobs-controller))
#:use-reserved-thread-pool? #t)) (('GET "job" job-id) (delegate-to jobs-controller))
(('GET "job" job-id) (delegate-to jobs-controller (('GET _ ...) (delegate-to nar-controller))
#:use-reserved-thread-pool? #t))
(('GET _ ...) (delegate-to nar-controller
#:use-reserved-thread-pool? #t))
((method path ...) ((method path ...)
(render-html (render-html
#:sxml (general-not-found #:sxml (general-not-found

29
guix-data-service/web/jobs/controller.scm
View file

@ -20,6 +20,7 @@
#:use-module (guix-data-service utils) #:use-module (guix-data-service utils)
#:use-module (guix-data-service database) #:use-module (guix-data-service database)
#:use-module (guix-data-service web render) #: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 query-parameters)
#:use-module (guix-data-service web util) #:use-module (guix-data-service web util)
#:use-module (guix-data-service jobs load-new-guix-revision) #:use-module (guix-data-service jobs load-new-guix-revision)
@ -73,14 +74,14 @@
(define limit-results (assq-ref query-parameters 'limit_results)) (define limit-results (assq-ref query-parameters 'limit_results))
(letpar& ((jobs (letpar& ((jobs
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(select-jobs-and-events (select-jobs-and-events
conn conn
(assq-ref query-parameters 'before_id) (assq-ref query-parameters 'before_id)
limit-results)))) limit-results)))
(recent-events (recent-events
(with-thread-postgresql-connection (call-with-resource-from-pool
(connection-pool)
select-recent-job-events))) select-recent-job-events)))
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
'(application/json text/html) '(application/json text/html)
@ -116,14 +117,13 @@
limit-results)))))))) limit-results))))))))
(define (render-job-events mime-types query-parameters) (define (render-job-events mime-types query-parameters)
(letpar& ((recent-events (let ((recent-events
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(select-recent-job-events (select-recent-job-events
conn conn
;; TODO Ideally there wouldn't be a limit ;; TODO Ideally there wouldn't be a limit
#:limit (or (assq-ref query-parameters 'limit_results) #:limit (or (assq-ref query-parameters 'limit_results)
1000000)))))) 1000000)))))
(render-html (render-html
#:sxml (view-job-events #:sxml (view-job-events
query-parameters query-parameters
@ -132,19 +132,18 @@
(define (render-job-queue mime-types) (define (render-job-queue mime-types)
(render-html (render-html
#:sxml (view-job-queue #:sxml (view-job-queue
(parallel-via-thread-pool-channel (call-with-resource-from-pool
(with-thread-postgresql-connection (connection-pool)
select-unprocessed-jobs-and-events))))) select-unprocessed-jobs-and-events))))
(define (render-job mime-types job-id query-parameters) (define (render-job mime-types job-id query-parameters)
(letpar& ((log-text (let ((log-text
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(log-for-job conn job-id (log-for-job conn job-id
#:character-limit #:character-limit
(assq-ref query-parameters 'characters) (assq-ref query-parameters 'characters)
#:start-character #:start-character
(assq-ref query-parameters 'start_character)))))) (assq-ref query-parameters 'start_character)))))
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
'(text/plain text/html) '(text/plain text/html)
mime-types) mime-types)

35
guix-data-service/web/nar/controller.scm
View file

@ -34,6 +34,7 @@
#:use-module (guix-data-service utils) #:use-module (guix-data-service utils)
#:use-module (guix-data-service database) #:use-module (guix-data-service database)
#:use-module (guix-data-service web render) #: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 web nar html)
#:use-module (guix-data-service model derivation) #:use-module (guix-data-service model derivation)
#:export (nar-controller #:export (nar-controller
@ -99,11 +100,9 @@
mime-types mime-types
file-name) file-name)
(or (or
(and=> (parallel-via-thread-pool-channel (and=> (with-resource-from-pool (reserved-connection-pool) conn
(with-thread-postgresql-connection
(lambda (conn)
(select-serialized-derivation-by-file-name conn (select-serialized-derivation-by-file-name conn
file-name)))) file-name))
(lambda (derivation-text) (lambda (derivation-text)
(let ((derivation-bytevector (let ((derivation-bytevector
(string->bytevector derivation-text (string->bytevector derivation-text
@ -130,11 +129,9 @@
mime-types mime-types
file-name) file-name)
(or (or
(and=> (parallel-via-thread-pool-channel (and=> (with-resource-from-pool (reserved-connection-pool) conn
(with-thread-postgresql-connection
(lambda (conn)
(select-derivation-source-file-nar-data-by-file-name conn (select-derivation-source-file-nar-data-by-file-name conn
file-name)))) file-name))
(lambda (data) (lambda (data)
(list (build-response (list (build-response
#:code 200 #:code 200
@ -150,11 +147,9 @@
(define (render-narinfo request (define (render-narinfo request
hash) hash)
(or (or
(and=> (parallel-via-thread-pool-channel (and=> (with-resource-from-pool (reserved-connection-pool) conn
(with-thread-postgresql-connection
(lambda (conn)
(select-derivation-by-file-name-hash conn (select-derivation-by-file-name-hash conn
hash)))) hash))
(lambda (derivation) (lambda (derivation)
(list (build-response (list (build-response
#:code 200 #:code 200
@ -162,17 +157,15 @@
(let ((derivation-file-name (second derivation))) (let ((derivation-file-name (second derivation)))
(letpar& (letpar&
((derivation-text ((derivation-text
(with-thread-postgresql-connection (with-resource-from-pool (reserved-connection-pool) conn
(lambda (conn)
(select-serialized-derivation-by-file-name (select-serialized-derivation-by-file-name
conn conn
derivation-file-name)))) derivation-file-name)))
(derivation-references (derivation-references
(with-thread-postgresql-connection (with-resource-from-pool (reserved-connection-pool) conn
(lambda (conn)
(select-derivation-references-by-derivation-id (select-derivation-references-by-derivation-id
conn conn
(first derivation)))))) (first derivation)))))
(let* ((derivation-bytevector (let* ((derivation-bytevector
(string->bytevector derivation-text (string->bytevector derivation-text
"ISO-8859-1")) "ISO-8859-1"))
@ -195,11 +188,9 @@
(narinfo-string derivation-file-name (narinfo-string derivation-file-name
nar-bytevector nar-bytevector
derivation-references))))))) derivation-references)))))))
(and=> (parallel-via-thread-pool-channel (and=> (with-resource-from-pool (reserved-connection-pool) conn
(with-thread-postgresql-connection
(lambda (conn)
(select-derivation-source-file-data-by-file-name-hash conn (select-derivation-source-file-data-by-file-name-hash conn
hash)))) hash))
(match-lambda (match-lambda
((store-path compression compressed-size ((store-path compression compressed-size
hash-algorithm hash uncompressed-size) hash-algorithm hash uncompressed-size)

6
guix-data-service/web/package/controller.scm
View file

@ -22,6 +22,7 @@
#:use-module (guix-data-service utils) #:use-module (guix-data-service utils)
#:use-module (guix-data-service database) #:use-module (guix-data-service database)
#:use-module (guix-data-service web render) #: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 query-parameters)
#:use-module (guix-data-service web util) #:use-module (guix-data-service web util)
#:use-module (guix-data-service model package) #:use-module (guix-data-service model package)
@ -40,13 +41,12 @@
`((system ,parse-system #:default "x86_64-linux") `((system ,parse-system #:default "x86_64-linux")
(target ,parse-target #:default ""))))) (target ,parse-target #:default "")))))
(letpar& ((package-versions-with-branches (letpar& ((package-versions-with-branches
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(branches-by-package-version conn name (branches-by-package-version conn name
(assq-ref parsed-query-parameters (assq-ref parsed-query-parameters
'system) 'system)
(assq-ref parsed-query-parameters (assq-ref parsed-query-parameters
'target)))))) 'target)))))
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
'(application/json text/html) '(application/json text/html)
mime-types) mime-types)

115
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 model git-repository)
#:use-module (guix-data-service web view html) #:use-module (guix-data-service web view html)
#:use-module (guix-data-service web revision controller) #:use-module (guix-data-service web revision controller)
#:use-module (guix-data-service web controller)
#:use-module (guix-data-service web repository html) #:use-module (guix-data-service web repository html)
#:export (repository-controller)) #:export (repository-controller))
@ -47,7 +48,7 @@
(match method-and-path-components (match method-and-path-components
(('GET "repositories") (('GET "repositories")
(letpar& ((git-repositories (letpar& ((git-repositories
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
all-git-repositories))) all-git-repositories)))
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
'(application/json text/html) '(application/json text/html)
@ -67,17 +68,14 @@
#:sxml #:sxml
(view-git-repositories git-repositories)))))) (view-git-repositories git-repositories))))))
(('GET "repository" id) (('GET "repository" id)
(match (parallel-via-thread-pool-channel (match (with-resource-from-pool (connection-pool) conn
(with-thread-postgresql-connection (select-git-repository conn id))
(lambda (conn)
(select-git-repository conn id))))
((label url cgit-url-base fetch-with-authentication?) ((label url cgit-url-base fetch-with-authentication?)
(letpar& ((branches (letpar& ((branches
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(all-branches-with-most-recent-commit (all-branches-with-most-recent-commit
conn conn
(string->number id)))))) (string->number id)))))
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
'(application/json text/html) '(application/json text/html)
mime-types) mime-types)
@ -122,8 +120,7 @@
(before_date ,parse-datetime) (before_date ,parse-datetime)
(limit_results ,parse-result-limit #:default 100))))) (limit_results ,parse-result-limit #:default 100)))))
(letpar& ((revisions (letpar& ((revisions
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(most-recent-commits-for-branch (most-recent-commits-for-branch
conn conn
(string->number repository-id) (string->number repository-id)
@ -132,7 +129,7 @@
#:after-date (assq-ref parsed-query-parameters #:after-date (assq-ref parsed-query-parameters
'after_date) 'after_date)
#:before-date (assq-ref parsed-query-parameters #:before-date (assq-ref parsed-query-parameters
'before_date)))))) 'before_date)))))
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
'(application/json text/html) '(application/json text/html)
mime-types) mime-types)
@ -164,12 +161,11 @@
revisions))))))))) revisions)))))))))
(('GET "repository" repository-id "branch" branch-name "package" package-name) (('GET "repository" repository-id "branch" branch-name "package" package-name)
(letpar& ((package-versions (letpar& ((package-versions
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(package-versions-for-branch conn (package-versions-for-branch conn
(string->number repository-id) (string->number repository-id)
branch-name branch-name
package-name))))) package-name))))
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
'(application/json text/html) '(application/json text/html)
mime-types) mime-types)
@ -216,17 +212,17 @@
request request
`((system ,parse-system #:default "x86_64-linux"))))) `((system ,parse-system #:default "x86_64-linux")))))
(letpar& ((system-test-history (letpar& ((system-test-history
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(system-test-derivations-for-branch (system-test-derivations-for-branch
conn conn
(string->number repository-id) (string->number repository-id)
branch-name branch-name
(assq-ref parsed-query-parameters (assq-ref parsed-query-parameters
'system) 'system)
system-test-name)))) system-test-name)))
(valid-systems (valid-systems
(with-thread-postgresql-connection list-systems))) (call-with-resource-from-pool (connection-pool)
list-systems)))
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
'(application/json text/html) '(application/json text/html)
mime-types) mime-types)
@ -261,11 +257,10 @@
system-test-history))))))) system-test-history)))))))
(('GET "repository" repository-id "branch" branch-name "latest-processed-revision") (('GET "repository" repository-id "branch" branch-name "latest-processed-revision")
(letpar& ((commit-hash (letpar& ((commit-hash
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(latest-processed-commit-for-branch conn (latest-processed-commit-for-branch conn
repository-id repository-id
branch-name))))) branch-name))))
(if commit-hash (if commit-hash
(render-view-revision mime-types (render-view-revision mime-types
commit-hash commit-hash
@ -278,11 +273,10 @@
branch-name)))) branch-name))))
(('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "packages") (('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "packages")
(letpar& ((commit-hash (letpar& ((commit-hash
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(latest-processed-commit-for-branch conn (latest-processed-commit-for-branch conn
repository-id repository-id
branch-name))))) branch-name))))
(if commit-hash (if commit-hash
(let ((parsed-query-parameters (let ((parsed-query-parameters
(guard-against-mutually-exclusive-query-parameters (guard-against-mutually-exclusive-query-parameters
@ -319,11 +313,10 @@
branch-name)))) branch-name))))
(('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "package-derivations") (('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "package-derivations")
(letpar& ((commit-hash (letpar& ((commit-hash
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(latest-processed-commit-for-branch conn (latest-processed-commit-for-branch conn
repository-id repository-id
branch-name))))) branch-name))))
(if commit-hash (if commit-hash
(let ((parsed-query-parameters (let ((parsed-query-parameters
(guard-against-mutually-exclusive-query-parameters (guard-against-mutually-exclusive-query-parameters
@ -353,12 +346,11 @@
branch-name)))) branch-name))))
(('GET "repository" repository-id "branch" branch-name (('GET "repository" repository-id "branch" branch-name
"latest-processed-revision" "fixed-output-package-derivations") "latest-processed-revision" "fixed-output-package-derivations")
(letpar& ((commit-hash (let ((commit-hash
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(latest-processed-commit-for-branch conn (latest-processed-commit-for-branch conn
repository-id repository-id
branch-name))))) branch-name))))
(if commit-hash (if commit-hash
(let ((parsed-query-parameters (let ((parsed-query-parameters
(guard-against-mutually-exclusive-query-parameters (guard-against-mutually-exclusive-query-parameters
@ -383,12 +375,11 @@
repository-id repository-id
branch-name)))) branch-name))))
(('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "package-derivation-outputs") (('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "package-derivation-outputs")
(letpar& ((commit-hash (let ((commit-hash
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(latest-processed-commit-for-branch conn (latest-processed-commit-for-branch conn
repository-id repository-id
branch-name))))) branch-name))))
(if commit-hash (if commit-hash
(let ((parsed-query-parameters (let ((parsed-query-parameters
(guard-against-mutually-exclusive-query-parameters (guard-against-mutually-exclusive-query-parameters
@ -431,11 +422,10 @@
(('GET "repository" repository-id "branch" branch-name (('GET "repository" repository-id "branch" branch-name
"latest-processed-revision" "system-tests") "latest-processed-revision" "system-tests")
(letpar& ((commit-hash (letpar& ((commit-hash
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(latest-processed-commit-for-branch conn (latest-processed-commit-for-branch conn
repository-id repository-id
branch-name))))) branch-name))))
(if commit-hash (if commit-hash
(let ((parsed-query-parameters (let ((parsed-query-parameters
(parse-query-parameters (parse-query-parameters
@ -450,11 +440,10 @@
branch-name)))) branch-name))))
(('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "package-reproducibility") (('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "package-reproducibility")
(letpar& ((commit-hash (letpar& ((commit-hash
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(latest-processed-commit-for-branch conn (latest-processed-commit-for-branch conn
repository-id repository-id
branch-name))))) branch-name))))
(if commit-hash (if commit-hash
(render-revision-package-reproduciblity (render-revision-package-reproduciblity
mime-types mime-types
@ -473,11 +462,10 @@
branch-name)))) branch-name))))
(('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "package-substitute-availability") (('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "package-substitute-availability")
(letpar& ((commit-hash (letpar& ((commit-hash
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(latest-processed-commit-for-branch conn (latest-processed-commit-for-branch conn
repository-id repository-id
branch-name))))) branch-name))))
(if commit-hash (if commit-hash
(render-revision-package-substitute-availability mime-types (render-revision-package-substitute-availability mime-types
commit-hash commit-hash
@ -488,11 +476,10 @@
(('GET "repository" repository-id "branch" branch-name "latest-processed-revision" (('GET "repository" repository-id "branch" branch-name "latest-processed-revision"
"lint-warnings") "lint-warnings")
(letpar& ((commit-hash (letpar& ((commit-hash
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(latest-processed-commit-for-branch conn (latest-processed-commit-for-branch conn
repository-id repository-id
branch-name))))) branch-name))))
(if commit-hash (if commit-hash
(let ((parsed-query-parameters (let ((parsed-query-parameters
(parse-query-parameters (parse-query-parameters
@ -523,11 +510,10 @@
branch-name)))) branch-name))))
(('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "package" name version) (('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "package" name version)
(letpar& ((commit-hash (letpar& ((commit-hash
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(latest-processed-commit-for-branch conn (latest-processed-commit-for-branch conn
repository-id repository-id
branch-name))))) branch-name))))
(let ((parsed-query-parameters (let ((parsed-query-parameters
(parse-query-parameters (parse-query-parameters
request request
@ -558,9 +544,9 @@
(define (parse-build-system) (define (parse-build-system)
(let ((systems (let ((systems
(parallel-via-thread-pool-channel (call-with-resource-from-pool
(with-thread-postgresql-connection (connection-pool)
list-systems)))) list-systems)))
(lambda (s) (lambda (s)
(if (member s systems) (if (member s systems)
s s
@ -598,16 +584,15 @@
(assq-ref parsed-query-parameters 'target))) (assq-ref parsed-query-parameters 'target)))
(letpar& (letpar&
((package-derivations ((package-derivations
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(package-derivations-for-branch conn (package-derivations-for-branch conn
(string->number repository-id) (string->number repository-id)
branch-name branch-name
system system
target target
package-name)))) package-name)))
(build-server-urls (build-server-urls
(with-thread-postgresql-connection (call-with-resource-from-pool (connection-pool)
select-build-server-urls-by-id))) select-build-server-urls-by-id)))
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
'(application/json text/html) '(application/json text/html)
@ -635,10 +620,10 @@
package-derivations)))))) package-derivations))))))
(else (else
(letpar& ((systems (letpar& ((systems
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
list-systems)) list-systems))
(targets (targets
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
valid-targets))) valid-targets)))
(render-html (render-html
#:sxml (view-branch-package-derivations #:sxml (view-branch-package-derivations
@ -673,17 +658,17 @@
(assq-ref parsed-query-parameters 'output))) (assq-ref parsed-query-parameters 'output)))
(letpar& (letpar&
((package-outputs ((package-outputs
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(package-outputs-for-branch conn (package-outputs-for-branch conn
(string->number repository-id) (string->number repository-id)
branch-name branch-name
system system
target target
package-name package-name
output-name)))) output-name)))
(build-server-urls (build-server-urls
(with-thread-postgresql-connection (call-with-resource-from-pool
(connection-pool)
select-build-server-urls-by-id))) select-build-server-urls-by-id)))
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
'(application/json text/html) '(application/json text/html)
@ -711,10 +696,10 @@
package-outputs)))))) package-outputs))))))
(else (else
(letpar& ((systems (letpar& ((systems
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
list-systems)) list-systems))
(targets (targets
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
valid-targets))) valid-targets)))
(render-html (render-html
#:sxml (view-branch-package-outputs #:sxml (view-branch-package-outputs

384
guix-data-service/web/revision/controller.scm
View file

@ -30,6 +30,7 @@
#:use-module (guix-data-service web sxml) #:use-module (guix-data-service web sxml)
#:use-module (guix-data-service web query-parameters) #:use-module (guix-data-service web query-parameters)
#:use-module (guix-data-service web util) #: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 model utils)
#:use-module (guix-data-service jobs load-new-guix-revision) #:use-module (guix-data-service jobs load-new-guix-revision)
#:use-module (guix-data-service model build) #:use-module (guix-data-service model build)
@ -84,7 +85,7 @@
(define (parse-build-server v) (define (parse-build-server v)
(letpar& ((build-servers (letpar& ((build-servers
(with-thread-postgresql-connection select-build-servers))) (with-resource-from-pool (connection-pool) conn select-build-servers)))
(or (any (match-lambda (or (any (match-lambda
((id url lookup-all-derivations? lookup-builds?) ((id url lookup-all-derivations? lookup-builds?)
(if (eq? (string->number v) (if (eq? (string->number v)
@ -105,20 +106,16 @@
(match method-and-path-components (match method-and-path-components
(('GET "revision" commit-hash) (('GET "revision" commit-hash)
(if (parallel-via-thread-pool-channel (if (with-resource-from-pool (connection-pool) conn
(with-thread-postgresql-connection (guix-revision-loaded-successfully? conn commit-hash))
(lambda (conn)
(guix-revision-loaded-successfully? conn commit-hash))))
(render-view-revision mime-types (render-view-revision mime-types
commit-hash commit-hash
#:path-base path) #:path-base path)
(render-unknown-revision mime-types (render-unknown-revision mime-types
commit-hash))) commit-hash)))
(('GET "revision" commit-hash "news") (('GET "revision" commit-hash "news")
(if (parallel-via-thread-pool-channel (if (with-resource-from-pool (connection-pool) conn
(with-thread-postgresql-connection (guix-revision-loaded-successfully? conn commit-hash))
(lambda (conn)
(guix-revision-loaded-successfully? conn commit-hash))))
(let ((parsed-query-parameters (let ((parsed-query-parameters
(parse-query-parameters (parse-query-parameters
request request
@ -129,10 +126,8 @@
(render-unprocessed-revision mime-types (render-unprocessed-revision mime-types
commit-hash))) commit-hash)))
(('GET "revision" commit-hash "packages") (('GET "revision" commit-hash "packages")
(if (parallel-via-thread-pool-channel (if (with-resource-from-pool (connection-pool) conn
(with-thread-postgresql-connection (guix-revision-loaded-successfully? conn commit-hash))
(lambda (conn)
(guix-revision-loaded-successfully? conn commit-hash))))
(let ((parsed-query-parameters (let ((parsed-query-parameters
(guard-against-mutually-exclusive-query-parameters (guard-against-mutually-exclusive-query-parameters
(parse-query-parameters (parse-query-parameters
@ -158,30 +153,24 @@
(render-unprocessed-revision mime-types (render-unprocessed-revision mime-types
commit-hash))) commit-hash)))
(('GET "revision" commit-hash "packages-translation-availability") (('GET "revision" commit-hash "packages-translation-availability")
(if (parallel-via-thread-pool-channel (if (with-resource-from-pool (connection-pool) conn
(with-thread-postgresql-connection (guix-revision-loaded-successfully? conn commit-hash))
(lambda (conn)
(guix-revision-loaded-successfully? conn commit-hash))))
(render-revision-packages-translation-availability mime-types (render-revision-packages-translation-availability mime-types
commit-hash commit-hash
#:path-base path) #:path-base path)
(render-unprocessed-revision mime-types (render-unprocessed-revision mime-types
commit-hash))) commit-hash)))
(('GET "revision" commit-hash "package" name) (('GET "revision" commit-hash "package" name)
(if (parallel-via-thread-pool-channel (if (with-resource-from-pool (connection-pool) conn
(with-thread-postgresql-connection (guix-revision-loaded-successfully? conn commit-hash))
(lambda (conn)
(guix-revision-loaded-successfully? conn commit-hash))))
(render-revision-package mime-types (render-revision-package mime-types
commit-hash commit-hash
name) name)
(render-unprocessed-revision mime-types (render-unprocessed-revision mime-types
commit-hash))) commit-hash)))
(('GET "revision" commit-hash "package" name version) (('GET "revision" commit-hash "package" name version)
(if (parallel-via-thread-pool-channel (if (with-resource-from-pool (connection-pool) conn
(with-thread-postgresql-connection (guix-revision-loaded-successfully? conn commit-hash))
(lambda (conn)
(guix-revision-loaded-successfully? conn commit-hash))))
(let ((parsed-query-parameters (let ((parsed-query-parameters
(parse-query-parameters (parse-query-parameters
request request
@ -194,10 +183,8 @@
(render-unprocessed-revision mime-types (render-unprocessed-revision mime-types
commit-hash))) commit-hash)))
(('GET "revision" commit-hash "package-derivations") (('GET "revision" commit-hash "package-derivations")
(if (parallel-via-thread-pool-channel (if (with-resource-from-pool (connection-pool) conn
(with-thread-postgresql-connection (guix-revision-loaded-successfully? conn commit-hash))
(lambda (conn)
(guix-revision-loaded-successfully? conn commit-hash))))
(let ((parsed-query-parameters (let ((parsed-query-parameters
(guard-against-mutually-exclusive-query-parameters (guard-against-mutually-exclusive-query-parameters
(parse-query-parameters (parse-query-parameters
@ -228,10 +215,8 @@
(render-unprocessed-revision mime-types (render-unprocessed-revision mime-types
commit-hash))) commit-hash)))
(('GET "revision" commit-hash "fixed-output-package-derivations") (('GET "revision" commit-hash "fixed-output-package-derivations")
(if (parallel-via-thread-pool-channel (if (with-resource-from-pool (connection-pool) conn
(with-thread-postgresql-connection (guix-revision-loaded-successfully? conn commit-hash))
(lambda (conn)
(guix-revision-loaded-successfully? conn commit-hash))))
(let ((parsed-query-parameters (let ((parsed-query-parameters
(guard-against-mutually-exclusive-query-parameters (guard-against-mutually-exclusive-query-parameters
(parse-query-parameters (parse-query-parameters
@ -254,10 +239,8 @@
(render-unprocessed-revision mime-types (render-unprocessed-revision mime-types
commit-hash))) commit-hash)))
(('GET "revision" commit-hash "package-derivation-outputs") (('GET "revision" commit-hash "package-derivation-outputs")
(if (parallel-via-thread-pool-channel (if (with-resource-from-pool (connection-pool) conn
(with-thread-postgresql-connection (guix-revision-loaded-successfully? conn commit-hash))
(lambda (conn)
(guix-revision-loaded-successfully? conn commit-hash))))
(let ((parsed-query-parameters (let ((parsed-query-parameters
(guard-against-mutually-exclusive-query-parameters (guard-against-mutually-exclusive-query-parameters
(parse-query-parameters (parse-query-parameters
@ -287,10 +270,8 @@
(render-unprocessed-revision mime-types (render-unprocessed-revision mime-types
commit-hash))) commit-hash)))
(('GET "revision" commit-hash "system-tests") (('GET "revision" commit-hash "system-tests")
(if (parallel-via-thread-pool-channel (if (with-resource-from-pool (connection-pool) conn
(with-thread-postgresql-connection (guix-revision-loaded-successfully? conn commit-hash))
(lambda (conn)
(guix-revision-loaded-successfully? conn commit-hash))))
(let ((parsed-query-parameters (let ((parsed-query-parameters
(parse-query-parameters (parse-query-parameters
request request
@ -302,40 +283,32 @@
(render-unprocessed-revision mime-types (render-unprocessed-revision mime-types
commit-hash))) commit-hash)))
(('GET "revision" commit-hash "channel-instances") (('GET "revision" commit-hash "channel-instances")
(if (parallel-via-thread-pool-channel (if (with-resource-from-pool (connection-pool) conn
(with-thread-postgresql-connection (channel-instances-exist-for-guix-revision? conn commit-hash))
(lambda (conn)
(channel-instances-exist-for-guix-revision? conn commit-hash))))
(render-revision-channel-instances mime-types (render-revision-channel-instances mime-types
commit-hash commit-hash
#:path-base path) #:path-base path)
(render-unprocessed-revision mime-types (render-unprocessed-revision mime-types
commit-hash))) commit-hash)))
(('GET "revision" commit-hash "package-substitute-availability") (('GET "revision" commit-hash "package-substitute-availability")
(if (parallel-via-thread-pool-channel (if (with-resource-from-pool (connection-pool) conn
(with-thread-postgresql-connection (guix-revision-loaded-successfully? conn commit-hash))
(lambda (conn)
(guix-revision-loaded-successfully? conn commit-hash))))
(render-revision-package-substitute-availability mime-types (render-revision-package-substitute-availability mime-types
commit-hash commit-hash
#:path-base path) #:path-base path)
(render-unprocessed-revision mime-types (render-unprocessed-revision mime-types
commit-hash))) commit-hash)))
(('GET "revision" commit-hash "package-reproducibility") (('GET "revision" commit-hash "package-reproducibility")
(if (parallel-via-thread-pool-channel (if (with-resource-from-pool (connection-pool) conn
(with-thread-postgresql-connection (guix-revision-loaded-successfully? conn commit-hash))
(lambda (conn)
(guix-revision-loaded-successfully? conn commit-hash))))
(render-revision-package-reproduciblity mime-types (render-revision-package-reproduciblity mime-types
commit-hash commit-hash
#:path-base path) #:path-base path)
(render-unprocessed-revision mime-types (render-unprocessed-revision mime-types
commit-hash))) commit-hash)))
(('GET "revision" commit-hash "builds") (('GET "revision" commit-hash "builds")
(if (parallel-via-thread-pool-channel (if (with-resource-from-pool (connection-pool) conn
(with-thread-postgresql-connection (guix-revision-loaded-successfully? conn commit-hash))
(lambda (conn)
(guix-revision-loaded-successfully? conn commit-hash))))
(let ((parsed-query-parameters (let ((parsed-query-parameters
(guard-against-mutually-exclusive-query-parameters (guard-against-mutually-exclusive-query-parameters
(parse-query-parameters (parse-query-parameters
@ -357,10 +330,8 @@
(render-unprocessed-revision mime-types (render-unprocessed-revision mime-types
commit-hash))) commit-hash)))
(('GET "revision" commit-hash "blocking-builds") (('GET "revision" commit-hash "blocking-builds")
(if (parallel-via-thread-pool-channel (if (with-resource-from-pool (connection-pool) conn
(with-thread-postgresql-connection (guix-revision-loaded-successfully? conn commit-hash))
(lambda (conn)
(guix-revision-loaded-successfully? conn commit-hash))))
(let ((parsed-query-parameters (let ((parsed-query-parameters
(guard-against-mutually-exclusive-query-parameters (guard-against-mutually-exclusive-query-parameters
(parse-query-parameters (parse-query-parameters
@ -381,10 +352,8 @@
(render-unprocessed-revision mime-types (render-unprocessed-revision mime-types
commit-hash))) commit-hash)))
(('GET "revision" commit-hash "lint-warnings") (('GET "revision" commit-hash "lint-warnings")
(if (parallel-via-thread-pool-channel (if (with-resource-from-pool (connection-pool) conn
(with-thread-postgresql-connection (guix-revision-loaded-successfully? conn commit-hash))
(lambda (conn)
(guix-revision-loaded-successfully? conn commit-hash))))
(let ((parsed-query-parameters (let ((parsed-query-parameters
(parse-query-parameters (parse-query-parameters
request request
@ -424,18 +393,15 @@
#:code 404)) #:code 404))
(else (else
(letpar& ((job (letpar& ((job
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn) (select-job-for-commit conn commit-hash)))
(select-job-for-commit conn commit-hash))))
(git-repositories-and-branches (git-repositories-and-branches
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(git-branches-with-repository-details-for-commit conn (git-branches-with-repository-details-for-commit conn
commit-hash)))) commit-hash)))
(jobs-and-events (jobs-and-events
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn) (select-jobs-and-events-for-commit conn commit-hash))))
(select-jobs-and-events-for-commit conn commit-hash)))))
(render-html (render-html
#:code 404 #:code 404
@ -455,18 +421,15 @@
#:code 404)) #:code 404))
(else (else
(letpar& ((job (letpar& ((job
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn) (select-job-for-commit conn commit-hash)))
(select-job-for-commit conn commit-hash))))
(git-repositories-and-branches (git-repositories-and-branches
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(git-branches-with-repository-details-for-commit conn (git-branches-with-repository-details-for-commit conn
commit-hash)))) commit-hash)))
(jobs-and-events (jobs-and-events
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn) (select-jobs-and-events-for-commit conn commit-hash))))
(select-jobs-and-events-for-commit conn commit-hash)))))
(render-html (render-html
#:code 404 #:code 404
@ -482,27 +445,22 @@
(header-text (header-text
`("Revision " (samp ,commit-hash)))) `("Revision " (samp ,commit-hash))))
(letpar& ((packages-count (letpar& ((packages-count
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn) (count-packages-in-revision conn commit-hash)))
(count-packages-in-revision conn commit-hash))))
(git-repositories-and-branches (git-repositories-and-branches
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(git-branches-with-repository-details-for-commit conn (git-branches-with-repository-details-for-commit conn
commit-hash)))) commit-hash)))
(derivations-counts (derivations-counts
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn) (count-packages-derivations-in-revision conn commit-hash)))
(count-packages-derivations-in-revision conn commit-hash))))
(jobs-and-events (jobs-and-events
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn) (select-jobs-and-events-for-commit conn commit-hash)))
(select-jobs-and-events-for-commit conn commit-hash))))
(lint-warning-counts (lint-warning-counts
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(lint-warning-count-by-lint-checker-for-revision conn (lint-warning-count-by-lint-checker-for-revision conn
commit-hash))))) commit-hash))))
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
'(application/json text/html) '(application/json text/html)
mime-types) mime-types)
@ -547,12 +505,11 @@
(header-link (header-link
(string-append "/revision/" commit-hash))) (string-append "/revision/" commit-hash)))
(letpar& ((system-tests (letpar& ((system-tests
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(select-system-tests-for-guix-revision (select-system-tests-for-guix-revision
conn conn
(assq-ref query-parameters 'system) (assq-ref query-parameters 'system)
commit-hash))))) commit-hash))))
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
'(application/json text/html) '(application/json text/html)
mime-types) mime-types)
@ -576,12 +533,11 @@
system-tests)))))) system-tests))))))
(else (else
(letpar& ((git-repositories (letpar& ((git-repositories
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(git-repositories-containing-commit conn (git-repositories-containing-commit conn
commit-hash)))) commit-hash)))
(systems (systems
(with-thread-postgresql-connection list-systems))) (with-resource-from-pool (connection-pool) conn list-systems)))
(render-html (render-html
#:sxml (view-revision-system-tests #:sxml (view-revision-system-tests
commit-hash commit-hash
@ -603,9 +559,8 @@
(string-append "/revision/" (string-append "/revision/"
commit-hash))) commit-hash)))
(letpar& ((channel-instances (letpar& ((channel-instances
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn) (select-channel-instances-for-guix-revision conn commit-hash))))
(select-channel-instances-for-guix-revision conn commit-hash)))))
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
'(application/json text/html) '(application/json text/html)
mime-types) mime-types)
@ -632,12 +587,12 @@
commit-hash commit-hash
#:key path-base) #:key path-base)
(letpar& ((substitute-availability (letpar& ((substitute-availability
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(select-package-output-availability-for-revision conn (select-package-output-availability-for-revision conn
commit-hash)))) commit-hash)))
(build-server-urls (build-server-urls
(with-thread-postgresql-connection (call-with-resource-from-pool
(connection-pool)
select-build-server-urls-by-id))) select-build-server-urls-by-id)))
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
'(application/json text/html) '(application/json text/html)
@ -678,9 +633,8 @@
(string-append "/revision/" (string-append "/revision/"
commit-hash))) commit-hash)))
(letpar& ((output-consistency (letpar& ((output-consistency
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn) (select-output-consistency-for-revision conn commit-hash))))
(select-output-consistency-for-revision conn commit-hash)))))
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
'(application/json text/html) '(application/json text/html)
mime-types) mime-types)
@ -713,11 +667,10 @@
query-parameters query-parameters
'())))) '()))))
(letpar& ((news-entries (letpar& ((news-entries
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(select-channel-news-entries-contained-in-guix-revision (select-channel-news-entries-contained-in-guix-revision
conn conn
commit-hash))))) commit-hash))))
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
'(application/json text/html) '(application/json text/html)
mime-types) mime-types)
@ -774,8 +727,7 @@
(locale (assq-ref query-parameters 'locale))) (locale (assq-ref query-parameters 'locale)))
(letpar& (letpar&
((packages ((packages
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(if search-query (if search-query
(search-packages-in-revision (search-packages-in-revision
conn conn
@ -788,12 +740,11 @@
commit-hash commit-hash
#:limit-results limit-results #:limit-results limit-results
#:after-name (assq-ref query-parameters 'after_name) #:after-name (assq-ref query-parameters 'after_name)
#:locale (assq-ref query-parameters 'locale)))))) #:locale (assq-ref query-parameters 'locale)))))
(git-repositories (git-repositories
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(git-repositories-containing-commit conn (git-repositories-containing-commit conn
commit-hash))))) commit-hash))))
(let ((show-next-page? (let ((show-next-page?
(and (not search-query) (and (not search-query)
(>= (length packages) (>= (length packages)
@ -843,14 +794,12 @@
packages)))) packages))))
#:extra-headers http-headers-for-unchanging-content)) #:extra-headers http-headers-for-unchanging-content))
(else (else
(letpar& (let ((locale-options
((locale-options (with-resource-from-pool (connection-pool) conn
(with-thread-postgresql-connection
(lambda (conn)
(description-and-synopsis-locale-options (description-and-synopsis-locale-options
(package-description-and-synopsis-locale-options-guix-revision (package-description-and-synopsis-locale-options-guix-revision
conn conn
(commit->revision-id conn commit-hash))))))) (commit->revision-id conn commit-hash))))))
(render-html (render-html
#:sxml (view-revision-packages commit-hash #:sxml (view-revision-packages commit-hash
query-parameters query-parameters
@ -874,19 +823,17 @@
(header-text (header-text
`("Revision " (samp ,commit-hash)))) `("Revision " (samp ,commit-hash))))
(letpar& ((package-synopsis-counts (letpar& ((package-synopsis-counts
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(synopsis-counts-by-locale conn (synopsis-counts-by-locale conn
(commit->revision-id (commit->revision-id
conn conn
commit-hash))))) commit-hash))))
(package-description-counts (package-description-counts
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(description-counts-by-locale conn (description-counts-by-locale conn
(commit->revision-id (commit->revision-id
conn conn
commit-hash)))))) commit-hash)))))
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
'(application/json text/html) '(application/json text/html)
mime-types) mime-types)
@ -916,16 +863,14 @@
(string-append (string-append
"/revision/" commit-hash))) "/revision/" commit-hash)))
(letpar& ((package-versions (letpar& ((package-versions
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(select-package-versions-for-revision conn (select-package-versions-for-revision conn
commit-hash commit-hash
name)))) name)))
(git-repositories-and-branches (git-repositories-and-branches
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(git-branches-with-repository-details-for-commit conn (git-branches-with-repository-details-for-commit conn
commit-hash))))) commit-hash))))
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
'(application/json text/html) '(application/json text/html)
mime-types) mime-types)
@ -963,48 +908,42 @@
(match-lambda (match-lambda
((locale) ((locale)
locale)) locale))
(parallel-via-thread-pool-channel (with-resource-from-pool (connection-pool) conn
(with-thread-postgresql-connection
(lambda (conn)
(delete-duplicates (delete-duplicates
(append (append
(package-description-and-synopsis-locale-options-guix-revision (package-description-and-synopsis-locale-options-guix-revision
conn (commit->revision-id conn commit-hash)) conn (commit->revision-id conn commit-hash))
(lint-warning-message-locales-for-revision conn commit-hash)))))))) (lint-warning-message-locales-for-revision conn commit-hash))))))
(define locale (assq-ref query-parameters 'locale)) (define locale (assq-ref query-parameters 'locale))
(letpar& ((metadata (letpar& ((metadata
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(select-package-metadata-by-revision-name-and-version (select-package-metadata-by-revision-name-and-version
conn conn
commit-hash commit-hash
name name
version version
locale)))) locale)))
(derivations (derivations
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(select-derivations-by-revision-name-and-version (select-derivations-by-revision-name-and-version
conn conn
commit-hash commit-hash
name name
version)))) version)))
(git-repositories (git-repositories
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(git-repositories-containing-commit conn (git-repositories-containing-commit conn
commit-hash)))) commit-hash)))
(lint-warnings (lint-warnings
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(select-lint-warnings-by-revision-package-name-and-version (select-lint-warnings-by-revision-package-name-and-version
conn conn
commit-hash commit-hash
name name
version version
#:locale locale))))) #:locale locale))))
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
'(application/json text/html) '(application/json text/html)
mime-types) mime-types)
@ -1062,9 +1001,11 @@
`((error . "invalid query")))) `((error . "invalid query"))))
(else (else
(letpar& ((systems (letpar& ((systems
(with-thread-postgresql-connection list-systems)) (call-with-resource-from-pool (connection-pool)
list-systems))
(targets (targets
(with-thread-postgresql-connection valid-targets))) (call-with-resource-from-pool (connection-pool)
valid-targets)))
(render-html (render-html
#:sxml (view-revision-package-derivations commit-hash #:sxml (view-revision-package-derivations commit-hash
query-parameters query-parameters
@ -1087,8 +1028,7 @@
(assq-ref query-parameters 'field))) (assq-ref query-parameters 'field)))
(letpar& (letpar&
((derivations ((derivations
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(if search-query (if search-query
(search-package-derivations-in-revision (search-package-derivations-in-revision
conn conn
@ -1124,9 +1064,9 @@
string->symbol) string->symbol)
#:limit-results limit-results #:limit-results limit-results
#:after-name (assq-ref query-parameters 'after_name) #:after-name (assq-ref query-parameters 'after_name)
#:include-builds? (member "builds" fields)))))) #:include-builds? (member "builds" fields)))))
(build-server-urls (build-server-urls
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
select-build-server-urls-by-id))) select-build-server-urls-by-id)))
(let ((show-next-page? (let ((show-next-page?
(if all-results (if all-results
@ -1161,9 +1101,11 @@
derivations)))))) derivations))))))
(else (else
(letpar& ((systems (letpar& ((systems
(with-thread-postgresql-connection list-systems)) (call-with-resource-from-pool (connection-pool)
list-systems))
(targets (targets
(with-thread-postgresql-connection valid-targets))) (call-with-resource-from-pool (connection-pool)
valid-targets)))
(render-html (render-html
#:sxml (view-revision-package-derivations #:sxml (view-revision-package-derivations
commit-hash commit-hash
@ -1197,9 +1139,11 @@
`((error . "invalid query")))) `((error . "invalid query"))))
(else (else
(letpar& ((systems (letpar& ((systems
(with-thread-postgresql-connection list-systems)) (call-with-resource-from-pool (connection-pool)
list-systems))
(targets (targets
(with-thread-postgresql-connection valid-targets))) (call-with-resource-from-pool (connection-pool)
valid-targets)))
(render-html (render-html
#:sxml (view-revision-fixed-output-package-derivations #:sxml (view-revision-fixed-output-package-derivations
commit-hash commit-hash
@ -1222,8 +1166,7 @@
(assq-ref query-parameters 'field))) (assq-ref query-parameters 'field)))
(letpar& (letpar&
((derivations ((derivations
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(select-fixed-output-package-derivations-in-revision (select-fixed-output-package-derivations-in-revision
conn conn
commit-hash commit-hash
@ -1233,9 +1176,9 @@
'latest_build_status) 'latest_build_status)
#:limit-results limit-results #:limit-results limit-results
#:after-derivation-file-name #:after-derivation-file-name
(assq-ref query-parameters 'after_name))))) (assq-ref query-parameters 'after_name))))
(build-server-urls (build-server-urls
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
select-build-server-urls-by-id))) select-build-server-urls-by-id)))
(let ((show-next-page? (let ((show-next-page?
(if all-results (if all-results
@ -1251,9 +1194,11 @@
`((derivations . ,(list->vector derivations))))) `((derivations . ,(list->vector derivations)))))
(else (else
(letpar& ((systems (letpar& ((systems
(with-thread-postgresql-connection list-systems)) (call-with-resource-from-pool (connection-pool)
list-systems))
(targets (targets
(with-thread-postgresql-connection valid-targets))) (call-with-resource-from-pool (connection-pool)
valid-targets)))
(render-html (render-html
#:sxml (view-revision-fixed-output-package-derivations #:sxml (view-revision-fixed-output-package-derivations
commit-hash commit-hash
@ -1278,8 +1223,9 @@
(header-link (header-link
(string-append "/revision/" commit-hash))) (string-append "/revision/" commit-hash)))
(define build-server-urls (define build-server-urls
(parallel-via-thread-pool-channel (call-with-resource-from-pool
(with-thread-postgresql-connection select-build-server-urls-by-id))) (connection-pool)
select-build-server-urls-by-id))
(if (any-invalid-query-parameters? query-parameters) (if (any-invalid-query-parameters? query-parameters)
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
@ -1290,9 +1236,11 @@
`((error . "invalid query")))) `((error . "invalid query"))))
(else (else
(letpar& ((systems (letpar& ((systems
(with-thread-postgresql-connection list-systems)) (call-with-resource-from-pool (connection-pool)
list-systems))
(targets (targets
(with-thread-postgresql-connection valid-targets))) (call-with-resource-from-pool (connection-pool)
valid-targets)))
(render-html (render-html
#:sxml (view-revision-package-derivation-outputs #:sxml (view-revision-package-derivation-outputs
commit-hash commit-hash
@ -1313,8 +1261,7 @@
(assq-ref query-parameters 'field))) (assq-ref query-parameters 'field)))
(letpar& (letpar&
((derivation-outputs ((derivation-outputs
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(select-derivation-outputs-in-revision (select-derivation-outputs-in-revision
conn conn
commit-hash commit-hash
@ -1329,7 +1276,7 @@
#:target (assq-ref query-parameters 'target) #:target (assq-ref query-parameters 'target)
#:include-nars? (member "nars" fields) #:include-nars? (member "nars" fields)
#:limit-results limit-results #:limit-results limit-results
#:after-path (assq-ref query-parameters 'after_path)))))) #:after-path (assq-ref query-parameters 'after_path)))))
(let ((show-next-page? (let ((show-next-page?
(if all-results (if all-results
#f #f
@ -1395,9 +1342,11 @@
derivation-outputs)))))) derivation-outputs))))))
(else (else
(letpar& ((systems (letpar& ((systems
(with-thread-postgresql-connection list-systems)) (call-with-resource-from-pool (connection-pool)
list-systems))
(targets (targets
(with-thread-postgresql-connection valid-targets))) (call-with-resource-from-pool (connection-pool)
valid-targets)))
(render-html (render-html
#:sxml (view-revision-package-derivation-outputs #:sxml (view-revision-package-derivation-outputs
commit-hash commit-hash
@ -1422,9 +1371,11 @@
(string-append "/revision/" commit-hash))) (string-append "/revision/" commit-hash)))
(if (any-invalid-query-parameters? query-parameters) (if (any-invalid-query-parameters? query-parameters)
(letpar& ((systems (letpar& ((systems
(with-thread-postgresql-connection list-systems)) (call-with-resource-from-pool (connection-pool)
list-systems))
(targets (targets
(with-thread-postgresql-connection valid-targets))) (call-with-resource-from-pool (connection-pool)
valid-targets)))
(render-html (render-html
#:sxml #:sxml
(view-revision-builds query-parameters (view-revision-builds query-parameters
@ -1438,30 +1389,29 @@
(let ((system (assq-ref query-parameters 'system)) (let ((system (assq-ref query-parameters 'system))
(target (assq-ref query-parameters 'target))) (target (assq-ref query-parameters 'target)))
(letpar& ((systems (letpar& ((systems
(with-thread-postgresql-connection list-systems)) (call-with-resource-from-pool (connection-pool)
list-systems))
(targets (targets
(with-thread-postgresql-connection valid-targets)) (call-with-resource-from-pool (connection-pool)
valid-targets))
(build-server-options (build-server-options
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(map (match-lambda (map (match-lambda
((id url lookup-all-derivations ((id url lookup-all-derivations
lookup-builds) lookup-builds)
(cons url id))) (cons url id)))
(select-build-servers conn))))) (select-build-servers conn))))
(stats (stats
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(select-build-stats (select-build-stats
conn conn
(assq-ref query-parameters (assq-ref query-parameters
'build_server) 'build_server)
#:revision-commit commit-hash #:revision-commit commit-hash
#:system system #:system system
#:target target)))) #:target target)))
(builds (builds
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(select-builds-with-context (select-builds-with-context
conn conn
(assq-ref query-parameters (assq-ref query-parameters
@ -1472,7 +1422,7 @@
#:system system #:system system
#:target target #:target target
#:limit (assq-ref query-parameters #:limit (assq-ref query-parameters
'limit_results)))))) 'limit_results)))))
(render-html (render-html
#:sxml (view-revision-builds query-parameters #:sxml (view-revision-builds query-parameters
commit-hash commit-hash
@ -1494,9 +1444,11 @@
(string-append "/revision/" commit-hash))) (string-append "/revision/" commit-hash)))
(if (any-invalid-query-parameters? query-parameters) (if (any-invalid-query-parameters? query-parameters)
(letpar& ((systems (letpar& ((systems
(with-thread-postgresql-connection list-systems)) (call-with-resource-from-pool (connection-pool)
list-systems))
(targets (targets
(with-thread-postgresql-connection valid-targets))) (call-with-resource-from-pool (connection-pool)
valid-targets)))
(render-html (render-html
#:sxml #:sxml
(view-revision-blocking-builds query-parameters (view-revision-blocking-builds query-parameters
@ -1509,20 +1461,20 @@
(let ((system (assq-ref query-parameters 'system)) (let ((system (assq-ref query-parameters 'system))
(target (assq-ref query-parameters 'target))) (target (assq-ref query-parameters 'target)))
(letpar& ((systems (letpar& ((systems
(with-thread-postgresql-connection list-systems)) (call-with-resource-from-pool (connection-pool)
list-systems))
(targets (targets
(with-thread-postgresql-connection valid-targets)) (call-with-resource-from-pool (connection-pool)
valid-targets))
(build-server-options (build-server-options
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(map (match-lambda (map (match-lambda
((id url lookup-all-derivations ((id url lookup-all-derivations
lookup-builds) lookup-builds)
(cons url id))) (cons url id)))
(select-build-servers conn))))) (select-build-servers conn))))
(blocking-builds (blocking-builds
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(select-blocking-builds (select-blocking-builds
conn conn
commit-hash commit-hash
@ -1531,7 +1483,7 @@
#:system system #:system system
#:target target #:target target
#:limit (assq-ref query-parameters #:limit (assq-ref query-parameters
'limit_results)))))) 'limit_results)))))
(render-html (render-html
#:sxml (view-revision-blocking-builds query-parameters #:sxml (view-revision-blocking-builds query-parameters
commit-hash commit-hash
@ -1551,24 +1503,20 @@
(header-link (header-link
(string-append "/revision/" commit-hash))) (string-append "/revision/" commit-hash)))
(define lint-checker-options (define lint-checker-options
(parallel-via-thread-pool-channel (with-resource-from-pool (connection-pool) conn
(with-thread-postgresql-connection
(lambda (conn)
(map (match-lambda (map (match-lambda
((name description network-dependent) ((name description network-dependent)
(cons (string-append name ": " description ) (cons (string-append name ": " description )
name))) name)))
(lint-checkers-for-revision conn commit-hash)))))) (lint-checkers-for-revision conn commit-hash))))
(define lint-warnings-locale-options (define lint-warnings-locale-options
(parallel-via-thread-pool-channel (with-resource-from-pool (connection-pool) conn
(with-thread-postgresql-connection
(lambda (conn)
(map (map
(match-lambda (match-lambda
((locale) ((locale)
locale)) locale))
(lint-warning-message-locales-for-revision conn commit-hash)))))) (lint-warning-message-locales-for-revision conn commit-hash))))
(if (any-invalid-query-parameters? query-parameters) (if (any-invalid-query-parameters? query-parameters)
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
@ -1597,18 +1545,16 @@
(fields (assq-ref query-parameters 'field))) (fields (assq-ref query-parameters 'field)))
(letpar& (letpar&
((git-repositories ((git-repositories
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(git-repositories-containing-commit conn (git-repositories-containing-commit conn
commit-hash)))) commit-hash)))
(lint-warnings (lint-warnings
(with-thread-postgresql-connection (with-resource-from-pool (connection-pool) conn
(lambda (conn)
(lint-warnings-for-guix-revision conn commit-hash (lint-warnings-for-guix-revision conn commit-hash
#:locale locale #:locale locale
#:package-query package-query #:package-query package-query
#:linters linters #:linters linters
#:message-query message-query))))) #:message-query message-query))))
(let ((any-translated-lint-warnings? (let ((any-translated-lint-warnings?
(any-translated-lint-warnings? lint-warnings locale))) (any-translated-lint-warnings? lint-warnings locale)))
(case (most-appropriate-mime-type (case (most-appropriate-mime-type

63
guix-data-service/web/server.scm
View file

@ -25,8 +25,10 @@
#:use-module (web uri) #:use-module (web uri)
#:use-module (system repl error-handling) #:use-module (system repl error-handling)
#:use-module (ice-9 atomic) #:use-module (ice-9 atomic)
#:use-module (fibers web server) #:use-module (fibers)
#:use-module (fibers conditions)
#:use-module (prometheus) #:use-module (prometheus)
#:use-module (guix-data-service utils)
#:use-module (guix-data-service database) #:use-module (guix-data-service database)
#:use-module (guix-data-service web controller) #:use-module (guix-data-service web controller)
#:use-module (guix-data-service web util) #:use-module (guix-data-service web util)
@ -60,7 +62,9 @@
render-metrics)))) render-metrics))))
(define* (start-guix-data-service-web-server port host secret-key-base (define* (start-guix-data-service-web-server port host secret-key-base
startup-completed) startup-completed
#:key postgresql-statement-timeout
postgresql-connections)
(define registry (define registry
(make-metrics-registry #:namespace "guixdataservice")) (make-metrics-registry #:namespace "guixdataservice"))
@ -69,25 +73,50 @@
(%database-metrics-registry registry) (%database-metrics-registry registry)
(call-with-error-handling (let ((finished? (make-condition)))
(call-with-sigint
(lambda () (lambda ()
(run-server (lambda (request body) (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 (handler request body controller
secret-key-base secret-key-base
startup-completed startup-completed
render-metrics)) render-metrics))
#:host host #:host host
#:port port)) #:port port))
#:on-error 'backtrace #:unwind? #t))
#:post-error (lambda (key . args) (wait finished?))))
(when (eq? key 'system-error) finished?)))
(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)))))))

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

@ -93,11 +93,11 @@
(alist-cons 'host (alist-cons 'host
arg arg
(alist-delete 'host result)))) (alist-delete 'host result))))
(option '("thread-pool-threads") #t #f (option '("postgresql-connections") #t #f
(lambda (opt name arg result) (lambda (opt name arg result)
(alist-cons 'thread-pool-threads (alist-cons 'postgresql-connections
(string->number arg) (string->number arg)
(alist-delete 'thread-pool-threads (alist-delete 'postgresql-connections
result)))) result))))
(option '("postgresql-statement-timeout") #t #f (option '("postgresql-statement-timeout") #t #f
(lambda (opt name arg result) (lambda (opt name arg result)
@ -119,7 +119,7 @@
(_ #t))) (_ #t)))
(port . 8765) (port . 8765)
(host . "0.0.0.0") (host . "0.0.0.0")
(thread-pool-threads . 16) (postgresql-connections . 16)
(postgresql-statement-timeout . 60000))) (postgresql-statement-timeout . 60000)))
@ -187,44 +187,6 @@
(if (assoc-ref opts 'update-database) (if (assoc-ref opts 'update-database)
#f #f
#t))) #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))) (pid-file (assq-ref opts 'pid-file)))
@ -233,11 +195,6 @@
(lambda (port) (lambda (port)
(simple-format port "~A\n" (getpid))))) (simple-format port "~A\n" (getpid)))))
(when (assoc-ref opts 'update-database)
(run-sqitch)
(atomic-box-set! startup-completed #t))
(call-with-new-thread (call-with-new-thread
(lambda () (lambda ()
(with-postgresql-connection-per-thread (with-postgresql-connection-per-thread
@ -247,4 +204,24 @@
(start-substitute-query-threads) (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)))))