[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
05/06: Completely rework the way db connections are handled during reque
|
From: |
Christopher Baines |
|
Subject: |
05/06: Completely rework the way db connections are handled during requests |
|
Date: |
Sat, 3 Oct 2020 16:43:18 -0400 (EDT) |
cbaines pushed a commit to branch master
in repository data-service.
commit c3c9c07f9a208633882a21004d30c5ee29026cb1
Author: Christopher Baines <mail@cbaines.net>
AuthorDate: Sat Oct 3 21:35:31 2020 +0100
Completely rework the way db connections are handled during requests
Previously, a connection was passed through the code handling the
request. When queries were performed, this could block the thread though,
potentially leaving the server unable to serve other requests.
Instead, this now runs queries in a pool of threads. This should remove the
possibility of blocking the threads used by the web server, and in doing so,
some of the queries have been parallelised.
I''m still not sure about the naming and syntax, but I think the
functionality
is a sort of step forward.
---
guix-data-service/web/build-server/controller.scm | 105 +-
guix-data-service/web/build/controller.scm | 61 +-
guix-data-service/web/compare/controller.scm | 740 ++++++++------
guix-data-service/web/controller.scm | 521 ++++++----
guix-data-service/web/dumps/controller.scm | 3 +-
guix-data-service/web/jobs/controller.scm | 69 +-
guix-data-service/web/nar/controller.scm | 108 +-
guix-data-service/web/repository/controller.scm | 411 ++++----
guix-data-service/web/revision/controller.scm | 1131 ++++++++++++---------
9 files changed, 1777 insertions(+), 1372 deletions(-)
diff --git a/guix-data-service/web/build-server/controller.scm
b/guix-data-service/web/build-server/controller.scm
index 8eb5e7a..9c185c6 100644
--- a/guix-data-service/web/build-server/controller.scm
+++ b/guix-data-service/web/build-server/controller.scm
@@ -20,6 +20,7 @@
#:use-module (ice-9 match)
#:use-module (rnrs bytevectors)
#:use-module (json)
+ #:use-module (guix-data-service utils)
#:use-module (guix-data-service database)
#:use-module (guix-data-service web render)
#:use-module (guix-data-service web query-parameters)
@@ -36,7 +37,6 @@
#:export (build-server-controller))
(define (render-build mime-types
- conn
build-server-id
query-parameters)
(if (any-invalid-query-parameters? query-parameters)
@@ -56,15 +56,18 @@
(build-server-build-id
(assq-ref query-parameters 'build_server_build_id))
(build
- (if build-server-build-id
- (select-build-by-build-server-and-build-server-build-id
- conn
- build-server-id
- build-server-build-id)
- (select-build-by-build-server-and-derivation-file-name
- conn
- build-server-id
- derivation-file-name))))
+ (parallel-via-thread-pool-channel
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (if build-server-build-id
+ (select-build-by-build-server-and-build-server-build-id
+ conn
+ build-server-id
+ build-server-build-id)
+ (select-build-by-build-server-and-derivation-file-name
+ conn
+ build-server-id
+ derivation-file-name)))))))
(if build
(render-html
#:sxml
@@ -80,10 +83,13 @@
; guix-build-coordinator
; doesn't mark builds as
; failed-dependency
- (select-required-builds-that-failed
- conn
- build-server-id
- derivation-file-name)
+ (parallel-via-thread-pool-channel
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-required-builds-that-failed
+ conn
+ build-server-id
+ derivation-file-name))))
#f)))))
(render-html
#:sxml (general-not-found
@@ -106,12 +112,11 @@
(define (handle-build-event-submission parsed-query-parameters
build-server-id-string
body
- conn
secret-key-base)
(define build-server-id
(string->number build-server-id-string))
- (define (handle-derivation-events items)
+ (define (handle-derivation-events conn items)
(unless (null? items)
(let ((build-ids
(insert-builds conn
@@ -132,30 +137,38 @@
items)))))
(define (process-items items)
- (with-postgresql-transaction
- conn
- (lambda (conn)
- (handle-derivation-events
- (filter (lambda (item)
- (let ((type (assoc-ref item "type")))
- (if type
- (string=? type "build")
- (begin
- (simple-format (current-error-port)
- "warning: unknown type for event:
~A\n"
- item)
- #f))))
- items)))))
+ (parallel-via-thread-pool-channel
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (with-postgresql-transaction
+ conn
+ (lambda (conn)
+ (handle-derivation-events
+ conn
+ (filter (lambda (item)
+ (let ((type (assoc-ref item "type")))
+ (if type
+ (string=? type "build")
+ (begin
+ (simple-format
+ (current-error-port)
+ "warning: unknown type for event: ~A\n"
+ item)
+ #f))))
+ items))))))))
(if (any-invalid-query-parameters? parsed-query-parameters)
(render-json
'((error . "no token provided"))
#:code 400)
(let ((provided-token (assq-ref parsed-query-parameters 'token))
- (permitted-tokens (compute-tokens-for-build-server
- conn
- secret-key-base
- build-server-id)))
+ (permitted-tokens
+ (parallel-via-thread-pool-channel
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (compute-tokens-for-build-server conn
+ secret-key-base
+ build-server-id))))))
(if (member provided-token
(map cdr permitted-tokens)
string=?)
@@ -201,25 +214,32 @@
'((error . "error"))
#:code 403)))))
-(define (handle-signing-key-request conn id)
+(define (handle-signing-key-request id)
(render-html
#:sxml (view-signing-key
- (select-signing-key conn id))))
+ (parallel-via-thread-pool-channel
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-signing-key conn id)))))))
(define (build-server-controller request
method-and-path-components
mime-types
body
- conn
secret-key-base)
(match method-and-path-components
(('GET "build-servers")
- (let ((build-servers (select-build-servers conn)))
+ (letpar& ((build-servers
+ (with-thread-postgresql-connection
+ select-build-servers)))
(render-build-servers mime-types
build-servers)))
(('GET "build-server" build-server-id)
- (let ((build-server (select-build-server conn (string->number
- build-server-id))))
+ (letpar& ((build-server
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-build-server conn (string->number
+ build-server-id))))))
(if build-server
(render-build-server mime-types
build-server)
@@ -231,7 +251,6 @@
`((derivation_file_name ,identity)
(build_server_build_id ,identity)))))
(render-build mime-types
- conn
(string->number build-server-id)
parsed-query-parameters)))
(('POST "build-server" build-server-id "build-events")
@@ -242,9 +261,7 @@
(handle-build-event-submission parsed-query-parameters
build-server-id
body
- conn
secret-key-base)))
(('GET "build-server" "signing-key" id)
- (handle-signing-key-request conn
- (string->number id)))
+ (handle-signing-key-request (string->number id)))
(_ #f)))
diff --git a/guix-data-service/web/build/controller.scm
b/guix-data-service/web/build/controller.scm
index 78a89e7..b573a26 100644
--- a/guix-data-service/web/build/controller.scm
+++ b/guix-data-service/web/build/controller.scm
@@ -18,6 +18,8 @@
(define-module (guix-data-service web build controller)
#:use-module (srfi srfi-1)
#:use-module (ice-9 match)
+ #:use-module (guix-data-service utils)
+ #:use-module (guix-data-service database)
#:use-module (guix-data-service web render)
#:use-module (guix-data-service web query-parameters)
#:use-module (guix-data-service model build)
@@ -34,9 +36,11 @@
(string-append "unknown build status: "
status))))
-(define (parse-build-server conn)
+(define parse-build-server
(lambda (v)
- (let ((build-servers (select-build-servers conn)))
+ (letpar& ((build-servers
+ (with-thread-postgresql-connection
+ select-build-servers)))
(or (any (match-lambda
((id url lookup-all-derivations? lookup-builds?)
(if (eq? (string->number v)
@@ -51,21 +55,19 @@
(define (build-controller request
method-and-path-components
mime-types
- body
- conn)
+ body)
(match method-and-path-components
(('GET "builds")
(render-builds request
- mime-types
- conn))
+ mime-types))
(_ #f)))
-(define (render-builds request mime-types conn)
+(define (render-builds request mime-types)
(let ((parsed-query-parameters
(parse-query-parameters
request
`((build_status ,parse-build-status #:multi-value)
- (build_server ,(parse-build-server conn) #:multi-value)))))
+ (build_server ,parse-build-server #:multi-value)))))
(if (any-invalid-query-parameters? parsed-query-parameters)
(render-html
#:sxml (view-builds parsed-query-parameters
@@ -73,20 +75,29 @@
'()
'()
'()))
- (render-html
- #:sxml (view-builds parsed-query-parameters
- build-status-strings
- (map (match-lambda
- ((id url lookup-all-derivations
lookup-builds)
- (cons url id)))
- (select-build-servers conn))
- (select-build-stats
- conn
- (assq-ref parsed-query-parameters
- 'build_server))
- (select-builds-with-context
- conn
- (assq-ref parsed-query-parameters
- 'build_status)
- (assq-ref parsed-query-parameters
- 'build_server)))))))
+ (letpar& ((build-servers
+ (with-thread-postgresql-connection
+ select-build-servers))
+ (build-stats
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-build-stats
+ conn
+ (assq-ref parsed-query-parameters
+ 'build_server)))))
+ (builds-with-context
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-builds-with-context
+ conn
+ (assq-ref parsed-query-parameters
+ 'build_status)
+ (assq-ref parsed-query-parameters
+ 'build_server))))))
+
+ (render-html
+ #:sxml (view-builds parsed-query-parameters
+ build-status-strings
+ build-servers
+ build-stats
+ builds-with-context))))))
diff --git a/guix-data-service/web/compare/controller.scm
b/guix-data-service/web/compare/controller.scm
index c3db5e2..636de67 100644
--- a/guix-data-service/web/compare/controller.scm
+++ b/guix-data-service/web/compare/controller.scm
@@ -23,6 +23,8 @@
#:use-module (texinfo)
#:use-module (texinfo html)
#:use-module (texinfo plain-text)
+ #:use-module (guix-data-service utils)
+ #:use-module (guix-data-service database)
#:use-module (guix-data-service web sxml)
#:use-module (guix-data-service web util)
#:use-module (guix-data-service web render)
@@ -48,35 +50,37 @@
(define (parse-build-status s)
s)
-(define (parse-commit conn)
- (lambda (s)
- (if (guix-commit-exists? conn s)
- s
- (make-invalid-query-parameter
- s "unknown commit"))))
+(define (parse-commit s)
+ (if (parallel-via-thread-pool-channel
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (guix-commit-exists? conn s))))
+ s
+ (make-invalid-query-parameter
+ s "unknown commit")))
-(define (parse-derivation conn)
- (lambda (file-name)
- (if (select-derivation-by-file-name conn file-name)
- file-name
- (make-invalid-query-parameter
- file-name "unknown derivation"))))
+(define (parse-derivation file-name)
+ (if (parallel-via-thread-pool-channel
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-derivation-by-file-name conn file-name))))
+ file-name
+ (make-invalid-query-parameter
+ file-name "unknown derivation")))
(define (compare-controller request
method-and-path-components
mime-types
- body
- conn)
+ body)
(match method-and-path-components
(('GET "compare")
(let* ((parsed-query-parameters
(parse-query-parameters
request
- `((base_commit ,(parse-commit conn) #:required)
- (target_commit ,(parse-commit conn) #:required)
+ `((base_commit ,parse-commit #:required)
+ (target_commit ,parse-commit #:required)
(locale ,identity #:default "en_US.UTF-8")))))
(render-compare mime-types
- conn
parsed-query-parameters)))
(('GET "compare-by-datetime")
(let* ((parsed-query-parameters
@@ -88,28 +92,25 @@
(target_datetime ,parse-datetime #:required)
(locale ,identity #:default "en_US.UTF-8")))))
(render-compare-by-datetime mime-types
- conn
parsed-query-parameters)))
(('GET "compare" "derivation")
(let* ((parsed-query-parameters
(parse-query-parameters
request
- `((base_derivation ,(parse-derivation conn) #:required)
- (target_derivation ,(parse-derivation conn) #:required)))))
+ `((base_derivation ,parse-derivation #:required)
+ (target_derivation ,parse-derivation #:required)))))
(render-compare/derivation mime-types
- conn
parsed-query-parameters)))
(('GET "compare" "derivations")
(let* ((parsed-query-parameters
(parse-query-parameters
request
- `((base_commit ,(parse-commit conn) #:required)
- (target_commit ,(parse-commit conn) #:required)
+ `((base_commit ,parse-commit #:required)
+ (target_commit ,parse-commit #:required)
(system ,parse-system #:multi-value)
(target ,parse-target #:multi-value)
(build_status ,parse-build-status #:multi-value)))))
(render-compare/derivations mime-types
- conn
parsed-query-parameters)))
(('GET "compare-by-datetime" "derivations")
(let* ((parsed-query-parameters
@@ -126,17 +127,15 @@
'((base_commit base_datetime)
(target_commit target_datetime)))))
(render-compare-by-datetime/derivations mime-types
- conn
parsed-query-parameters)))
(('GET "compare" "packages")
(let* ((parsed-query-parameters
(parse-query-parameters
request
- `((base_commit ,(parse-commit conn) #:required)
- (target_commit ,(parse-commit conn) #:required)))))
+ `((base_commit ,parse-commit #:required)
+ (target_commit ,parse-commit #:required)))))
(render-compare/packages mime-types
- conn
- parsed-query-parameters)))
+ parsed-query-parameters)))
(_ #f)))
(define (texinfo->variants-alist s)
@@ -148,16 +147,7 @@
(plain . ,(stexi->plain-text stexi)))))
(define (render-compare mime-types
- conn
query-parameters)
- (define lint-warnings-locale-options
- (map
- (match-lambda
- ((locale)
- locale))
- (lint-warning-message-locales-for-revision
- conn (assq-ref query-parameters 'target_commit))))
-
(if (any-invalid-query-parameters? query-parameters)
(case (most-appropriate-mime-type
'(application/json text/html)
@@ -166,195 +156,79 @@
(render-json
'((error . "invalid query"))))
(else
- (render-html
- #:sxml (compare-invalid-parameters
- query-parameters
- (match (assq-ref query-parameters 'base_commit)
- (($ <invalid-query-parameter> value)
- (select-job-for-commit conn value))
- (_ #f))
- (match (assq-ref query-parameters 'target_commit)
- (($ <invalid-query-parameter> value)
- (select-job-for-commit conn value))
- (_ #f))))))
+ (letpar& ((base-job
+ (match (assq-ref query-parameters 'base_commit)
+ (($ <invalid-query-parameter> value)
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-job-for-commit conn value))))
+ (_ #f)))
+ (target-job
+ (match (assq-ref query-parameters 'target_commit)
+ (($ <invalid-query-parameter> value)
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-job-for-commit conn value))))
+ (_ #f))))
+ (render-html
+ #:sxml (compare-invalid-parameters
+ query-parameters
+ base-job
+ target-job)))))
- (let ((base-revision-id (commit->revision-id
- conn
- (assq-ref query-parameters 'base_commit)))
- (target-revision-id (commit->revision-id
- conn
- (assq-ref query-parameters 'target_commit)))
- (locale (assq-ref query-parameters 'locale)))
+ (letpar& ((base-revision-id
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (commit->revision-id
+ conn
+ (assq-ref query-parameters 'base_commit)))))
+ (target-revision-id
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (commit->revision-id
+ conn
+ (assq-ref query-parameters 'target_commit)))))
+ (locale
+ (assq-ref query-parameters 'locale)))
(let-values
(((base-packages-vhash target-packages-vhash)
(package-data->package-data-vhashes
- (package-differences-data conn
- base-revision-id
- target-revision-id))))
- (let* ((new-packages
- (package-data-vhashes->new-packages base-packages-vhash
- target-packages-vhash))
- (removed-packages
- (package-data-vhashes->removed-packages base-packages-vhash
-
target-packages-vhash))
- (version-changes
- (package-data-version-changes base-packages-vhash
- target-packages-vhash))
- (lint-warnings-data
- (group-list-by-first-n-fields
- 2
- (lint-warning-differences-data conn
- base-revision-id
- target-revision-id
- locale)))
- (channel-news-data
- (channel-news-differences-data conn
- base-revision-id
- target-revision-id)))
- (case (most-appropriate-mime-type
- '(application/json text/html)
- mime-types)
- ((application/json)
- (render-json
- `((channel-news . ,(list->vector
- (map
- (match-lambda
- ((commit tag title_text body_text
change)
- `(,@(if (null? commit)
- '()
- `((commit . ,commit)))
- ,@(if (null? tag)
- '()
- `((tag . ,tag)))
- (title-text
- . ,(map
- (match-lambda
- ((lang . text)
- (cons
- lang
- (texinfo->variants-alist
text))))
- title_text))
- (body-text
- . ,(map
- (match-lambda
- ((lang . text)
- (cons
- lang
- (texinfo->variants-alist
text))))
- body_text))
- (change . ,change))))
- channel-news-data)))
- (new-packages . ,(list->vector new-packages))
- (removed-packages . ,(list->vector removed-packages))
- (version-changes . ,(list->vector
- (map
- (match-lambda
- ((name data ...)
- `((name . ,name)
- ,@data)))
- version-changes))))
- #:extra-headers http-headers-for-unchanging-content))
- (else
- (render-html
- #:sxml (compare query-parameters
- (guix-revisions-cgit-url-bases
- conn
- (list base-revision-id
- target-revision-id))
- new-packages
- removed-packages
- version-changes
- lint-warnings-data
- lint-warnings-locale-options
- channel-news-data)
- #:extra-headers http-headers-for-unchanging-content))))))))
-
-(define (render-compare-by-datetime mime-types
- conn
- query-parameters)
- (if (any-invalid-query-parameters? query-parameters)
- (case (most-appropriate-mime-type
- '(application/json text/html)
- mime-types)
- ((application/json)
- (render-json
- '((error . "invalid query"))))
- (else
- (render-html
- #:sxml (compare-invalid-parameters
- query-parameters
- (match (assq-ref query-parameters 'base_commit)
- (($ <invalid-query-parameter> value)
- (select-job-for-commit conn value))
- (_ #f))
- (match (assq-ref query-parameters 'target_commit)
- (($ <invalid-query-parameter> value)
- (select-job-for-commit conn value))
- (_ #f))))))
-
- (let ((base-branch (assq-ref query-parameters 'base_branch))
- (base-datetime (assq-ref query-parameters 'base_datetime))
- (target-branch (assq-ref query-parameters 'target_branch))
- (target-datetime (assq-ref query-parameters 'target_datetime))
- (locale (assq-ref query-parameters 'locale)))
- (let* ((base-revision-details
- (select-guix-revision-for-branch-and-datetime conn
- base-branch
- base-datetime))
- (lint-warnings-locale-options
- (map
- (match-lambda
- ((locale)
- locale))
- (lint-warning-message-locales-for-revision
- conn (second base-revision-details))))
- (base-revision-id
- (first base-revision-details))
- (target-revision-details
- (select-guix-revision-for-branch-and-datetime conn
- target-branch
- target-datetime))
- (target-revision-id
- (first target-revision-details)))
- (let-values
- (((base-packages-vhash target-packages-vhash)
- (package-data->package-data-vhashes
- (package-differences-data conn
- base-revision-id
- target-revision-id))))
- (let* ((new-packages
- (package-data-vhashes->new-packages base-packages-vhash
- target-packages-vhash))
- (removed-packages
- (package-data-vhashes->removed-packages base-packages-vhash
-
target-packages-vhash))
- (version-changes
- (package-data-version-changes base-packages-vhash
- target-packages-vhash))
- (lint-warnings-data
- (group-list-by-first-n-fields
- 2
- (lint-warning-differences-data conn
- base-revision-id
- target-revision-id
- locale)))
- (channel-news-data
- (channel-news-differences-data conn
- base-revision-id
- target-revision-id)))
+ (parallel-via-thread-pool-channel
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (package-differences-data conn
+ base-revision-id
+ target-revision-id)))))))
+ (let ((new-packages
+ (package-data-vhashes->new-packages base-packages-vhash
+ target-packages-vhash))
+ (removed-packages
+ (package-data-vhashes->removed-packages base-packages-vhash
+
target-packages-vhash))
+ (version-changes
+ (package-data-version-changes base-packages-vhash
+ target-packages-vhash)))
+ (letpar& ((lint-warnings-data
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (group-list-by-first-n-fields
+ 2
+ (lint-warning-differences-data conn
+ base-revision-id
+ target-revision-id
+ locale)))))
+ (channel-news-data
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (channel-news-differences-data conn
+ base-revision-id
+
target-revision-id)))))
(case (most-appropriate-mime-type
'(application/json text/html)
mime-types)
((application/json)
(render-json
- `((revisions
- . ((base
- . ((commit . ,(second base-revision-details))
- (datetime . ,(fifth base-revision-details))))
- (target
- . ((commit . ,(second target-revision-details))
- (datetime . ,(fifth target-revision-details))))))
- (channel-news . ,(list->vector
+ `((channel-news . ,(list->vector
(map
(match-lambda
((commit tag title_text body_text
change)
@@ -393,24 +267,202 @@
version-changes))))
#:extra-headers http-headers-for-unchanging-content))
(else
- (render-html
- #:sxml (compare `(,@query-parameters
- (base_commit . ,(second
base-revision-details))
- (target_commit . ,(second
target-revision-details)))
- (guix-revisions-cgit-url-bases
- conn
- (list base-revision-id
- target-revision-id))
- new-packages
- removed-packages
- version-changes
- lint-warnings-data
- lint-warnings-locale-options
- channel-news-data)
- #:extra-headers http-headers-for-unchanging-content)))))))))
+ (letpar& ((lint-warnings-locale-options
+ (map
+ (match-lambda
+ ((locale)
+ locale))
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (lint-warning-message-locales-for-revision
+ conn
+ (assq-ref query-parameters
'target_commit))))))
+ (cgit-url-bases
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (guix-revisions-cgit-url-bases
+ conn
+ (list base-revision-id
+ target-revision-id))))))
+ (render-html
+ #:sxml (compare query-parameters
+ cgit-url-bases
+ new-packages
+ removed-packages
+ version-changes
+ lint-warnings-data
+ lint-warnings-locale-options
+ channel-news-data)
+ #:extra-headers
http-headers-for-unchanging-content))))))))))
+
+(define (render-compare-by-datetime mime-types
+ query-parameters)
+ (if (any-invalid-query-parameters? query-parameters)
+ (case (most-appropriate-mime-type
+ '(application/json text/html)
+ mime-types)
+ ((application/json)
+ (render-json
+ '((error . "invalid query"))))
+ (else
+ (letpar& ((base-job
+ (match (assq-ref query-parameters 'base_commit)
+ (($ <invalid-query-parameter> value)
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-job-for-commit conn value))))
+ (_ #f)))
+ (target-job
+ (match (assq-ref query-parameters 'target_commit)
+ (($ <invalid-query-parameter> value)
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-job-for-commit conn value))))
+ (_ #f))))
+ (render-html
+ #:sxml (compare-invalid-parameters
+ query-parameters
+ base-job
+ target-job)))))
+
+ (let ((base-branch (assq-ref query-parameters 'base_branch))
+ (base-datetime (assq-ref query-parameters 'base_datetime))
+ (target-branch (assq-ref query-parameters 'target_branch))
+ (target-datetime (assq-ref query-parameters 'target_datetime))
+ (locale (assq-ref query-parameters 'locale)))
+ (letpar& ((base-revision-details
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-guix-revision-for-branch-and-datetime
+ conn
+ base-branch
+ base-datetime))))
+ (target-revision-details
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-guix-revision-for-branch-and-datetime
+ conn
+ target-branch
+ target-datetime)))))
+ (letpar& ((lint-warnings-locale-options
+ (map
+ (match-lambda
+ ((locale)
+ locale))
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (lint-warning-message-locales-for-revision
+ conn
+ (second base-revision-details)))))))
+ (let ((base-revision-id
+ (first base-revision-details))
+ (target-revision-id
+ (first target-revision-details)))
+ (let-values
+ (((base-packages-vhash target-packages-vhash)
+ (package-data->package-data-vhashes
+ (parallel-via-thread-pool-channel
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (package-differences-data conn
+ base-revision-id
+ target-revision-id)))))))
+ (let* ((new-packages
+ (package-data-vhashes->new-packages base-packages-vhash
+
target-packages-vhash))
+ (removed-packages
+ (package-data-vhashes->removed-packages
base-packages-vhash
+
target-packages-vhash))
+ (version-changes
+ (package-data-version-changes base-packages-vhash
+ target-packages-vhash))
+ (channel-news-data
+ (parallel-via-thread-pool-channel
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (channel-news-differences-data conn
+ base-revision-id
+
target-revision-id))))))
+ (case (most-appropriate-mime-type
+ '(application/json text/html)
+ mime-types)
+ ((application/json)
+ (render-json
+ `((revisions
+ . ((base
+ . ((commit . ,(second base-revision-details))
+ (datetime . ,(fifth base-revision-details))))
+ (target
+ . ((commit . ,(second target-revision-details))
+ (datetime . ,(fifth
target-revision-details))))))
+ (channel-news . ,(list->vector
+ (map
+ (match-lambda
+ ((commit tag title_text body_text
change)
+ `(,@(if (null? commit)
+ '()
+ `((commit . ,commit)))
+ ,@(if (null? tag)
+ '()
+ `((tag . ,tag)))
+ (title-text
+ . ,(map
+ (match-lambda
+ ((lang . text)
+ (cons
+ lang
+
(texinfo->variants-alist text))))
+ title_text))
+ (body-text
+ . ,(map
+ (match-lambda
+ ((lang . text)
+ (cons
+ lang
+
(texinfo->variants-alist text))))
+ body_text))
+ (change . ,change))))
+ channel-news-data)))
+ (new-packages . ,(list->vector new-packages))
+ (removed-packages . ,(list->vector removed-packages))
+ (version-changes . ,(list->vector
+ (map
+ (match-lambda
+ ((name data ...)
+ `((name . ,name)
+ ,@data)))
+ version-changes))))
+ #:extra-headers http-headers-for-unchanging-content))
+ (else
+ (render-html
+ #:sxml (compare `(,@query-parameters
+ (base_commit . ,(second
base-revision-details))
+ (target_commit . ,(second
target-revision-details)))
+ (parallel-via-thread-pool-channel
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (guix-revisions-cgit-url-bases
+ conn
+ (list base-revision-id
+ target-revision-id)))))
+ new-packages
+ removed-packages
+ version-changes
+ (parallel-via-thread-pool-channel
+ (group-list-by-first-n-fields
+ 2
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (lint-warning-differences-data
+ conn
+ base-revision-id
+ target-revision-id
+ locale)))))
+ lint-warnings-locale-options
+ channel-news-data)
+ #:extra-headers
http-headers-for-unchanging-content)))))))))))
(define (render-compare/derivation mime-types
- conn
query-parameters)
(if (any-invalid-query-parameters? query-parameters)
(case (most-appropriate-mime-type
@@ -427,10 +479,12 @@
(let ((base-derivation (assq-ref query-parameters 'base_derivation))
(target-derivation (assq-ref query-parameters
'target_derivation)))
- (let ((data
- (derivation-differences-data conn
- base-derivation
- target-derivation)))
+ (letpar& ((data
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (derivation-differences-data conn
+ base-derivation
+ target-derivation)))))
(case (most-appropriate-mime-type
'(application/json text/html)
mime-types)
@@ -446,7 +500,6 @@
#:extra-headers http-headers-for-unchanging-content)))))))
(define (render-compare/derivations mime-types
- conn
query-parameters)
(define (derivations->alist derivations)
(map (match-lambda
@@ -470,7 +523,8 @@
(render-html
#:sxml (compare/derivations
query-parameters
- (valid-systems conn)
+ (parallel-via-thread-pool-channel
+ (with-thread-postgresql-connection valid-systems))
build-status-strings
'()))))
@@ -479,41 +533,42 @@
(systems (assq-ref query-parameters 'system))
(targets (assq-ref query-parameters 'target))
(build-statuses (assq-ref query-parameters 'build_status)))
- (let*
- ((data
- (package-derivation-differences-data
- conn
- (commit->revision-id conn base-commit)
- (commit->revision-id conn target-commit)
- #:systems systems
- #:targets targets))
- (names-and-versions
- (package-derivation-data->names-and-versions data)))
- (let-values
- (((base-packages-vhash target-packages-vhash)
- (package-derivation-data->package-derivation-data-vhashes
data)))
- (let ((derivation-changes
- (package-derivation-data-changes names-and-versions
- base-packages-vhash
- target-packages-vhash)))
- (case (most-appropriate-mime-type
- '(application/json text/html)
- mime-types)
- ((application/json)
- (render-json
- derivation-changes
- #:extra-headers http-headers-for-unchanging-content))
- (else
- (render-html
- #:sxml (compare/derivations
- query-parameters
- (valid-systems conn)
- build-status-strings
- derivation-changes)
- #:extra-headers http-headers-for-unchanging-content)))))))))
+ (letpar& ((data
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (package-derivation-differences-data
+ conn
+ (commit->revision-id conn base-commit)
+ (commit->revision-id conn target-commit)
+ #:systems systems
+ #:targets targets)))))
+ (let ((names-and-versions
+ (package-derivation-data->names-and-versions data)))
+ (let-values
+ (((base-packages-vhash target-packages-vhash)
+ (package-derivation-data->package-derivation-data-vhashes
data)))
+ (let ((derivation-changes
+ (package-derivation-data-changes names-and-versions
+ base-packages-vhash
+ target-packages-vhash)))
+ (case (most-appropriate-mime-type
+ '(application/json text/html)
+ mime-types)
+ ((application/json)
+ (render-json
+ derivation-changes
+ #:extra-headers http-headers-for-unchanging-content))
+ (else
+ (render-html
+ #:sxml (compare/derivations
+ query-parameters
+ (parallel-via-thread-pool-channel
+ (with-thread-postgresql-connection valid-systems))
+ build-status-strings
+ derivation-changes)
+ #:extra-headers
http-headers-for-unchanging-content))))))))))
(define (render-compare-by-datetime/derivations mime-types
- conn
query-parameters)
(define (derivations->alist derivations)
(map (match-lambda
@@ -537,7 +592,8 @@
(render-html
#:sxml (compare-by-datetime/derivations
query-parameters
- (valid-systems conn)
+ (parallel-via-thread-pool-channel
+ (with-thread-postgresql-connection valid-systems))
build-status-strings
'()
'()
@@ -550,50 +606,58 @@
(systems (assq-ref query-parameters 'system))
(targets (assq-ref query-parameters 'target))
(build-statuses (assq-ref query-parameters 'build_status)))
- (let*
+ (letpar&
((base-revision-details
- (select-guix-revision-for-branch-and-datetime conn
- base-branch
- base-datetime))
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-guix-revision-for-branch-and-datetime conn
+ base-branch
+
base-datetime))))
(target-revision-details
- (select-guix-revision-for-branch-and-datetime conn
- target-branch
- target-datetime))
- (data
- (package-derivation-differences-data conn
- (first
base-revision-details)
- (first
target-revision-details)
- #:systems systems
- #:targets targets))
- (names-and-versions
- (package-derivation-data->names-and-versions data)))
- (let-values
- (((base-packages-vhash target-packages-vhash)
- (package-derivation-data->package-derivation-data-vhashes
data)))
- (let ((derivation-changes
- (package-derivation-data-changes names-and-versions
- base-packages-vhash
- target-packages-vhash)))
- (case (most-appropriate-mime-type
- '(application/json text/html)
- mime-types)
- ((application/json)
- (render-json
- derivation-changes
- #:extra-headers http-headers-for-unchanging-content))
- (else
- (render-html
- #:sxml (compare-by-datetime/derivations
- query-parameters
- (valid-systems conn)
- build-status-strings
- base-revision-details
- target-revision-details
- derivation-changes)
- #:extra-headers http-headers-for-unchanging-content)))))))))
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-guix-revision-for-branch-and-datetime conn
+ target-branch
+
target-datetime)))))
+ (letpar&
+ ((data
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (package-derivation-differences-data
+ conn
+ (first base-revision-details)
+ (first target-revision-details)
+ #:systems systems
+ #:targets targets)))))
+ (let ((names-and-versions
+ (package-derivation-data->names-and-versions data)))
+ (let-values
+ (((base-packages-vhash target-packages-vhash)
+ (package-derivation-data->package-derivation-data-vhashes
data)))
+ (let ((derivation-changes
+ (package-derivation-data-changes names-and-versions
+ base-packages-vhash
+
target-packages-vhash)))
+ (case (most-appropriate-mime-type
+ '(application/json text/html)
+ mime-types)
+ ((application/json)
+ (render-json
+ derivation-changes
+ #:extra-headers http-headers-for-unchanging-content))
+ (else
+ (render-html
+ #:sxml (compare-by-datetime/derivations
+ query-parameters
+ (parallel-via-thread-pool-channel
+ (with-thread-postgresql-connection
valid-systems))
+ build-status-strings
+ base-revision-details
+ target-revision-details
+ derivation-changes)
+ #:extra-headers
http-headers-for-unchanging-content)))))))))))
(define (render-compare/packages mime-types
- conn
query-parameters)
(define (package-data-vhash->json vh)
(delete-duplicates
@@ -612,29 +676,49 @@
(render-json
'((error . "invalid query"))))
(else
+ (letpar& ((base-job
+ (match (assq-ref query-parameters 'base_commit)
+ (($ <invalid-query-parameter> value)
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-job-for-commit conn value))))
+ (_ #f)))
+ (target-job
+ (match (assq-ref query-parameters 'target_commit)
+ (($ <invalid-query-parameter> value)
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-job-for-commit conn value))))
+ (_ #f))))
(render-html
#:sxml (compare-invalid-parameters
query-parameters
- (match (assq-ref query-parameters 'base_commit)
- (($ <invalid-query-parameter> value)
- (select-job-for-commit conn value))
- (_ #f))
- (match (assq-ref query-parameters 'target_commit)
- (($ <invalid-query-parameter> value)
- (select-job-for-commit conn value))
- (_ #f))))))
+ base-job
+ target-job)))))
(let ((base-commit (assq-ref query-parameters 'base_commit))
(target-commit (assq-ref query-parameters 'target_commit)))
- (let ((base-revision-id (commit->revision-id conn base-commit))
- (target-revision-id (commit->revision-id conn target-commit)))
-
+ (letpar& ((base-revision-id
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (commit->revision-id
+ conn
+ base-commit))))
+ (target-revision-id
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (commit->revision-id
+ conn
+ target-commit)))))
(let-values
(((base-packages-vhash target-packages-vhash)
(package-data->package-data-vhashes
- (package-differences-data conn
- base-revision-id
- target-revision-id))))
+ (parallel-via-thread-pool-channel
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (package-differences-data conn
+ base-revision-id
+ target-revision-id)))))))
(case (most-appropriate-mime-type
'(application/json text/html)
mime-types)
diff --git a/guix-data-service/web/controller.scm
b/guix-data-service/web/controller.scm
index a8a8696..cf751ad 100644
--- a/guix-data-service/web/controller.scm
+++ b/guix-data-service/web/controller.scm
@@ -19,6 +19,7 @@
(define-module (guix-data-service web controller)
#:use-module (ice-9 match)
#:use-module (ice-9 vlist)
+ #:use-module (ice-9 threads)
#:use-module (ice-9 pretty-print)
#:use-module (ice-9 textual-ports)
#:use-module (ice-9 string-fun)
@@ -35,6 +36,7 @@
#:use-module (squee)
#:use-module (json)
#:use-module (prometheus)
+ #:use-module (guix-data-service utils)
#:use-module (guix-data-service config)
#:use-module (guix-data-service comparison)
#:use-module (guix-data-service database)
@@ -129,8 +131,20 @@
"_"))
#:labels '(name))))
pg-stat-fields)))
- (lambda (conn)
- (let ((metric-values (fetch-high-level-table-size-metrics conn)))
+ (lambda ()
+ (letpar& ((metric-values
+ (with-thread-postgresql-connection
+ fetch-high-level-table-size-metrics))
+ (guix-revisions-count
+ (with-thread-postgresql-connection
+ count-guix-revisions))
+ (pg-stat-user-tables-metrics
+ (with-thread-postgresql-connection
+ fetch-pg-stat-user-tables-metrics))
+ (load-new-guix-revision-job-metrics
+ (with-thread-postgresql-connection
+ select-load-new-guix-revision-job-metrics)))
+
(for-each (match-lambda
((name row-estimate table-bytes index-bytes toast-bytes)
@@ -146,54 +160,66 @@
(metric-set table-toast-bytes-metric
toast-bytes
#:label-values `((name . ,name)))))
- metric-values))
-
- (metric-set revisions-count-metric
- (count-guix-revisions conn))
-
- (map (lambda (field-values)
- (let ((name (assq-ref field-values 'name)))
- (for-each
- (match-lambda
- (('name . _) #f)
- ((field . value)
- (let ((metric (or (assq-ref pg-stat-metrics field)
- (error field))))
- (metric-set metric
- value
- #:label-values `((name . ,name))))))
- field-values)))
- (fetch-pg-stat-user-tables-metrics conn))
-
- (for-each (match-lambda
- ((repository-label completed count)
- (metric-set
- load-new-guix-revision-job-count
- count
- #:label-values
- `((repository_label . ,repository-label)
- (completed . ,(if completed "yes" "no"))))))
- (select-load-new-guix-revision-job-metrics conn))
-
- (list (build-response
- #:code 200
- #:headers '((content-type . (text/plain))))
- (lambda (port)
- (write-metrics registry port))))))
-
-(define (render-derivation conn derivation-file-name)
- (let ((derivation (select-derivation-by-file-name conn
- derivation-file-name)))
+ metric-values)
+
+ (metric-set revisions-count-metric
+ guix-revisions-count)
+
+ (map (lambda (field-values)
+ (let ((name (assq-ref field-values 'name)))
+ (for-each
+ (match-lambda
+ (('name . _) #f)
+ ((field . value)
+ (let ((metric (or (assq-ref pg-stat-metrics field)
+ (error field))))
+ (metric-set metric
+ value
+ #:label-values `((name . ,name))))))
+ field-values)))
+ pg-stat-user-tables-metrics)
+
+ (for-each (match-lambda
+ ((repository-label completed count)
+ (metric-set
+ load-new-guix-revision-job-count
+ count
+ #:label-values
+ `((repository_label . ,repository-label)
+ (completed . ,(if completed "yes" "no"))))))
+ load-new-guix-revision-job-metrics)
+
+ (list (build-response
+ #:code 200
+ #:headers '((content-type . (text/plain))))
+ (lambda (port)
+ (write-metrics registry port)))))))
+
+(define (render-derivation derivation-file-name)
+ (letpar& ((derivation
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-derivation-by-file-name conn derivation-file-name)))))
+
(if derivation
- (let ((derivation-inputs (select-derivation-inputs-by-derivation-id
- conn
- (first derivation)))
- (derivation-outputs (select-derivation-outputs-by-derivation-id
- conn
- (first derivation)))
- (builds (select-builds-with-context-by-derivation-file-name
+ (letpar& ((derivation-inputs
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-derivation-inputs-by-derivation-id
+ conn
+ (first derivation)))))
+ (derivation-outputs
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-derivation-outputs-by-derivation-id
conn
- (second derivation))))
+ (first derivation)))))
+ (builds
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-builds-with-context-by-derivation-file-name
+ conn
+ (second derivation))))))
(render-html
#:sxml (view-derivation derivation
derivation-inputs
@@ -207,19 +233,32 @@
"No derivation found with this file name.")
#:code 404))))
-(define (render-json-derivation conn derivation-file-name)
- (let ((derivation (select-derivation-by-file-name conn
- derivation-file-name)))
- (if derivation
- (let ((derivation-inputs (select-derivation-inputs-by-derivation-id
- conn
- (first derivation)))
- (derivation-outputs (select-derivation-outputs-by-derivation-id
- conn
- (first derivation)))
- (derivation-sources (select-derivation-sources-by-derivation-id
- conn
- (first derivation))))
+(define (render-json-derivation derivation-file-name)
+ (let ((derivation
+ (parallel-via-thread-pool-channel
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-derivation-by-file-name conn
+ derivation-file-name))))))
+ (if derivation
+ (letpar& ((derivation-inputs
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-derivation-inputs-by-derivation-id
+ conn
+ (first derivation)))))
+ (derivation-outputs
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-derivation-outputs-by-derivation-id
+ conn
+ (first derivation)))))
+ (derivation-sources
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-derivation-sources-by-derivation-id
+ conn
+ (first derivation))))))
(render-json
`((inputs . ,(list->vector
(map
@@ -255,19 +294,35 @@
env-var))))))))
(render-json '((error . "invalid path"))))))
-(define (render-formatted-derivation conn derivation-file-name)
- (let ((derivation (select-derivation-by-file-name conn
- derivation-file-name)))
+(define (render-formatted-derivation derivation-file-name)
+ (let ((derivation
+ (parallel-via-thread-pool-channel
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-derivation-by-file-name conn
+ derivation-file-name))))))
(if derivation
- (let ((derivation-inputs (select-derivation-inputs-by-derivation-id
- conn
- (first derivation)))
- (derivation-outputs (select-derivation-outputs-by-derivation-id
- conn
- (first derivation)))
- (derivation-sources (select-derivation-sources-by-derivation-id
- conn
- (first derivation))))
+ (letpar& ((derivation-inputs
+ (parallel-via-thread-pool-channel
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-derivation-inputs-by-derivation-id
+ conn
+ (first derivation))))))
+ (derivation-outputs
+ (parallel-via-thread-pool-channel
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-derivation-outputs-by-derivation-id
+ conn
+ (first derivation))))))
+ (derivation-sources
+ (parallel-via-thread-pool-channel
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-derivation-sources-by-derivation-id
+ conn
+ (first derivation)))))))
(render-html
#:sxml (view-formatted-derivation derivation
derivation-inputs
@@ -281,10 +336,14 @@
"No derivation found with this file name.")
#:code 404))))
-(define (render-narinfos conn filename)
- (let ((narinfos (select-nars-for-output
- conn
- (string-append "/gnu/store/" filename))))
+(define (render-narinfos filename)
+ (let ((narinfos
+ (parallel-via-thread-pool-channel
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-nars-for-output
+ conn
+ (string-append "/gnu/store/" filename)))))))
(if (null? narinfos)
(render-html
#:sxml (general-not-found
@@ -295,11 +354,17 @@
(render-html
#:sxml (view-narinfos narinfos)))))
-(define (render-store-item conn filename)
- (let ((derivation (select-derivation-by-output-filename conn filename)))
+(define (render-store-item filename)
+ (letpar& ((derivation
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-derivation-by-output-filename conn filename)))))
(match derivation
(()
- (match (select-derivation-source-file-by-store-path conn filename)
+ (match (parallel-via-thread-pool-channel
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-derivation-source-file-by-store-path conn
filename))))
(()
(render-html
#:sxml (general-not-found
@@ -310,29 +375,52 @@
(render-html
#:sxml (view-derivation-source-file
filename
- (select-derivation-source-file-nar-details-by-file-name conn
-
filename))
+ (parallel-via-thread-pool-channel
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-derivation-source-file-nar-details-by-file-name
+ conn
+ filename)))))
#:extra-headers http-headers-for-unchanging-content))))
(derivations
- (render-html
- #:sxml (view-store-item filename
- derivations
- (map (lambda (derivation)
- (match derivation
- ((file-name output-id rest ...)
- (select-derivations-using-output
- conn output-id))))
- derivations)
- (select-nars-for-output conn
- filename)
-
(select-builds-with-context-by-derivation-output
- conn filename)))))))
-
-(define (render-json-store-item conn filename)
- (let ((derivation (select-derivation-by-output-filename conn filename)))
+ (letpar& ((derivations-using-store-item-list
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (map (lambda (derivation)
+ (match derivation
+ ((file-name output-id rest ...)
+ (select-derivations-using-output
+ conn output-id))))
+ derivations))))
+ (nars
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-nars-for-output conn filename))))
+ (builds
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-builds-with-context-by-derivation-output
+ conn
+ filename)))))
+ (render-html
+ #:sxml (view-store-item filename
+ derivations
+ derivations-using-store-item-list
+ nars
+ builds)))))))
+
+(define (render-json-store-item filename)
+ (let ((derivation
+ (parallel-via-thread-pool-channel
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-derivation-by-output-filename conn filename))))))
(match derivation
(()
- (match (select-derivation-source-file-by-store-path conn filename)
+ (match (parallel-via-thread-pool-channel
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-derivation-source-file-by-store-path conn
filename))))
(()
(render-json '((error . "store item not found"))))
((id)
@@ -343,43 +431,54 @@
(match-lambda
((key . value)
`((,key . ,value))))
- (select-derivation-source-file-nar-details-by-file-name
- conn
- filename)))))))))
+ (parallel-via-thread-pool-channel
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-derivation-source-file-nar-details-by-file-name
+ conn
+ filename))))))))))))
(derivations
- (render-json
- `((nars . ,(list->vector
- (map
- (match-lambda
- ((_ hash _ urls signatures)
- `((hash . ,hash)
- (urls
- . ,(list->vector
- (map
- (lambda (url-data)
- `((size . ,(assoc-ref url-data "size"))
- (compression . ,(assoc-ref url-data
"compression"))
- (url . ,(assoc-ref url-data "url"))))
- urls)))
- (signatures
- . ,(list->vector
- (map
- (lambda (signature)
- `((version . ,(assoc-ref signature
"version"))
- (host-name . ,(assoc-ref signature
"host_name"))))
- signatures))))))
- (select-nars-for-output conn filename))))
- (derivations
- . ,(list->vector
- (map
- (match-lambda
- ((filename output-id)
- `((filename . ,filename)
- (derivations-using-store-item
- . ,(list->vector
- (map car (select-derivations-using-output
- conn output-id)))))))
- derivations)))))))))
+ (letpar& ((nars
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-nars-for-output conn filename)))))
+ (render-json
+ `((nars . ,(list->vector
+ (map
+ (match-lambda
+ ((_ hash _ urls signatures)
+ `((hash . ,hash)
+ (urls
+ . ,(list->vector
+ (map
+ (lambda (url-data)
+ `((size . ,(assoc-ref url-data "size"))
+ (compression . ,(assoc-ref url-data
"compression"))
+ (url . ,(assoc-ref url-data "url"))))
+ urls)))
+ (signatures
+ . ,(list->vector
+ (map
+ (lambda (signature)
+ `((version . ,(assoc-ref signature
"version"))
+ (host-name . ,(assoc-ref signature
"host_name"))))
+ signatures))))))
+ nars)))
+ (derivations
+ . ,(list->vector
+ (map
+ (match-lambda
+ ((filename output-id)
+ `((filename . ,filename)
+ (derivations-using-store-item
+ . ,(list->vector
+ (map car
+ (parallel-via-thread-pool-channel
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-derivations-using-output
+ conn output-id))))))))))
+ derivations))))))))))
(define handle-static-assets
(if assets-dir-in-store?
@@ -393,50 +492,12 @@
mime-types body
secret-key-base)
(define (controller-thunk)
- (match method-and-path-components
- (('GET "assets" rest ...)
- (or (handle-static-assets (string-join rest "/")
- (request-headers request))
- (not-found (request-uri request))))
- (('GET "healthcheck")
- (let ((database-status
- (catch
- #t
- (lambda ()
- (with-postgresql-connection
- "web healthcheck"
- (lambda (conn)
- (number? (count-guix-revisions conn)))))
- (lambda (key . args)
- #f))))
- (render-json
- `((status . ,(if database-status
- "ok"
- "not ok")))
- #:code (if (eq? database-status
- #t)
- 200
- 500))))
- (('GET "README")
- (let ((filename (string-append (%config 'doc-dir) "/README.html")))
- (if (file-exists? filename)
- (render-html
- #:sxml (readme (call-with-input-file filename
- get-string-all)))
- (render-html
- #:sxml (general-not-found
- "README not found"
- "The README.html file does not exist")
- #:code 404))))
- (_
- (with-thread-postgresql-connection
- (lambda (conn)
- (controller-with-database-connection request
- method-and-path-components
- mime-types
- body
- conn
- secret-key-base))))))
+ (actual-controller request
+ method-and-path-components
+ mime-types
+ body
+ secret-key-base))
+
(call-with-error-handling
controller-thunk
#:on-error 'backtrace
@@ -447,12 +508,11 @@
#f))
#:code 500))))
-(define (controller-with-database-connection request
- method-and-path-components
- mime-types
- body
- conn
- secret-key-base)
+(define (actual-controller request
+ method-and-path-components
+ mime-types
+ body
+ secret-key-base)
(define path
(uri-path (request-uri request)))
@@ -460,8 +520,7 @@
(or (f request
method-and-path-components
mime-types
- body
- conn)
+ body)
(render-html
#:sxml (general-not-found
"Page not found"
@@ -473,7 +532,6 @@
method-and-path-components
mime-types
body
- conn
secret-key-base)
(render-html
#:sxml (general-not-found
@@ -485,21 +543,63 @@
(('GET)
(render-html
#:sxml (index
- (map
- (lambda (git-repository-details)
- (cons
- git-repository-details
- (all-branches-with-most-recent-commit
- conn (first git-repository-details))))
- (all-git-repositories conn)))))
+ (parallel-via-thread-pool-channel
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (map
+ (lambda (git-repository-details)
+ (cons
+ git-repository-details
+ (all-branches-with-most-recent-commit
+ conn (first git-repository-details))))
+ (all-git-repositories conn))))))))
+ (('GET "assets" rest ...)
+ (or (handle-static-assets (string-join rest "/")
+ (request-headers request))
+ (not-found (request-uri request))))
+ (('GET "healthcheck")
+ (let ((database-status
+ (catch
+ #t
+ (lambda ()
+ (with-postgresql-connection
+ "web healthcheck"
+ (lambda (conn)
+ (number? (count-guix-revisions conn)))))
+ (lambda (key . args)
+ #f))))
+ (render-json
+ `((status . ,(if database-status
+ "ok"
+ "not ok")))
+ #:code (if (eq? database-status
+ #t)
+ 200
+ 500))))
+ (('GET "README")
+ (let ((filename (string-append (%config 'doc-dir) "/README.html")))
+ (if (file-exists? filename)
+ (render-html
+ #:sxml (readme (call-with-input-file filename
+ get-string-all)))
+ (render-html
+ #:sxml (general-not-found
+ "README not found"
+ "The README.html file does not exist")
+ #:code 404))))
(('GET "builds")
(delegate-to build-controller))
(('GET "statistics")
- (render-html
- #:sxml (view-statistics (count-guix-revisions conn)
- (count-derivations conn))))
+ (letpar& ((guix-revisions-count
+ (with-thread-postgresql-connection count-guix-revisions))
+ (count-derivations
+ (with-thread-postgresql-connection count-derivations)))
+
+ (render-html
+ #:sxml (view-statistics guix-revisions-count
+ count-derivations))))
(('GET "metrics")
- (render-metrics conn))
+ (render-metrics))
(('GET "revision" args ...)
(delegate-to revision-controller))
(('GET "repositories")
@@ -511,12 +611,11 @@
;; content negotiation, so just use the path from the request
(let ((path (uri-path (request-uri request))))
(if (string-suffix? ".drv" path)
- (render-derivation conn path)
- (render-store-item conn path))))
+ (render-derivation path)
+ (render-store-item path))))
(('GET "gnu" "store" filename "formatted")
(if (string-suffix? ".drv" filename)
- (render-formatted-derivation conn
- (string-append "/gnu/store/" filename))
+ (render-formatted-derivation (string-append "/gnu/store/" filename))
(render-html
#:sxml (general-not-found
"Not a derivation"
@@ -525,20 +624,22 @@
(('GET "gnu" "store" filename "plain")
(if (string-suffix? ".drv" filename)
(let ((raw-drv
- (select-serialized-derivation-by-file-name
- conn
- (string-append "/gnu/store/" filename))))
+ (parallel-via-thread-pool-channel
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-serialized-derivation-by-file-name
+ conn
+ (string-append "/gnu/store/" filename)))))))
(if raw-drv
(render-text raw-drv)
(not-found (request-uri request))))
(not-found (request-uri request))))
(('GET "gnu" "store" filename "narinfos")
- (render-narinfos conn filename))
+ (render-narinfos filename))
(('GET "gnu" "store" filename "json")
(if (string-suffix? ".drv" filename)
- (render-json-derivation conn
- (string-append "/gnu/store/" filename))
- (render-json-store-item conn (string-append "/gnu/store/" filename))))
+ (render-json-derivation (string-append "/gnu/store/" filename))
+ (render-json-store-item (string-append "/gnu/store/" filename))))
(('GET "build-servers")
(delegate-to-with-secret-key-base build-server-controller))
(('GET "dumps" _ ...)
diff --git a/guix-data-service/web/dumps/controller.scm
b/guix-data-service/web/dumps/controller.scm
index 70b6fe9..ecae2d8 100644
--- a/guix-data-service/web/dumps/controller.scm
+++ b/guix-data-service/web/dumps/controller.scm
@@ -31,8 +31,7 @@
(define (dumps-controller request
method-and-path-components
mime-types
- body
- conn)
+ body)
(match method-and-path-components
(('GET "dumps")
(render-dumps request
diff --git a/guix-data-service/web/jobs/controller.scm
b/guix-data-service/web/jobs/controller.scm
index 3de9827..47034ee 100644
--- a/guix-data-service/web/jobs/controller.scm
+++ b/guix-data-service/web/jobs/controller.scm
@@ -17,6 +17,8 @@
(define-module (guix-data-service web jobs controller)
#:use-module (ice-9 match)
+ #:use-module (guix-data-service utils)
+ #:use-module (guix-data-service database)
#:use-module (guix-data-service web render)
#:use-module (guix-data-service web query-parameters)
#:use-module (guix-data-service web util)
@@ -27,8 +29,7 @@
(define (jobs-controller request
method-and-path-components
mime-types
- body
- conn)
+ body)
(match method-and-path-components
(('GET "jobs")
(let ((parsed-query-parameters
@@ -42,7 +43,6 @@
(all_results ,parse-checkbox-value)))
'((limit_results all_results)))))
(render-jobs mime-types
- conn
parsed-query-parameters)))
(('GET "jobs" "events")
(let ((parsed-query-parameters
@@ -55,11 +55,9 @@
(all_results ,parse-checkbox-value)))
'((limit_results all_results)))))
(render-job-events mime-types
- conn
parsed-query-parameters)))
(('GET "jobs" "queue")
- (render-job-queue mime-types
- conn))
+ (render-job-queue mime-types))
(('GET "job" job-id)
(let ((parsed-query-parameters
(parse-query-parameters
@@ -67,19 +65,23 @@
`((start_character ,parse-number)
(characters ,parse-number #:default 10000000)))))
(render-job mime-types
- conn
job-id
parsed-query-parameters)))
(_ #f)))
-(define (render-jobs mime-types conn query-parameters)
- (let* ((limit-results
- (assq-ref query-parameters 'limit_results))
- (jobs (select-jobs-and-events
- conn
- (assq-ref query-parameters 'before_id)
- limit-results))
- (recent-events (select-recent-job-events conn)))
+(define (render-jobs mime-types query-parameters)
+ (define limit-results (assq-ref query-parameters 'limit_results))
+
+ (letpar& ((jobs
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-jobs-and-events
+ conn
+ (assq-ref query-parameters 'before_id)
+ limit-results))))
+ (recent-events
+ (with-thread-postgresql-connection
+ select-recent-job-events)))
(case (most-appropriate-mime-type
'(application/json text/html)
mime-types)
@@ -113,29 +115,36 @@
(>= (length jobs)
limit-results))))))))
-(define (render-job-events mime-types conn query-parameters)
- (let* ((limit-results
- (assq-ref query-parameters 'limit_results))
- (recent-events (select-recent-job-events
- conn
- ;; TODO Ideally there wouldn't be a limit
- #:limit (or limit-results 1000000))))
+(define (render-job-events mime-types query-parameters)
+ (letpar& ((recent-events
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-recent-job-events
+ conn
+ ;; TODO Ideally there wouldn't be a limit
+ #:limit (or (assq-ref query-parameters 'limit_results)
+ 1000000))))))
(render-html
#:sxml (view-job-events
query-parameters
recent-events))))
-(define (render-job-queue mime-types conn)
+(define (render-job-queue mime-types)
(render-html
#:sxml (view-job-queue
- (select-unprocessed-jobs-and-events conn))))
+ (parallel-via-thread-pool-channel
+ (with-thread-postgresql-connection
+ select-unprocessed-jobs-and-events)))))
-(define (render-job mime-types conn job-id query-parameters)
- (let ((log-text (log-for-job conn job-id
- #:character-limit
- (assq-ref query-parameters 'characters)
- #:start-character
- (assq-ref query-parameters 'start_character))))
+(define (render-job mime-types job-id query-parameters)
+ (letpar& ((log-text
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (log-for-job conn job-id
+ #:character-limit
+ (assq-ref query-parameters 'characters)
+ #:start-character
+ (assq-ref query-parameters 'start_character))))))
(case (most-appropriate-mime-type
'(text/plain text/html)
mime-types)
diff --git a/guix-data-service/web/nar/controller.scm
b/guix-data-service/web/nar/controller.scm
index 2bf61be..ba8b890 100644
--- a/guix-data-service/web/nar/controller.scm
+++ b/guix-data-service/web/nar/controller.scm
@@ -31,6 +31,8 @@
#:use-module (guix base32)
#:use-module (guix base64)
#:use-module (guix serialization)
+ #:use-module (guix-data-service utils)
+ #:use-module (guix-data-service database)
#:use-module (guix-data-service web render)
#:use-module (guix-data-service web nar html)
#:use-module (guix-data-service model derivation)
@@ -54,8 +56,7 @@
(define (nar-controller request
method-and-path-components
mime-types
- body
- conn)
+ body)
(define (.narinfo-suffix s)
(string-suffix? ".narinfo" s))
@@ -78,7 +79,6 @@
(uri-decode (last (string-split path #\/)))))
(render-nar request
mime-types
- conn
(string-append "/gnu/store/" file-name))))
(('GET "nar" "lzip" _)
;; These routes are a little special, as the extensions aren't used for
@@ -88,22 +88,22 @@
(uri-decode (last (string-split path #\/)))))
(render-lzip-nar request
mime-types
- conn
(string-append "/gnu/store/" file-name))))
(('GET (? .narinfo-suffix path))
(render-narinfo request
- conn
(string-drop-right path
(string-length ".narinfo"))))
(_ #f)))
(define (render-nar request
mime-types
- conn
file-name)
(or
- (and=> (select-serialized-derivation-by-file-name conn
- file-name)
+ (and=> (parallel-via-thread-pool-channel
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-serialized-derivation-by-file-name conn
+ file-name))))
(lambda (derivation-text)
(let ((derivation-bytevector
(string->bytevector derivation-text
@@ -127,10 +127,13 @@
(define (render-lzip-nar request
mime-types
- conn
file-name)
(or
- (and=> (select-derivation-source-file-nar-data-by-file-name conn file-name)
+ (and=> (parallel-via-thread-pool-channel
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-derivation-source-file-nar-data-by-file-name conn
+
file-name))))
(lambda (data)
(list (build-response
#:code 200
@@ -141,51 +144,60 @@
(not-found (request-uri request))))
(define (render-narinfo request
- conn
hash)
(or
- (and=> (select-derivation-by-file-name-hash conn
- hash)
+ (and=> (parallel-via-thread-pool-channel
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-derivation-by-file-name-hash conn
+ hash))))
(lambda (derivation)
(list (build-response
#:code 200
#:headers '((content-type . (application/x-narinfo))))
- (let* ((derivation-file-name
- (second derivation))
- (derivation-text
- (select-serialized-derivation-by-file-name
- conn
- derivation-file-name))
- (derivation-bytevector
- (string->bytevector derivation-text
- "ISO-8859-1"))
+ (let ((derivation-file-name (second derivation)))
+ (letpar&
+ ((derivation-text
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-serialized-derivation-by-file-name
+ conn
+ derivation-file-name))))
(derivation-references
- (select-derivation-references-by-derivation-id
- conn
- (first derivation)))
- (nar-bytevector
- (call-with-values
- (lambda ()
- (open-bytevector-output-port))
- (lambda (port get-bytevector)
- (write-file-tree
- derivation-file-name
- port
- #:file-type+size
- (lambda (file)
- (values 'regular
- (bytevector-length
derivation-bytevector)))
- #:file-port
- (lambda (file)
- (open-bytevector-input-port
derivation-bytevector)))
- (get-bytevector)))))
- (lambda (port)
- (display (narinfo-string derivation-file-name
- nar-bytevector
- derivation-references)
- port))))))
- (and=> (select-derivation-source-file-data-by-file-name-hash conn
- hash)
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-derivation-references-by-derivation-id
+ conn
+ (first derivation))))))
+ (let* ((derivation-bytevector
+ (string->bytevector derivation-text
+ "ISO-8859-1"))
+ (nar-bytevector
+ (call-with-values
+ (lambda ()
+ (open-bytevector-output-port))
+ (lambda (port get-bytevector)
+ (write-file-tree
+ derivation-file-name
+ port
+ #:file-type+size
+ (lambda (file)
+ (values 'regular
+ (bytevector-length
derivation-bytevector)))
+ #:file-port
+ (lambda (file)
+ (open-bytevector-input-port
derivation-bytevector)))
+ (get-bytevector)))))
+ (lambda (port)
+ (display (narinfo-string derivation-file-name
+ nar-bytevector
+ derivation-references)
+ port))))))))
+ (and=> (parallel-via-thread-pool-channel
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-derivation-source-file-data-by-file-name-hash conn
+ hash))))
(match-lambda
((store-path compression compressed-size
hash-algorithm hash uncompressed-size)
diff --git a/guix-data-service/web/repository/controller.scm
b/guix-data-service/web/repository/controller.scm
index d3c6ab5..84568a9 100644
--- a/guix-data-service/web/repository/controller.scm
+++ b/guix-data-service/web/repository/controller.scm
@@ -19,6 +19,8 @@
#:use-module (ice-9 match)
#:use-module (web uri)
#:use-module (web request)
+ #:use-module (guix-data-service utils)
+ #:use-module (guix-data-service database)
#:use-module (guix-data-service web render)
#:use-module (guix-data-service web query-parameters)
#:use-module (guix-data-service web util)
@@ -36,14 +38,15 @@
(define (repository-controller request
method-and-path-components
mime-types
- body
- conn)
+ body)
(define path
(uri-path (request-uri request)))
(match method-and-path-components
(('GET "repositories")
- (let ((git-repositories (all-git-repositories conn)))
+ (letpar& ((git-repositories
+ (with-thread-postgresql-connection
+ all-git-repositories)))
(case (most-appropriate-mime-type
'(application/json text/html)
mime-types)
@@ -62,11 +65,17 @@
#:sxml
(view-git-repositories git-repositories))))))
(('GET "repository" id)
- (match (select-git-repository conn id)
+ (match (parallel-via-thread-pool-channel
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-git-repository conn id))))
((label url cgit-url-base)
- (let ((branches
- (all-branches-with-most-recent-commit conn
- (string->number id))))
+ (letpar& ((branches
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (all-branches-with-most-recent-commit
+ conn
+ (string->number id))))))
(case (most-appropriate-mime-type
'(application/json text/html)
mime-types)
@@ -110,16 +119,18 @@
`((after_date ,parse-datetime)
(before_date ,parse-datetime)
(limit_results ,parse-result-limit #:default 100)))))
- (let ((revisions
- (most-recent-commits-for-branch
- conn
- (string->number repository-id)
- branch-name
- #:limit (assq-ref parsed-query-parameters 'limit_results)
- #:after-date (assq-ref parsed-query-parameters
- 'after_date)
- #:before-date (assq-ref parsed-query-parameters
- 'before_date))))
+ (letpar& ((revisions
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (most-recent-commits-for-branch
+ conn
+ (string->number repository-id)
+ branch-name
+ #:limit (assq-ref parsed-query-parameters 'limit_results)
+ #:after-date (assq-ref parsed-query-parameters
+ 'after_date)
+ #:before-date (assq-ref parsed-query-parameters
+ 'before_date))))))
(case (most-appropriate-mime-type
'(application/json text/html)
mime-types)
@@ -144,11 +155,13 @@
parsed-query-parameters
revisions))))))))
(('GET "repository" repository-id "branch" branch-name "package"
package-name)
- (let ((package-versions
- (package-versions-for-branch conn
- (string->number repository-id)
- branch-name
- package-name)))
+ (letpar& ((package-versions
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (package-versions-for-branch conn
+ (string->number repository-id)
+ branch-name
+ package-name)))))
(case (most-appropriate-mime-type
'(application/json text/html)
mime-types)
@@ -178,7 +191,6 @@
(('GET "repository" repository-id "branch" branch-name "package"
package-name "derivation-history")
(render-branch-package-derivation-history request
mime-types
- conn
repository-id
branch-name
package-name))
@@ -186,27 +198,32 @@
"package" package-name "output-history")
(render-branch-package-output-history request
mime-types
- conn
repository-id
branch-name
package-name))
(('GET "repository" repository-id "branch" branch-name
"latest-processed-revision")
- (let ((commit-hash
- (latest-processed-commit-for-branch conn repository-id
branch-name)))
+ (letpar& ((commit-hash
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (latest-processed-commit-for-branch conn
+ repository-id
+ branch-name)))))
(if commit-hash
(render-view-revision mime-types
- conn
commit-hash
#:path-base path
#:header-text
`("Latest processed revision for branch "
(samp ,branch-name)))
(render-unknown-revision mime-types
- conn
commit-hash))))
(('GET "repository" repository-id "branch" branch-name
"latest-processed-revision" "packages")
- (let ((commit-hash
- (latest-processed-commit-for-branch conn repository-id
branch-name)))
+ (letpar& ((commit-hash
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (latest-processed-commit-for-branch conn
+ repository-id
+ branch-name)))))
(if commit-hash
(let ((parsed-query-parameters
(guard-against-mutually-exclusive-query-parameters
@@ -227,7 +244,6 @@
(limit_results all_results)))))
(render-revision-packages mime-types
- conn
commit-hash
parsed-query-parameters
#:path-base path
@@ -240,11 +256,14 @@
"/branch/" branch-name
"/latest-processed-revision")))
(render-unknown-revision mime-types
- conn
commit-hash))))
(('GET "repository" repository-id "branch" branch-name
"latest-processed-revision" "package-derivations")
- (let ((commit-hash
- (latest-processed-commit-for-branch conn repository-id
branch-name)))
+ (letpar& ((commit-hash
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (latest-processed-commit-for-branch conn
+ repository-id
+ branch-name)))))
(if commit-hash
(let ((parsed-query-parameters
(guard-against-mutually-exclusive-query-parameters
@@ -265,39 +284,45 @@
'((limit_results all_results)))))
(render-revision-package-derivations mime-types
- conn
commit-hash
parsed-query-parameters
#:path-base path))
(render-unknown-revision mime-types
- conn
commit-hash))))
(('GET "repository" repository-id "branch" branch-name
"latest-processed-revision" "package-reproducibility")
- (let ((commit-hash
- (latest-processed-commit-for-branch conn repository-id
branch-name)))
+ (letpar& ((commit-hash
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (latest-processed-commit-for-branch conn
+ repository-id
+ branch-name)))))
(if commit-hash
(render-revision-package-reproduciblity mime-types
- conn
commit-hash
#:path-base path)
(render-unknown-revision mime-types
- conn
commit-hash))))
(('GET "repository" repository-id "branch" branch-name
"latest-processed-revision" "package-substitute-availability")
- (let ((commit-hash
- (latest-processed-commit-for-branch conn repository-id
branch-name)))
+ (letpar& ((commit-hash
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (latest-processed-commit-for-branch conn
+ repository-id
+ branch-name)))))
(if commit-hash
(render-revision-package-substitute-availability mime-types
- conn
commit-hash
#:path-base path)
(render-unknown-revision mime-types
- conn
commit-hash))))
(('GET "repository" repository-id "branch" branch-name
"latest-processed-revision"
"lint-warnings")
- (let ((commit-hash
- (latest-processed-commit-for-branch conn repository-id
branch-name)))
+ (letpar& ((commit-hash
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (latest-processed-commit-for-branch conn
+ repository-id
+ branch-name)))))
(if commit-hash
(let ((parsed-query-parameters
(parse-query-parameters
@@ -312,7 +337,6 @@
"location"))))))
(render-revision-lint-warnings mime-types
- conn
commit-hash
parsed-query-parameters
#:path-base path
@@ -325,43 +349,46 @@
"/branch/" branch-name
"/latest-processed-revision")))
(render-unknown-revision mime-types
- conn
commit-hash))))
(('GET "repository" repository-id "branch" branch-name
"latest-processed-revision" "package" name version)
- (let ((commit-hash
- (latest-processed-commit-for-branch conn repository-id
branch-name))
- (parsed-query-parameters
- (parse-query-parameters
- request
- `((locale ,identity #:default "en_US.UTF-8")))))
- (if commit-hash
- (render-revision-package-version mime-types
- conn
- commit-hash
- name
- version
- parsed-query-parameters
- #:header-text
- `("Latest processed revision for
branch "
- (samp ,branch-name))
- #:header-link
- (string-append
- "/repository/" repository-id
- "/branch/" branch-name
- "/latest-processed-revision")
- #:version-history-link
- (string-append
- "/repository/" repository-id
- "/branch/" branch-name
- "/package/" name))
- (render-unknown-revision mime-types
- conn
- commit-hash))))
- (_ #f)))
+ (letpar& ((commit-hash
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (latest-processed-commit-for-branch conn
+ repository-id
+ branch-name)))))
+ (let ((parsed-query-parameters
+ (parse-query-parameters
+ request
+ `((locale ,identity #:default "en_US.UTF-8")))))
+ (if commit-hash
+ (render-revision-package-version mime-types
+ commit-hash
+ name
+ version
+ parsed-query-parameters
+ #:header-text
+ `("Latest processed revision for
branch "
+ (samp ,branch-name))
+ #:header-link
+ (string-append
+ "/repository/" repository-id
+ "/branch/" branch-name
+ "/latest-processed-revision")
+ #:version-history-link
+ (string-append
+ "/repository/" repository-id
+ "/branch/" branch-name
+ "/package/" name))
+ (render-unknown-revision mime-types
+ commit-hash)))))
+ (_ #f)))
-(define (parse-build-system conn)
+(define (parse-build-system)
(let ((systems
- (valid-systems conn)))
+ (parallel-via-thread-pool-channel
+ (with-thread-postgresql-connection
+ valid-systems))))
(lambda (s)
(if (member s systems)
s
@@ -370,70 +397,77 @@
(define (render-branch-package-derivation-history request
mime-types
- conn
repository-id
branch-name
package-name)
(let ((parsed-query-parameters
(parse-query-parameters
request
- `((system ,(parse-build-system conn)
+ `((system ,(parse-build-system)
#:default "x86_64-linux")
(target ,parse-target
#:default "")))))
- (let* ((system
- (assq-ref parsed-query-parameters 'system))
- (target
- (assq-ref parsed-query-parameters 'target))
- (package-derivations
- (package-derivations-for-branch conn
- (string->number repository-id)
- branch-name
- system
- target
- package-name))
+ (let ((system
+ (assq-ref parsed-query-parameters 'system))
+ (target
+ (assq-ref parsed-query-parameters 'target)))
+ (letpar&
+ ((package-derivations
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (package-derivations-for-branch conn
+ (string->number repository-id)
+ branch-name
+ system
+ target
+ package-name))))
(build-server-urls
- (select-build-server-urls-by-id conn)))
- (case (most-appropriate-mime-type
- '(application/json text/html)
- mime-types)
- ((application/json)
- (render-json
- `((derivations . ,(list->vector
- (map (match-lambda
- ((package-version derivation-file-name
-
first-guix-revision-commit
- first-datetime
- last-guix-revision-commit
- last-datetime
- builds)
- `((version . ,package-version)
- (derivation . ,derivation-file-name)
- (first_revision
- . ((commit .
,first-guix-revision-commit)
- (datetime . ,first-datetime)))
- (last_revision
- . ((commit .
,last-guix-revision-commit)
- (datetime . ,last-datetime)))
- (builds
- . ,(list->vector builds)))))
- package-derivations))))))
- (else
- (render-html
- #:sxml (view-branch-package-derivations
- parsed-query-parameters
- repository-id
- branch-name
- package-name
- (valid-systems conn)
- (valid-targets->options
- (valid-targets conn))
- build-server-urls
- package-derivations)))))))
+ (with-thread-postgresql-connection
+ select-build-server-urls-by-id)))
+ (case (most-appropriate-mime-type
+ '(application/json text/html)
+ mime-types)
+ ((application/json)
+ (render-json
+ `((derivations . ,(list->vector
+ (map (match-lambda
+ ((package-version derivation-file-name
+
first-guix-revision-commit
+ first-datetime
+
last-guix-revision-commit
+ last-datetime
+ builds)
+ `((version . ,package-version)
+ (derivation . ,derivation-file-name)
+ (first_revision
+ . ((commit .
,first-guix-revision-commit)
+ (datetime . ,first-datetime)))
+ (last_revision
+ . ((commit .
,last-guix-revision-commit)
+ (datetime . ,last-datetime)))
+ (builds
+ . ,(list->vector builds)))))
+ package-derivations))))))
+ (else
+ (letpar& ((systems
+ (with-thread-postgresql-connection
+ valid-systems))
+ (targets
+ (with-thread-postgresql-connection
+ valid-targets)))
+ (render-html
+ #:sxml (view-branch-package-derivations
+ parsed-query-parameters
+ repository-id
+ branch-name
+ package-name
+ systems
+ (valid-targets->options targets)
+ build-server-urls
+ package-derivations)))))))))
(define (render-branch-package-output-history request
mime-types
- conn
repository-id
branch-name
package-name)
@@ -442,60 +476,69 @@
request
`((output ,identity
#:default "out")
- (system ,(parse-build-system conn)
+ (system ,(parse-build-system)
#:default "x86_64-linux")
(target ,parse-target
#:default "")))))
- (let* ((system
- (assq-ref parsed-query-parameters 'system))
- (target
- (assq-ref parsed-query-parameters 'target))
- (output-name
- (assq-ref parsed-query-parameters 'output))
- (package-outputs
- (package-outputs-for-branch conn
- (string->number repository-id)
- branch-name
- system
- target
- package-name
- output-name))
+ (let ((system
+ (assq-ref parsed-query-parameters 'system))
+ (target
+ (assq-ref parsed-query-parameters 'target))
+ (output-name
+ (assq-ref parsed-query-parameters 'output)))
+ (letpar&
+ ((package-outputs
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (package-outputs-for-branch conn
+ (string->number repository-id)
+ branch-name
+ system
+ target
+ package-name
+ output-name))))
(build-server-urls
- (select-build-server-urls-by-id conn)))
- (case (most-appropriate-mime-type
- '(application/json text/html)
- mime-types)
- ((application/json)
- (render-json
- `((derivations . ,(list->vector
- (map (match-lambda
- ((package-version derivation-file-name
-
first-guix-revision-commit
- first-datetime
- last-guix-revision-commit
- last-datetime
- builds)
- `((version . ,package-version)
- (derivation . ,derivation-file-name)
- (first_revision
- . ((commit .
,first-guix-revision-commit)
- (datetime . ,first-datetime)))
- (last_revision
- . ((commit .
,last-guix-revision-commit)
- (datetime . ,last-datetime)))
- (builds
- . ,(list->vector builds)))))
- package-outputs))))))
- (else
- (render-html
- #:sxml (view-branch-package-outputs
- parsed-query-parameters
- repository-id
- branch-name
- package-name
- output-name
- (valid-systems conn)
- (valid-targets->options
- (valid-targets conn))
- build-server-urls
- package-outputs)))))))
+ (with-thread-postgresql-connection
+ select-build-server-urls-by-id)))
+ (case (most-appropriate-mime-type
+ '(application/json text/html)
+ mime-types)
+ ((application/json)
+ (render-json
+ `((derivations . ,(list->vector
+ (map (match-lambda
+ ((package-version derivation-file-name
+
first-guix-revision-commit
+ first-datetime
+
last-guix-revision-commit
+ last-datetime
+ builds)
+ `((version . ,package-version)
+ (derivation . ,derivation-file-name)
+ (first_revision
+ . ((commit .
,first-guix-revision-commit)
+ (datetime . ,first-datetime)))
+ (last_revision
+ . ((commit .
,last-guix-revision-commit)
+ (datetime . ,last-datetime)))
+ (builds
+ . ,(list->vector builds)))))
+ package-outputs))))))
+ (else
+ (letpar& ((systems
+ (with-thread-postgresql-connection
+ valid-systems))
+ (targets
+ (with-thread-postgresql-connection
+ valid-targets)))
+ (render-html
+ #:sxml (view-branch-package-outputs
+ parsed-query-parameters
+ repository-id
+ branch-name
+ package-name
+ output-name
+ systems
+ (valid-targets->options targets)
+ build-server-urls
+ package-outputs)))))))))
diff --git a/guix-data-service/web/revision/controller.scm
b/guix-data-service/web/revision/controller.scm
index be6a4d0..d5049e0 100644
--- a/guix-data-service/web/revision/controller.scm
+++ b/guix-data-service/web/revision/controller.scm
@@ -24,6 +24,8 @@
#:use-module (texinfo html)
#:use-module (texinfo plain-text)
#:use-module (json)
+ #:use-module (guix-data-service utils)
+ #:use-module (guix-data-service database)
#:use-module (guix-data-service web render)
#:use-module (guix-data-service web sxml)
#:use-module (guix-data-service web query-parameters)
@@ -75,52 +77,57 @@
(string-append "unknown build status: "
status))))
-(define (parse-build-server conn)
- (lambda (v)
- (let ((build-servers (select-build-servers conn)))
- (or (any (match-lambda
- ((id url lookup-all-derivations? lookup-builds?)
- (if (eq? (string->number v)
- id)
- id
- #f)))
- build-servers)
- (make-invalid-query-parameter
- v
- "unknown build server")))))
+(define (parse-build-server v)
+ (letpar& ((build-servers
+ (with-thread-postgresql-connection select-build-servers)))
+ (or (any (match-lambda
+ ((id url lookup-all-derivations? lookup-builds?)
+ (if (eq? (string->number v)
+ id)
+ id
+ #f)))
+ build-servers)
+ (make-invalid-query-parameter
+ v
+ "unknown build server"))))
(define (revision-controller request
method-and-path-components
mime-types
- body
- conn)
+ body)
(define path
(uri-path (request-uri request)))
(match method-and-path-components
- (('GET "revision" commit-hash) (if (guix-commit-exists? conn commit-hash)
- (render-view-revision mime-types
- conn
- commit-hash
- #:path-base path)
- (render-unknown-revision mime-types
- conn
- commit-hash)))
+ (('GET "revision" commit-hash)
+ (if (parallel-via-thread-pool-channel
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (guix-commit-exists? conn commit-hash))))
+ (render-view-revision mime-types
+ commit-hash
+ #:path-base path)
+ (render-unknown-revision mime-types
+ commit-hash)))
(('GET "revision" commit-hash "news")
- (if (guix-commit-exists? conn commit-hash)
+ (if (parallel-via-thread-pool-channel
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (guix-commit-exists? conn commit-hash))))
(let ((parsed-query-parameters
(parse-query-parameters
request
`((lang ,identity #:multi-value)))))
(render-revision-news mime-types
- conn
commit-hash
parsed-query-parameters))
(render-unknown-revision mime-types
- conn
commit-hash)))
(('GET "revision" commit-hash "packages")
- (if (guix-commit-exists? conn commit-hash)
+ (if (parallel-via-thread-pool-channel
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (guix-commit-exists? conn commit-hash))))
(let ((parsed-query-parameters
(guard-against-mutually-exclusive-query-parameters
(parse-query-parameters
@@ -140,48 +147,52 @@
(limit_results all_results)))))
(render-revision-packages mime-types
- conn
commit-hash
parsed-query-parameters
#:path-base path))
(render-unknown-revision mime-types
- conn
commit-hash)))
(('GET "revision" commit-hash "packages-translation-availability")
- (if (guix-commit-exists? conn commit-hash)
+ (if (parallel-via-thread-pool-channel
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (guix-commit-exists? conn commit-hash))))
(render-revision-packages-translation-availability mime-types
- conn
commit-hash
#:path-base path)
(render-unknown-revision mime-types
- conn
commit-hash)))
(('GET "revision" commit-hash "package" name)
- (if (guix-commit-exists? conn commit-hash)
+ (if (parallel-via-thread-pool-channel
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (guix-commit-exists? conn commit-hash))))
(render-revision-package mime-types
- conn
commit-hash
name)
(render-unknown-revision mime-types
- conn
commit-hash)))
(('GET "revision" commit-hash "package" name version)
- (if (guix-commit-exists? conn commit-hash)
+ (if (parallel-via-thread-pool-channel
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (guix-commit-exists? conn commit-hash))))
(let ((parsed-query-parameters
(parse-query-parameters
request
`((locale ,identity #:default "en_US.UTF-8")))))
(render-revision-package-version mime-types
- conn
commit-hash
name
version
parsed-query-parameters))
(render-unknown-revision mime-types
- conn
commit-hash)))
(('GET "revision" commit-hash "package-derivations")
- (if (guix-commit-exists? conn commit-hash)
+ (if (parallel-via-thread-pool-channel
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (guix-commit-exists? conn commit-hash))))
(let ((parsed-query-parameters
(guard-against-mutually-exclusive-query-parameters
(parse-query-parameters
@@ -201,15 +212,16 @@
'((limit_results all_results)))))
(render-revision-package-derivations mime-types
- conn
commit-hash
parsed-query-parameters
#:path-base path))
(render-unknown-revision mime-types
- conn
commit-hash)))
(('GET "revision" commit-hash "package-derivation-outputs")
- (if (guix-commit-exists? conn commit-hash)
+ (if (parallel-via-thread-pool-channel
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (guix-commit-exists? conn commit-hash))))
(let ((parsed-query-parameters
(guard-against-mutually-exclusive-query-parameters
(parse-query-parameters
@@ -231,62 +243,67 @@
'((limit_results all_results)))))
(render-revision-package-derivation-outputs mime-types
- conn
commit-hash
parsed-query-parameters
#:path-base path))
(render-unknown-revision mime-types
- conn
commit-hash)))
(('GET "revision" commit-hash "system-tests")
- (if (guix-commit-exists? conn commit-hash)
+ (if (parallel-via-thread-pool-channel
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (guix-commit-exists? conn commit-hash))))
(let ((parsed-query-parameters
(parse-query-parameters
request
`((system ,parse-system #:default "x86_64-linux")))))
(render-revision-system-tests mime-types
- conn
commit-hash
parsed-query-parameters
#:path-base path))
(render-unknown-revision mime-types
- conn
commit-hash)))
(('GET "revision" commit-hash "channel-instances")
- (if (guix-commit-exists? conn commit-hash)
+ (if (parallel-via-thread-pool-channel
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (guix-commit-exists? conn commit-hash))))
(render-revision-channel-instances mime-types
- conn
commit-hash
#:path-base path)
(render-unknown-revision mime-types
- conn
commit-hash)))
(('GET "revision" commit-hash "package-substitute-availability")
- (if (guix-commit-exists? conn commit-hash)
+ (if (parallel-via-thread-pool-channel
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (guix-commit-exists? conn commit-hash))))
(render-revision-package-substitute-availability mime-types
- conn
commit-hash
#:path-base path)
(render-unknown-revision mime-types
- conn
commit-hash)))
(('GET "revision" commit-hash "package-reproducibility")
- (if (guix-commit-exists? conn commit-hash)
+ (if (parallel-via-thread-pool-channel
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (guix-commit-exists? conn commit-hash))))
(render-revision-package-reproduciblity mime-types
- conn
commit-hash
#:path-base path)
(render-unknown-revision mime-types
- conn
commit-hash)))
(('GET "revision" commit-hash "builds")
- (if (guix-commit-exists? conn commit-hash)
+ (if (parallel-via-thread-pool-channel
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (guix-commit-exists? conn commit-hash))))
(let ((parsed-query-parameters
(guard-against-mutually-exclusive-query-parameters
(parse-query-parameters
request
`((build_status ,parse-build-status #:multi-value)
- (build_server ,(parse-build-server conn) #:multi-value)
+ (build_server ,parse-build-server #:multi-value)
(system ,parse-system #:default "x86_64-linux")
(target ,parse-target #:default "")
(limit_results ,parse-result-limit
@@ -296,15 +313,16 @@
'((limit_results all_results)))))
(render-revision-builds mime-types
- conn
commit-hash
parsed-query-parameters
#:path-base path))
(render-unknown-revision mime-types
- conn
commit-hash)))
(('GET "revision" commit-hash "lint-warnings")
- (if (guix-commit-exists? conn commit-hash)
+ (if (parallel-via-thread-pool-channel
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (guix-commit-exists? conn commit-hash))))
(let ((parsed-query-parameters
(parse-query-parameters
request
@@ -318,12 +336,10 @@
"location"))))))
(render-revision-lint-warnings mime-types
- conn
commit-hash
parsed-query-parameters
#:path-base path))
(render-unknown-revision mime-types
- conn
commit-hash)))
(_ #f)))
@@ -336,7 +352,7 @@
(plain . ,(stexi->plain-text stexi))
(locale . ,locale))))
-(define (render-unknown-revision mime-types conn commit-hash)
+(define (render-unknown-revision mime-types commit-hash)
(case (most-appropriate-mime-type
'(application/json text/html)
mime-types)
@@ -345,31 +361,55 @@
'((unknown_commit . ,commit-hash))
#:code 404))
(else
+ (letpar& ((job
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-job-for-commit conn commit-hash))))
+ (git-repositories-and-branches
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (git-branches-with-repository-details-for-commit conn
+
commit-hash))))
+ (jobs-and-events
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-jobs-and-events-for-commit conn commit-hash)))))
+
(render-html
#:code 404
#:sxml (unknown-revision
commit-hash
- (select-job-for-commit
- conn commit-hash)
- (git-branches-with-repository-details-for-commit conn
commit-hash)
- (select-jobs-and-events-for-commit conn commit-hash))))))
+ job
+ git-repositories-and-branches
+ jobs-and-events))))))
(define* (render-view-revision mime-types
- conn
commit-hash
#:key path-base
(header-text
`("Revision " (samp ,commit-hash))))
- (let ((packages-count
- (count-packages-in-revision conn commit-hash))
- (git-repositories-and-branches
- (git-branches-with-repository-details-for-commit conn commit-hash))
- (derivations-counts
- (count-packages-derivations-in-revision conn commit-hash))
- (jobs-and-events
- (select-jobs-and-events-for-commit conn commit-hash))
- (lint-warning-counts
- (lint-warning-count-by-lint-checker-for-revision conn commit-hash)))
+ (letpar& ((packages-count
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (count-packages-in-revision conn commit-hash))))
+ (git-repositories-and-branches
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (git-branches-with-repository-details-for-commit conn
+
commit-hash))))
+ (derivations-counts
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (count-packages-derivations-in-revision conn commit-hash))))
+ (jobs-and-events
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-jobs-and-events-for-commit conn commit-hash))))
+ (lint-warning-counts
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (lint-warning-count-by-lint-checker-for-revision conn
+
commit-hash)))))
(case (most-appropriate-mime-type
'(application/json text/html)
mime-types)
@@ -404,7 +444,6 @@
#:extra-headers http-headers-for-unchanging-content)))))
(define* (render-revision-system-tests mime-types
- conn
commit-hash
query-parameters
#:key
@@ -413,11 +452,13 @@
`("Revision " (samp ,commit-hash)))
(header-link
(string-append "/revision/"
commit-hash)))
- (let ((system-tests
- (select-system-tests-for-guix-revision
- conn
- (assq-ref query-parameters 'system)
- commit-hash)))
+ (letpar& ((system-tests
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-system-tests-for-guix-revision
+ conn
+ (assq-ref query-parameters 'system)
+ commit-hash)))))
(case (most-appropriate-mime-type
'(application/json text/html)
mime-types)
@@ -440,20 +481,25 @@
(builds . ,(list->vector builds)))))
system-tests))))))
(else
- (render-html
- #:sxml (view-revision-system-tests
- commit-hash
- system-tests
- (git-repositories-containing-commit conn
- commit-hash)
- (valid-systems conn)
- query-parameters
- #:path-base path-base
- #:header-text header-text
- #:header-link header-link))))))
+ (letpar& ((git-repositories
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (git-repositories-containing-commit conn
+ commit-hash))))
+ (systems
+ (with-thread-postgresql-connection valid-systems)))
+ (render-html
+ #:sxml (view-revision-system-tests
+ commit-hash
+ system-tests
+ git-repositories
+ systems
+ query-parameters
+ #:path-base path-base
+ #:header-text header-text
+ #:header-link header-link)))))))
(define* (render-revision-channel-instances mime-types
- conn
commit-hash
#:key
(path-base "/revision/")
@@ -462,8 +508,10 @@
(header-link
(string-append "/revision/"
commit-hash)))
- (let ((channel-instances
- (select-channel-instances-for-guix-revision conn commit-hash)))
+ (letpar& ((channel-instances
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-channel-instances-for-guix-revision conn
commit-hash)))))
(case (most-appropriate-mime-type
'(application/json text/html)
mime-types)
@@ -487,13 +535,16 @@
#:header-link header-link))))))
(define* (render-revision-package-substitute-availability mime-types
- conn
commit-hash
#:key path-base)
- (let ((substitute-availability
- (select-package-output-availability-for-revision conn commit-hash))
- (build-server-urls
- (select-build-server-urls-by-id conn)))
+ (letpar& ((substitute-availability
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-package-output-availability-for-revision conn
+
commit-hash))))
+ (build-server-urls
+ (with-thread-postgresql-connection
+ select-build-server-urls-by-id)))
(case (most-appropriate-mime-type
'(application/json text/html)
mime-types)
@@ -508,11 +559,12 @@
build-server-urls))))))
(define* (render-revision-package-reproduciblity mime-types
- conn
commit-hash
#:key path-base)
- (let ((output-consistency
- (select-output-consistency-for-revision conn commit-hash)))
+ (letpar& ((output-consistency
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-output-consistency-for-revision conn commit-hash)))))
(case (most-appropriate-mime-type
'(application/json text/html)
mime-types)
@@ -526,7 +578,6 @@
output-consistency))))))
(define (render-revision-news mime-types
- conn
commit-hash
query-parameters)
(if (any-invalid-query-parameters? query-parameters)
@@ -541,9 +592,12 @@
#:sxml (view-revision-news commit-hash
query-parameters
'()))))
- (let ((news-entries
- (select-channel-news-entries-contained-in-guix-revision conn
-
commit-hash)))
+ (letpar& ((news-entries
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-channel-news-entries-contained-in-guix-revision
+ conn
+ commit-hash)))))
(case (most-appropriate-mime-type
'(application/json text/html)
mime-types)
@@ -558,7 +612,6 @@
#:extra-headers http-headers-for-unchanging-content))))))
(define* (render-revision-packages mime-types
- conn
commit-hash
query-parameters
#:key
@@ -589,101 +642,109 @@
'()
#f
#f
+ #f
#:path-base path-base
#:header-text header-text
#:header-link header-link))))
- (let* ((search-query (assq-ref query-parameters 'search_query))
- (limit-results (or (assq-ref query-parameters 'limit_results)
- 99999)) ; TODO There shouldn't be a limit
- (fields (assq-ref query-parameters 'field))
- (locale (assq-ref query-parameters 'locale))
- (packages
- (if search-query
- (search-packages-in-revision
- conn
- commit-hash
- search-query
- #:limit-results limit-results
- #:locale locale)
- (select-packages-in-revision
- conn
- commit-hash
- #:limit-results limit-results
- #:after-name (assq-ref query-parameters 'after_name)
- #:locale (assq-ref query-parameters 'locale))))
+ (let ((search-query (assq-ref query-parameters 'search_query))
+ (limit-results (or (assq-ref query-parameters 'limit_results)
+ 99999)) ; TODO There shouldn't be a limit
+ (fields (assq-ref query-parameters 'field))
+ (locale (assq-ref query-parameters 'locale)))
+ (letpar&
+ ((packages
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (if search-query
+ (search-packages-in-revision
+ conn
+ commit-hash
+ search-query
+ #:limit-results limit-results
+ #:locale locale)
+ (select-packages-in-revision
+ conn
+ commit-hash
+ #:limit-results limit-results
+ #:after-name (assq-ref query-parameters 'after_name)
+ #:locale (assq-ref query-parameters 'locale))))))
(git-repositories
- (git-repositories-containing-commit conn
- commit-hash))
- (show-next-page?
- (and (not search-query)
- (>= (length packages)
- limit-results)))
- (any-translations?
(any-package-synopsis-or-descriptions-translations?
- packages locale)))
- (case (most-appropriate-mime-type
- '(application/json text/html)
- mime-types)
- ((application/json)
- (render-json
- `((revision
- . ((commit . ,commit-hash)))
- (packages
- . ,(list->vector
- (map (match-lambda
- ((name version synopsis synopsis-locale description
description-locale home-page
- location-file location-line
- location-column-number licenses)
- `((name . ,name)
- ,@(if (member "version" fields)
- `((version . ,version))
- '())
- ,@(if (member "synopsis" fields)
- `((synopsis
- . ,(texinfo->variants-alist synopsis
synopsis-locale)))
- '())
- ,@(if (member "description" fields)
- `((description
- . ,(texinfo->variants-alist description
description-locale)))
- '())
- ,@(if (member "home-page" fields)
- `((home-page . ,home-page))
- '())
- ,@(if (member "location" fields)
- `((location
- . ((file . ,location-file)
- (line . ,location-line)
- (column . ,location-column-number))))
- '())
- ,@(if (member "licenses" fields)
- `((licenses
- . ,(if (string-null? licenses)
- #()
- (json-string->scm licenses))))
- '()))))
- packages))))
- #:extra-headers http-headers-for-unchanging-content))
- (else
- (let ((locale-options
- (description-and-synopsis-locale-options
-
(package-description-and-synopsis-locale-options-guix-revision
- conn
- (commit->revision-id conn commit-hash)))))
- (render-html
- #:sxml (view-revision-packages commit-hash
- query-parameters
- packages
- git-repositories
- show-next-page?
- locale-options
- any-translations?
- #:path-base path-base
- #:header-text header-text
- #:header-link header-link)
- #:extra-headers http-headers-for-unchanging-content)))))))
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (git-repositories-containing-commit conn
+ commit-hash)))))
+ (let ((show-next-page?
+ (and (not search-query)
+ (>= (length packages)
+ limit-results)))
+ (any-translations?
(any-package-synopsis-or-descriptions-translations?
+ packages locale)))
+ (case (most-appropriate-mime-type
+ '(application/json text/html)
+ mime-types)
+ ((application/json)
+ (render-json
+ `((revision
+ . ((commit . ,commit-hash)))
+ (packages
+ . ,(list->vector
+ (map (match-lambda
+ ((name version synopsis synopsis-locale
description description-locale home-page
+ location-file location-line
+ location-column-number licenses)
+ `((name . ,name)
+ ,@(if (member "version" fields)
+ `((version . ,version))
+ '())
+ ,@(if (member "synopsis" fields)
+ `((synopsis
+ . ,(texinfo->variants-alist synopsis
synopsis-locale)))
+ '())
+ ,@(if (member "description" fields)
+ `((description
+ . ,(texinfo->variants-alist
description description-locale)))
+ '())
+ ,@(if (member "home-page" fields)
+ `((home-page . ,home-page))
+ '())
+ ,@(if (member "location" fields)
+ `((location
+ . ((file . ,location-file)
+ (line . ,location-line)
+ (column .
,location-column-number))))
+ '())
+ ,@(if (member "licenses" fields)
+ `((licenses
+ . ,(if (string-null? licenses)
+ #()
+ (json-string->scm licenses))))
+ '()))))
+ packages))))
+ #:extra-headers http-headers-for-unchanging-content))
+ (else
+ (letpar&
+ ((locale-options
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (description-and-synopsis-locale-options
+
(package-description-and-synopsis-locale-options-guix-revision
+ conn
+ (commit->revision-id conn commit-hash)))))))
+ (render-html
+ #:sxml (view-revision-packages commit-hash
+ query-parameters
+ packages
+ git-repositories
+ show-next-page?
+ locale-options
+ any-translations?
+ #:path-base path-base
+ #:header-text header-text
+ #:header-link header-link)
+ #:extra-headers http-headers-for-unchanging-content)))))))))
(define* (render-revision-packages-translation-availability mime-types
- conn
commit-hash
#:key
path-base
@@ -692,14 +753,20 @@
"/revision/"
commit-hash))
(header-text
`("Revision "
(samp ,commit-hash))))
- (let ((package-synopsis-counts
- (synopsis-counts-by-locale conn
- (commit->revision-id conn
- commit-hash)))
- (package-description-counts
- (description-counts-by-locale conn
- (commit->revision-id conn
- commit-hash))))
+ (letpar& ((package-synopsis-counts
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (synopsis-counts-by-locale conn
+ (commit->revision-id
+ conn
+ commit-hash)))))
+ (package-description-counts
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (description-counts-by-locale conn
+ (commit->revision-id
+ conn
+ commit-hash))))))
(case (most-appropriate-mime-type
'(application/json text/html)
mime-types)
@@ -718,7 +785,6 @@
#:header-text
header-text))))))
(define* (render-revision-package mime-types
- conn
commit-hash
name
#:key
@@ -729,13 +795,17 @@
(header-link
(string-append
"/revision/" commit-hash)))
- (let ((package-versions
- (select-package-versions-for-revision conn
- commit-hash
- name))
- (git-repositories-and-branches
- (git-branches-with-repository-details-for-commit conn
- commit-hash)))
+ (letpar& ((package-versions
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-package-versions-for-revision conn
+ commit-hash
+ name))))
+ (git-repositories-and-branches
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (git-branches-with-repository-details-for-commit conn
+
commit-hash)))))
(case (most-appropriate-mime-type
'(application/json text/html)
mime-types)
@@ -755,7 +825,6 @@
#:extra-headers http-headers-for-unchanging-content)))))
(define* (render-revision-package-version mime-types
- conn
commit-hash
name
version
@@ -774,36 +843,48 @@
(match-lambda
((locale)
locale))
- (delete-duplicates
- (append
- (package-description-and-synopsis-locale-options-guix-revision
- conn (commit->revision-id conn commit-hash))
- (lint-warning-message-locales-for-revision conn commit-hash)))))
+ (parallel-via-thread-pool-channel
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (delete-duplicates
+ (append
+ (package-description-and-synopsis-locale-options-guix-revision
+ conn (commit->revision-id conn commit-hash))
+ (lint-warning-message-locales-for-revision conn commit-hash))))))))
- (let* ((locale (assq-ref query-parameters 'locale))
- (metadata
- (select-package-metadata-by-revision-name-and-version
- conn
- commit-hash
- name
- version
- locale))
- (derivations
- (select-derivations-by-revision-name-and-version
- conn
- commit-hash
- name
- version))
- (git-repositories
- (git-repositories-containing-commit conn
- commit-hash))
- (lint-warnings
- (select-lint-warnings-by-revision-package-name-and-version
- conn
- commit-hash
- name
- version
- #:locale locale)))
+ (define locale (assq-ref query-parameters 'locale))
+
+ (letpar& ((metadata
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-package-metadata-by-revision-name-and-version
+ conn
+ commit-hash
+ name
+ version
+ locale))))
+ (derivations
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-derivations-by-revision-name-and-version
+ conn
+ commit-hash
+ name
+ version))))
+ (git-repositories
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (git-repositories-containing-commit conn
+ commit-hash))))
+ (lint-warnings
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-lint-warnings-by-revision-package-name-and-version
+ conn
+ commit-hash
+ name
+ version
+ #:locale locale)))))
(case (most-appropriate-mime-type
'(application/json text/html)
mime-types)
@@ -843,7 +924,6 @@
#:extra-headers http-headers-for-unchanging-content)))))
(define* (render-revision-package-derivations mime-types
- conn
commit-hash
query-parameters
#:key
@@ -861,100 +941,110 @@
(render-json
`((error . "invalid query"))))
(else
- (render-html
- #:sxml (view-revision-package-derivations commit-hash
- query-parameters
- (valid-systems conn)
- (valid-targets->options
- (valid-targets conn))
- '()
- '()
- #f
- #:path-base path-base
- #:header-text header-text
- #:header-link
header-link))))
- (let* ((limit-results
- (assq-ref query-parameters 'limit_results))
- (all-results
- (assq-ref query-parameters 'all_results))
- (search-query
- (assq-ref query-parameters 'search_query))
- (fields
- (assq-ref query-parameters 'field))
- (derivations
- (if search-query
- (search-package-derivations-in-revision
- conn
- commit-hash
- search-query
- #:systems (assq-ref query-parameters 'system)
- #:targets (assq-ref query-parameters 'target)
- #:maximum-builds (assq-ref query-parameters 'maximum_builds)
- #:minimum-builds (assq-ref query-parameters 'minimum_builds)
- #:limit-results limit-results
- #:after-name (assq-ref query-parameters 'after_name)
- #:include-builds? (member "builds" fields))
- (select-package-derivations-in-revision
- conn
- commit-hash
- #:systems (assq-ref query-parameters 'system)
- #:targets (assq-ref query-parameters 'target)
- #:maximum-builds (assq-ref query-parameters 'maximum_builds)
- #:minimum-builds (assq-ref query-parameters 'minimum_builds)
- #:limit-results limit-results
- #:after-name (assq-ref query-parameters 'after_name)
- #:include-builds? (member "builds" fields))))
- (build-server-urls
- (select-build-server-urls-by-id conn))
- (show-next-page?
- (if all-results
- #f
- (and (not (null? derivations))
- (>= (length derivations)
- limit-results)))))
- (case (most-appropriate-mime-type
- '(application/json text/html)
- mime-types)
- ((application/json)
- (render-json
- `((derivations . ,(list->vector
- (map (match-lambda
- ((derivation system target)
- `((derivation . ,derivation)
- ,@(if (member "system" fields)
- `((system . ,system))
- '())
- ,@(if (member "target" fields)
- `((target . ,target))
- '())))
- ((derivation system target builds)
- `((derivation . ,derivation)
- ,@(if (member "system" fields)
- `((system . ,system))
- '())
- ,@(if (member "target" fields)
- `((target . ,target))
- '())
- (builds . ,builds))))
- derivations))))))
- (else
+ (letpar& ((systems
+ (with-thread-postgresql-connection valid-systems))
+ (targets
+ (with-thread-postgresql-connection valid-targets)))
(render-html
- #:sxml (view-revision-package-derivations
- commit-hash
- query-parameters
- (valid-systems conn)
- (valid-targets->options
- (valid-targets conn))
- derivations
- build-server-urls
- show-next-page?
- #:path-base path-base
- #:header-text header-text
- #:header-link header-link)))))))
+ #:sxml (view-revision-package-derivations commit-hash
+ query-parameters
+ systems
+ (valid-targets->options
+ targets)
+ '()
+ '()
+ #f
+ #:path-base path-base
+ #:header-text header-text
+ #:header-link
header-link)))))
+ (let ((limit-results
+ (assq-ref query-parameters 'limit_results))
+ (all-results
+ (assq-ref query-parameters 'all_results))
+ (search-query
+ (assq-ref query-parameters 'search_query))
+ (fields
+ (assq-ref query-parameters 'field)))
+ (letpar&
+ ((derivations
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (if search-query
+ (search-package-derivations-in-revision
+ conn
+ commit-hash
+ search-query
+ #:systems (assq-ref query-parameters 'system)
+ #:targets (assq-ref query-parameters 'target)
+ #:maximum-builds (assq-ref query-parameters
'maximum_builds)
+ #:minimum-builds (assq-ref query-parameters
'minimum_builds)
+ #:limit-results limit-results
+ #:after-name (assq-ref query-parameters 'after_name)
+ #:include-builds? (member "builds" fields))
+ (select-package-derivations-in-revision
+ conn
+ commit-hash
+ #:systems (assq-ref query-parameters 'system)
+ #:targets (assq-ref query-parameters 'target)
+ #:maximum-builds (assq-ref query-parameters
'maximum_builds)
+ #:minimum-builds (assq-ref query-parameters
'minimum_builds)
+ #:limit-results limit-results
+ #:after-name (assq-ref query-parameters 'after_name)
+ #:include-builds? (member "builds" fields))))))
+ (build-server-urls
+ (with-thread-postgresql-connection
+ select-build-server-urls-by-id)))
+ (let ((show-next-page?
+ (if all-results
+ #f
+ (and (not (null? derivations))
+ (>= (length derivations)
+ limit-results)))))
+ (case (most-appropriate-mime-type
+ '(application/json text/html)
+ mime-types)
+ ((application/json)
+ (render-json
+ `((derivations . ,(list->vector
+ (map (match-lambda
+ ((derivation system target)
+ `((derivation . ,derivation)
+ ,@(if (member "system" fields)
+ `((system . ,system))
+ '())
+ ,@(if (member "target" fields)
+ `((target . ,target))
+ '())))
+ ((derivation system target builds)
+ `((derivation . ,derivation)
+ ,@(if (member "system" fields)
+ `((system . ,system))
+ '())
+ ,@(if (member "target" fields)
+ `((target . ,target))
+ '())
+ (builds . ,builds))))
+ derivations))))))
+ (else
+ (letpar& ((systems
+ (with-thread-postgresql-connection valid-systems))
+ (targets
+ (with-thread-postgresql-connection valid-targets)))
+ (render-html
+ #:sxml (view-revision-package-derivations
+ commit-hash
+ query-parameters
+ systems
+ (valid-targets->options targets)
+ derivations
+ build-server-urls
+ show-next-page?
+ #:path-base path-base
+ #:header-text header-text
+ #:header-link header-link))))))))))
(define* (render-revision-package-derivation-outputs
mime-types
- conn
commit-hash
query-parameters
#:key
@@ -964,7 +1054,8 @@
(header-link
(string-append "/revision/" commit-hash)))
(define build-server-urls
- (select-build-server-urls-by-id conn))
+ (parallel-via-thread-pool-channel
+ (with-thread-postgresql-connection select-build-server-urls-by-id)))
(if (any-invalid-query-parameters? query-parameters)
(case (most-appropriate-mime-type
@@ -974,66 +1065,74 @@
(render-json
`((error . "invalid query"))))
(else
- (render-html
- #:sxml (view-revision-package-derivation-outputs
- commit-hash
- query-parameters
- '()
- build-server-urls
- (valid-systems conn)
- (valid-targets->options
- (valid-targets conn))
- #f
- #:path-base path-base
- #:header-text header-text
- #:header-link header-link))))
- (let* ((limit-results
- (assq-ref query-parameters 'limit_results))
- (all-results
- (assq-ref query-parameters 'all_results))
- (derivation-outputs
- (select-derivation-outputs-in-revision
- conn
- commit-hash
- #:search-query (assq-ref query-parameters 'search_query)
- #:nars-from-build-servers
- (assq-ref query-parameters 'substitutes_available_from)
- #:no-nars-from-build-servers
- (assq-ref query-parameters 'substitutes_not_available_from)
- #:output-consistency
- (assq-ref query-parameters 'output_consistency)
- #:system (assq-ref query-parameters 'system)
- #:target (assq-ref query-parameters 'target)
- #:limit-results limit-results
- #:after-path (assq-ref query-parameters 'after_path)))
- (show-next-page?
- (if all-results
- #f
- (>= (length derivation-outputs)
- limit-results))))
- (case (most-appropriate-mime-type
- '(application/json text/html)
- mime-types)
- ((application/json)
- (render-json
- `()))
- (else
+ (letpar& ((systems
+ (with-thread-postgresql-connection valid-systems))
+ (targets
+ (with-thread-postgresql-connection valid-targets)))
(render-html
#:sxml (view-revision-package-derivation-outputs
commit-hash
query-parameters
- derivation-outputs
+ '()
build-server-urls
- (valid-systems conn)
- (valid-targets->options
- (valid-targets conn))
- show-next-page?
+ systems
+ (valid-targets->options targets)
+ #f
#:path-base path-base
#:header-text header-text
- #:header-link header-link)))))))
+ #:header-link header-link)))))
+ (let ((limit-results
+ (assq-ref query-parameters 'limit_results))
+ (all-results
+ (assq-ref query-parameters 'all_results)))
+ (letpar&
+ ((derivation-outputs
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-derivation-outputs-in-revision
+ conn
+ commit-hash
+ #:search-query (assq-ref query-parameters 'search_query)
+ #:nars-from-build-servers
+ (assq-ref query-parameters 'substitutes_available_from)
+ #:no-nars-from-build-servers
+ (assq-ref query-parameters 'substitutes_not_available_from)
+ #:output-consistency
+ (assq-ref query-parameters 'output_consistency)
+ #:system (assq-ref query-parameters 'system)
+ #:target (assq-ref query-parameters 'target)
+ #:limit-results limit-results
+ #:after-path (assq-ref query-parameters 'after_path))))))
+ (let ((show-next-page?
+ (if all-results
+ #f
+ (>= (length derivation-outputs)
+ limit-results))))
+ (case (most-appropriate-mime-type
+ '(application/json text/html)
+ mime-types)
+ ((application/json)
+ (render-json
+ `()))
+ (else
+ (letpar& ((systems
+ (with-thread-postgresql-connection valid-systems))
+ (targets
+ (with-thread-postgresql-connection valid-targets)))
+ (render-html
+ #:sxml (view-revision-package-derivation-outputs
+ commit-hash
+ query-parameters
+ derivation-outputs
+ build-server-urls
+ systems
+ (valid-targets->options targets)
+ show-next-page?
+ #:path-base path-base
+ #:header-text header-text
+ #:header-link header-link))))))))))
(define* (render-revision-builds mime-types
- conn
commit-hash
query-parameters
#:key
@@ -1043,51 +1142,69 @@
(header-link
(string-append "/revision/" commit-hash)))
(if (any-invalid-query-parameters? query-parameters)
- (render-html
- #:sxml (view-revision-builds query-parameters
- commit-hash
- build-status-strings
- (valid-systems conn)
- (valid-targets->options
- (valid-targets conn))
- '()
- '()
- '()))
+ (letpar& ((systems
+ (with-thread-postgresql-connection valid-systems))
+ (targets
+ (with-thread-postgresql-connection valid-targets)))
+ (render-html
+ #:sxml
+ (view-revision-builds query-parameters
+ commit-hash
+ build-status-strings
+ systems
+ (valid-targets->options targets)
+ '()
+ '()
+ '())))
(let ((system (assq-ref query-parameters 'system))
(target (assq-ref query-parameters 'target)))
- (render-html
- #:sxml (view-revision-builds query-parameters
- commit-hash
- build-status-strings
- (valid-systems conn)
- (valid-targets->options
- (valid-targets conn))
- (map (match-lambda
- ((id url lookup-all-derivations
- lookup-builds)
- (cons url id)))
- (select-build-servers conn))
- (select-build-stats
- conn
- (assq-ref query-parameters
- 'build_server)
- #:revision-commit commit-hash
- #:system system
- #:target target)
- (select-builds-with-context
- conn
- (assq-ref query-parameters
- 'build_status)
- (assq-ref query-parameters
- 'build_server)
- #:revision-commit commit-hash
- #:system system
- #:target target
- #:limit (assq-ref query-parameters
- 'limit_results)))))))
+ (letpar& ((systems
+ (with-thread-postgresql-connection valid-systems))
+ (targets
+ (with-thread-postgresql-connection valid-targets))
+ (build-server-options
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (map (match-lambda
+ ((id url lookup-all-derivations
+ lookup-builds)
+ (cons url id)))
+ (select-build-servers conn)))))
+ (stats
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-build-stats
+ conn
+ (assq-ref query-parameters
+ 'build_server)
+ #:revision-commit commit-hash
+ #:system system
+ #:target target))))
+ (builds
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-builds-with-context
+ conn
+ (assq-ref query-parameters
+ 'build_status)
+ (assq-ref query-parameters
+ 'build_server)
+ #:revision-commit commit-hash
+ #:system system
+ #:target target
+ #:limit (assq-ref query-parameters
+ 'limit_results))))))
+ (render-html
+ #:sxml (view-revision-builds query-parameters
+ commit-hash
+ build-status-strings
+ systems
+ (valid-targets->options targets)
+ build-server-options
+ stats
+ builds))))))
(define* (render-revision-lint-warnings mime-types
- conn
commit-hash
query-parameters
#:key
@@ -1097,18 +1214,24 @@
(header-link
(string-append "/revision/"
commit-hash)))
(define lint-checker-options
- (map (match-lambda
- ((name description network-dependent)
- (cons (string-append name ": " description )
- name)))
- (lint-checkers-for-revision conn commit-hash)))
+ (parallel-via-thread-pool-channel
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (map (match-lambda
+ ((name description network-dependent)
+ (cons (string-append name ": " description )
+ name)))
+ (lint-checkers-for-revision conn commit-hash))))))
(define lint-warnings-locale-options
- (map
- (match-lambda
- ((locale)
- locale))
- (lint-warning-message-locales-for-revision conn commit-hash)))
+ (parallel-via-thread-pool-channel
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (map
+ (match-lambda
+ ((locale)
+ locale))
+ (lint-warning-message-locales-for-revision conn commit-hash))))))
(if (any-invalid-query-parameters? query-parameters)
(case (most-appropriate-mime-type
@@ -1125,69 +1248,75 @@
'()
lint-checker-options
lint-warnings-locale-options
+ #t ;
any-translated-lint-warnings?
#:path-base path-base
#:header-text header-text
#:header-link header-link))))
- (let* ((locale (assq-ref query-parameters 'locale))
- (package-query (assq-ref query-parameters 'package_query))
- (linters (assq-ref query-parameters 'linter))
- (message-query (assq-ref query-parameters 'message_query))
- (fields (assq-ref query-parameters 'field))
- (git-repositories
- (git-repositories-containing-commit conn
- commit-hash))
+ (let ((locale (assq-ref query-parameters 'locale))
+ (package-query (assq-ref query-parameters 'package_query))
+ (linters (assq-ref query-parameters 'linter))
+ (message-query (assq-ref query-parameters 'message_query))
+ (fields (assq-ref query-parameters 'field)))
+ (letpar&
+ ((git-repositories
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (git-repositories-containing-commit conn
+ commit-hash))))
(lint-warnings
- (lint-warnings-for-guix-revision conn commit-hash
- #:locale locale
- #:package-query package-query
- #:linters linters
- #:message-query message-query))
- (any-translated-lint-warnings?
- (any-translated-lint-warnings? lint-warnings locale)))
- (case (most-appropriate-mime-type
- '(application/json text/html)
- mime-types)
- ((application/json)
- (render-json
- `((revision
- . ((commit . ,commit-hash)))
- (lint_warnings
- . ,(list->vector
- (map (match-lambda
- ((id lint-checker-name lint-checker-description
- lint-checker-description-locale
- lint-checker-network-dependent
- package-name package-version
- file line-number column-number
- message message-locale)
- `((package . ((name . ,package-name)
- (version . ,package-version)))
- ,@(if (member "message" fields)
- `((message . ,message)
- (message-locale . ,message-locale))
- '())
- ,@(if (member "linter" fields)
- `((lint-checker-description .
,lint-checker-description)
- (lint-checker-description-locale .
,lint-checker-description-locale))
- '())
- ,@(if (member "location" fields)
- `((location . ((file . ,file)
- (line-number .
,line-number)
- (column-number .
,column-number))))
- '()))))
- lint-warnings))))
- #:extra-headers http-headers-for-unchanging-content))
- (else
- (render-html
- #:sxml (view-revision-lint-warnings commit-hash
- query-parameters
- lint-warnings
- git-repositories
- lint-checker-options
- lint-warnings-locale-options
- any-translated-lint-warnings?
- #:path-base path-base
- #:header-text header-text
- #:header-link header-link)
- #:extra-headers http-headers-for-unchanging-content))))))
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (lint-warnings-for-guix-revision conn commit-hash
+ #:locale locale
+ #:package-query package-query
+ #:linters linters
+ #:message-query
message-query)))))
+ (let ((any-translated-lint-warnings?
+ (any-translated-lint-warnings? lint-warnings locale)))
+ (case (most-appropriate-mime-type
+ '(application/json text/html)
+ mime-types)
+ ((application/json)
+ (render-json
+ `((revision
+ . ((commit . ,commit-hash)))
+ (lint_warnings
+ . ,(list->vector
+ (map (match-lambda
+ ((id lint-checker-name lint-checker-description
+ lint-checker-description-locale
+ lint-checker-network-dependent
+ package-name package-version
+ file line-number column-number
+ message message-locale)
+ `((package . ((name . ,package-name)
+ (version . ,package-version)))
+ ,@(if (member "message" fields)
+ `((message . ,message)
+ (message-locale . ,message-locale))
+ '())
+ ,@(if (member "linter" fields)
+ `((lint-checker-description .
,lint-checker-description)
+ (lint-checker-description-locale .
,lint-checker-description-locale))
+ '())
+ ,@(if (member "location" fields)
+ `((location . ((file . ,file)
+ (line-number .
,line-number)
+ (column-number .
,column-number))))
+ '()))))
+ lint-warnings))))
+ #:extra-headers http-headers-for-unchanging-content))
+ (else
+ (render-html
+ #:sxml (view-revision-lint-warnings commit-hash
+ query-parameters
+ lint-warnings
+ git-repositories
+ lint-checker-options
+
lint-warnings-locale-options
+
any-translated-lint-warnings?
+ #:path-base path-base
+ #:header-text header-text
+ #:header-link header-link)
+ #:extra-headers http-headers-for-unchanging-content))))))))
- branch master updated (470573b -> 55eaaae), Christopher Baines, 2020/10/03
- 01/06: Extract out opening PostgreSQL connections, Christopher Baines, 2020/10/03
- 02/06: Add some utilities to work with PostgreSQL connections in threads, Christopher Baines, 2020/10/03
- 03/06: Stop opening a PostgreSQL connection per request, Christopher Baines, 2020/10/03
- 05/06: Completely rework the way db connections are handled during requests,
Christopher Baines <=
- 04/06: Rework the shortlived PostgreSQL specific connection channel, Christopher Baines, 2020/10/03
- 06/06: Bump the copyright date in the footer, Christopher Baines, 2020/10/03