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

Stop using a pool of threads for database operations 

Now that squee cooperates with suspendable ports, this is unnecessary. Use a
connection pool to still support running queries in parallel using multiple
connections.
This commit is contained in:
Christopher Baines 2023-07-09 16:52:35 +01:00
parent 672ee6216e
commit 7251c7d653
15 changed files with 1292 additions and 1310 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
.dir-locals.el
View File

@ -9,7 +9,9 @@
(eval put 'with-time-logging 'scheme-indent-function 1) (eval put '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)))

86
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,29 +580,29 @@ 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 ()
(with-postgresql-transaction (with-postgresql-transaction
conn conn
(lambda (conn) (lambda (conn)
(exec-query (exec-query
conn conn
" "
SET CONSTRAINTS derivations_by_output_details_set_derivation_id_fkey DEFERRED") SET CONSTRAINTS derivations_by_output_details_set_derivation_id_fkey DEFERRED")
(exec-query conn "SET LOCAL lock_timeout = '5s';") (exec-query conn "SET LOCAL lock_timeout = '5s';")
(maybe-delete-derivation conn (maybe-delete-derivation conn
derivation-id)))) derivation-id))))
(lambda (key . args) (lambda (key . args)
(simple-format (simple-format
(current-error-port) (current-error-port)
"error when attempting to delete derivation: ~A ~A\n" "error when attempting to delete derivation: ~A ~A\n"
key args) key args)
0)))))) 0))))))
(monitor (monitor
(set! deleted-count (set! deleted-count
(+ val deleted-count))))) (+ val deleted-count)))))
@ -613,26 +613,30 @@ SET CONSTRAINTS derivations_by_output_details_set_derivation_id_fkey DEFERRED")
deleted-count) deleted-count)
deleted-count))) deleted-count)))
(with-postgresql-connection-per-thread (run-fibers
"data-deletion-thread"
(lambda () (lambda ()
(run-fibers (let* ((connection-pool
(lambda () (make-resource-pool
(with-thread-postgresql-connection (lambda ()
(lambda (conn) (open-postgresql-connection "data-deletion" #f))
(obtain-advisory-transaction-lock 8)))
conn
'delete-unreferenced-derivations)
(let loop ((total-deleted 0)) (with-postgresql-connection
(let ((batch-deleted-count (delete-batch conn))) "data-deletion"
(if (eq? 0 batch-deleted-count) (lambda (conn)
(begin (obtain-advisory-transaction-lock
(with-time-logging conn
"Deleting unused derivation_source_files entries" 'delete-unreferenced-derivations)
(delete-unreferenced-derivations-source-files conn))
(simple-format (let loop ((total-deleted 0))
(current-output-port) (let ((batch-deleted-count (delete-batch conn connection-pool)))
"Finished deleting derivations, deleted ~A in total\n" (if (eq? 0 batch-deleted-count)
total-deleted)) (begin
(loop (+ total-deleted batch-deleted-count)))))))))))) (with-time-logging
"Deleting unused derivation_source_files entries"
(delete-unreferenced-derivations-source-files conn))
(simple-format
(current-output-port)
"Finished deleting derivations, deleted ~A in total\n"
total-deleted))
(loop (+ total-deleted batch-deleted-count)))))))))))

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

@ -28,6 +28,7 @@
run-sqitch 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))) (with-exception-handler
(lambda (exn)
(simple-format
(current-error-port)
"exception running ~A resource pool initializer: ~A:\n ~A\n"
name
initializer
exn)
#f)
(lambda ()
(with-throw-handler #t
initializer
(lambda args
(backtrace))))
#:unwind? #t))
(let ((channel (make-channel))) (let ((channel (make-channel)))
(for-each (spawn-fiber
(lambda _ (lambda ()
(call-with-new-thread (let loop ((resources '())
(lambda () (available '())
(let loop () (waiters '()))
(match (if idle-seconds
(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 (perform-operation
(choice-operation (choice-operation
(get-operation channel) (wrap-operation
(wrap-operation (sleep-operation idle-seconds) (put-operation reply (car available))
(const 'timeout)))) (const #t))
(get-message channel)) (wrap-operation (sleep-operation 0.2)
('timeout (const #f))))))
(when idle-thunk (if checkout-success?
(with-exception-handler (loop resources
(lambda (exn) (cdr available)
(simple-format (current-error-port) waiters)
"worker thread idle thunk exception: ~A\n" (loop resources
exn)) available
idle-thunk waiters)))))
#:unwind? #t)) (('return resource)
;; When a resource is returned, prompt all the waiters to request
;; again. This is to avoid the pool waiting on channels that may
;; be dead.
(for-each
(lambda (waiter)
(spawn-fiber
(lambda ()
(perform-operation
(choice-operation
(put-operation waiter 'resource-pool-retry-checkout)
(sleep-operation 0.2))))))
waiters)
(loop)) (loop resources
(cons resource available)
;; clear waiters, as they've been notified
'()))
(unknown
(simple-format
(current-error-port)
"unrecognised message to ~A resource pool channel: ~A\n"
name
unknown)
(loop resources
available
waiters))))))
(((? channel? reply) sent-time (? procedure? proc))
(let ((time-delay
(- (get-internal-real-time)
sent-time)))
(delay-logger (/ time-delay
internal-time-units-per-second))
(put-message
reply
(with-exception-handler
(lambda (exn)
(cons 'worker-thread-error exn))
(lambda ()
(with-exception-handler
(lambda (exn)
(simple-format
(current-error-port)
"worker thread: exception: ~A\n"
exn)
(backtrace)
(raise-exception exn))
(lambda ()
(call-with-values
proc
(lambda vals
vals)))))
#:unwind? #t)))
(loop))
(_ #f))))))
(iota threads))
channel)) 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))))))

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

@ -26,6 +26,7 @@
#:use-module (guix-data-service substitutes) #:use-module (guix-data-service 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,18 +61,16 @@
(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 (if build-server-build-id
(lambda (conn) (select-build-by-build-server-and-build-server-build-id
(if build-server-build-id conn
(select-build-by-build-server-and-build-server-build-id build-server-id
conn build-server-build-id)
build-server-id (select-build-by-build-server-and-derivation-file-name
build-server-build-id) conn
(select-build-by-build-server-and-derivation-file-name build-server-id
conn derivation-file-name)))))
build-server-id
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 (select-required-builds-that-failed
(lambda (conn) conn
(select-required-builds-that-failed build-server-id
conn derivation-file-name))
build-server-id
derivation-file-name))))
#f))))) #f)))))
(render-html (render-html
#:sxml (general-not-found #:sxml (general-not-found
@ -121,27 +118,26 @@
(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) (with-exception-handler
(with-exception-handler (lambda (exn)
(lambda (exn) (simple-format
(simple-format (current-error-port)
(current-error-port) "exception in build event handler: ~A\n"
"exception in build event handler: ~A\n" exn))
exn)) (lambda ()
(lambda () (with-throw-handler #t
(with-throw-handler #t (lambda ()
(lambda () (handler conn))
(handler conn)) (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 (compute-tokens-for-build-server conn
(lambda (conn) secret-key-base
(compute-tokens-for-build-server conn build-server-id))))
secret-key-base
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,17 +321,17 @@
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))))))
(if build-server (if build-server
(render-build-server mime-types (render-build-server mime-types
build-server) build-server)

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

@ -21,6 +21,7 @@
#:use-module (guix-data-service utils) #:use-module (guix-data-service 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,39 +89,38 @@
(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 'build_status)
'build_status) (assq-ref parsed-query-parameters
(assq-ref parsed-query-parameters 'build_server)
'build_server) #: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

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

@ -30,6 +30,7 @@
#:use-module (guix-data-service web util) #:use-module (guix-data-service web 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,42 +56,38 @@
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 (let* ((job-details
(lambda (conn) (select-job-for-commit conn s))
(let* ((job-details (job-state
(select-job-for-commit conn s)) (assq-ref job-details 'state)))
(job-state (if job-details
(assq-ref job-details 'state))) (cond
(if job-details ((string=? job-state "succeeded")
(cond s)
((string=? job-state "succeeded") ((string=? job-state "queued")
s)
((string=? job-state "queued")
(make-invalid-query-parameter
s
`("data unavailable, "
(a (@ (href ,(string-append
"/revision/" s)))
"yet to process revision"))))
((string=? job-state "failed")
(make-invalid-query-parameter
s
`("data unavailable, "
(a (@ (href ,(string-append
"/revision/" s)))
"failed to process revision"))))
(else
(make-invalid-query-parameter
s "unknown job state")))
(make-invalid-query-parameter (make-invalid-query-parameter
s "unknown commit"))))))) s
`("data unavailable, "
(a (@ (href ,(string-append
"/revision/" s)))
"yet to process revision"))))
((string=? job-state "failed")
(make-invalid-query-parameter
s
`("data unavailable, "
(a (@ (href ,(string-append
"/revision/" s)))
"failed to process revision"))))
(else
(make-invalid-query-parameter
s "unknown job state")))
(make-invalid-query-parameter
s "unknown commit")))))
(define (parse-derivation file-name) (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 (package-differences-data conn
(lambda (conn) base-revision-id
(package-differences-data conn target-revision-id)))))
base-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
target-revision-id
locale)))))
(channel-news-data
(with-thread-postgresql-connection
(lambda (conn)
(channel-news-differences-data conn
base-revision-id base-revision-id
target-revision-id))))) target-revision-id
locale))))
(channel-news-data
(with-resource-from-pool (connection-pool) conn
(channel-news-differences-data conn
base-revision-id
target-revision-id))))
(case (most-appropriate-mime-type (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
(assq-ref query-parameters 'target_commit))))))
(cgit-url-bases
(with-thread-postgresql-connection
(lambda (conn)
(guix-revisions-cgit-url-bases
conn conn
(list base-revision-id (assq-ref query-parameters 'target_commit)))))
target-revision-id)))))) (cgit-url-bases
(with-resource-from-pool (connection-pool) conn
(guix-revisions-cgit-url-bases
conn
(list base-revision-id
target-revision-id)))))
(render-html (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))))) (let ((lint-warnings-locale-options
(letpar& ((lint-warnings-locale-options (map
(map (match-lambda
(match-lambda ((locale)
((locale) locale))
locale)) (with-resource-from-pool (connection-pool) conn
(with-thread-postgresql-connection (lint-warning-message-locales-for-revision
(lambda (conn) conn
(lint-warning-message-locales-for-revision (second base-revision-details))))))
conn
(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 (package-differences-data conn
(lambda (conn) base-revision-id
(package-differences-data conn target-revision-id)))))
base-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 (channel-news-differences-data conn
(lambda (conn) base-revision-id
(channel-news-differences-data conn target-revision-id))))
base-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,32 +547,29 @@
#: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
(base_commit . ,(second base-revision-details)) `(,@query-parameters
(target_commit . ,(second target-revision-details))) (base_commit . ,(second base-revision-details))
'datetime (target_commit . ,(second target-revision-details)))
(parallel-via-thread-pool-channel 'datetime
(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))))) new-packages
new-packages removed-packages
removed-packages version-changes
version-changes (group-list-by-first-n-fields
(parallel-via-thread-pool-channel 2
(group-list-by-first-n-fields (with-resource-from-pool (connection-pool) conn
2 (lint-warning-differences-data
(with-thread-postgresql-connection conn
(lambda (conn) base-revision-id
(lint-warning-differences-data target-revision-id
conn locale)))
base-revision-id lint-warnings-locale-options
target-revision-id channel-news-data)
locale)))))
lint-warnings-locale-options
channel-news-data)
#:extra-headers http-headers-for-unchanging-content))))))))))) #:extra-headers http-headers-for-unchanging-content)))))))))))
(define (render-compare/derivation mime-types (define (render-compare/derivation mime-types
@ -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,14 +664,14 @@
(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
query-parameters query-parameters
@ -718,19 +692,18 @@
(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) (commit->revision-id conn target-commit)
(commit->revision-id conn target-commit) #:systems systems
#:systems systems #: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,11 +728,11 @@
. ,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
query-parameters query-parameters
@ -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,30 +780,27 @@
(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) (first target-revision-details)
(first target-revision-details) #:systems systems
#:systems systems #: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 (package-differences-data conn
(lambda (conn) base-revision-id
(package-differences-data conn target-revision-id)))))
base-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)

300
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 (select-derivation-by-file-name conn
(lambda (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 (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 (select-derivation-by-file-name conn
(lambda (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 (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 (select-nars-for-output
(lambda (conn) conn
(select-nars-for-output (string-append "/gnu/store/" filename)))))
conn
(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 (select-derivation-source-file-nar-details-by-file-name
(lambda (conn) conn
(select-derivation-source-file-nar-details-by-file-name filename)))
conn
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 (select-derivation-source-file-nar-details-by-file-name
(lambda (conn) conn
(select-derivation-source-file-nar-details-by-file-name filename))))))))))
conn
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 method-and-path-components
(if use-reserved-thread-pool? mime-types
(reserved-thread-pool-channel) body)
(thread-pool-channel))))
(f request
method-and-path-components
mime-types
body))
(render-html (render-html
#:sxml (general-not-found #:sxml (general-not-found
"Page not found" "Page not found"
"") "")
#:code 404))) #:code 404)))
(define* (delegate-to-with-secret-key-base f #:key use-reserved-thread-pool?) (define* (delegate-to-with-secret-key-base f)
(or (parameterize (or (f request
((thread-pool-channel method-and-path-components
(if use-reserved-thread-pool? mime-types
(reserved-thread-pool-channel) body
(thread-pool-channel)))) secret-key-base)
(f request
method-and-path-components
mime-types
body
secret-key-base))
(render-html (render-html
#:sxml (general-not-found #:sxml (general-not-found
"Page not found" "Page not found"
@ -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 (render-html
(reserved-thread-pool-channel))) #:sxml (index
(render-html (with-resource-from-pool (reserved-connection-pool) conn
#:sxml (index (map
(parallel-via-thread-pool-channel (lambda (git-repository-details)
(with-thread-postgresql-connection (cons
(lambda (conn) git-repository-details
(map (all-branches-with-most-recent-commit
(lambda (git-repository-details) conn (first git-repository-details))))
(cons (all-git-repositories conn))))))
git-repository-details
(all-branches-with-most-recent-commit
conn (first git-repository-details))))
(all-git-repositories conn)))))))))
(('GET "builds") (('GET "builds")
(delegate-to build-controller)) (delegate-to build-controller))
(('GET "statistics") (('GET "statistics")
(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 ;; These routes are a little special, as the extensions aren't used for
(reserved-thread-pool-channel))) ;; content negotiation, so just use the path from the request
;; These routes are a little special, as the extensions aren't used for (let ((path (uri-path (request-uri request))))
;; content negotiation, so just use the path from the request (if (string-suffix? ".drv" path)
(let ((path (uri-path (request-uri request)))) (render-derivation (uri-decode path))
(if (string-suffix? ".drv" path) (render-store-item (uri-decode path)))))
(render-derivation (uri-decode path))
(render-store-item (uri-decode path))))))
(('GET "gnu" "store" filename "formatted") (('GET "gnu" "store" filename "formatted")
(if (string-suffix? ".drv" filename) (if (string-suffix? ".drv" filename)
(render-formatted-derivation (string-append "/gnu/store/" filename)) (render-formatted-derivation (string-append "/gnu/store/" filename))
@ -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 (select-serialized-derivation-by-file-name
(lambda (conn) conn
(select-serialized-derivation-by-file-name (string-append "/gnu/store/" filename)))))
conn
(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

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

@ -20,6 +20,7 @@
#:use-module (guix-data-service utils) #:use-module (guix-data-service 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)

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

@ -34,6 +34,7 @@
#:use-module (guix-data-service utils) #:use-module (guix-data-service 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 (select-serialized-derivation-by-file-name conn
(lambda (conn) file-name))
(select-serialized-derivation-by-file-name conn
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 (select-derivation-source-file-nar-data-by-file-name conn
(lambda (conn) file-name))
(select-derivation-source-file-nar-data-by-file-name conn
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 (select-derivation-by-file-name-hash conn
(lambda (conn) hash))
(select-derivation-by-file-name-hash conn
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 (select-derivation-source-file-data-by-file-name-hash conn
(lambda (conn) hash))
(select-derivation-source-file-data-by-file-name-hash conn
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)

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

@ -22,6 +22,7 @@
#:use-module (guix-data-service utils) #:use-module (guix-data-service 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)

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

@ -34,6 +34,7 @@
#:use-module (guix-data-service model git-repository) #:use-module (guix-data-service 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,17 +120,16 @@
(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) branch-name
branch-name #:limit (assq-ref parsed-query-parameters 'limit_results)
#:limit (assq-ref parsed-query-parameters 'limit_results) #: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

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

File diff suppressed because it is too large Load Diff

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

@ -25,8 +25,10 @@
#:use-module (web uri) #:use-module (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)))
(lambda () (call-with-sigint
(run-server (lambda (request body) (lambda ()
(run-fibers
(lambda ()
(parameterize
((connection-pool
(make-resource-pool
(lambda ()
(open-postgresql-connection
"web"
postgresql-statement-timeout))
(floor (/ postgresql-connections 2))))
(reserved-connection-pool
(make-resource-pool
(lambda ()
(open-postgresql-connection
"web-reserved"
postgresql-statement-timeout))
(floor (/ postgresql-connections 2))))
(resource-pool-default-timeout 10))
(with-exception-handler
(lambda (exn)
(simple-format
(current-error-port)
"\n
error: guix-data-service could not start: ~A
Check if it's already running, or whether another process is using that
port. Also, the port used can be changed by passing the --port option.\n"
exn)
(primitive-exit 1))
(lambda ()
(run-server/patched
(lambda (request body)
(handler request body controller (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)))))