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

Completely rework the way db connections are handled during requests

Browse source 
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.
This commit is contained in:
Christopher Baines 2020-10-03 21:35:31 +01:00
parent e2e55c69de
commit c3c9c07f9a
9 changed files with 1771 additions and 1366 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -20,6 +20,7 @@
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (rnrs bytevectors) #:use-module (rnrs bytevectors)
#:use-module (json) #:use-module (json)
#:use-module (guix-data-service utils)
#:use-module (guix-data-service database) #:use-module (guix-data-service database)
#:use-module (guix-data-service web render) #:use-module (guix-data-service web render)
#:use-module (guix-data-service web query-parameters) #:use-module (guix-data-service web query-parameters)
@ -36,7 +37,6 @@
#:export (build-server-controller)) #:export (build-server-controller))
(define (render-build mime-types (define (render-build mime-types
conn
build-server-id build-server-id
query-parameters) query-parameters)
(if (any-invalid-query-parameters? query-parameters) (if (any-invalid-query-parameters? query-parameters)
@ -56,6 +56,9 @@
(build-server-build-id (build-server-build-id
(assq-ref query-parameters 'build_server_build_id)) (assq-ref query-parameters 'build_server_build_id))
(build (build
(parallel-via-thread-pool-channel
(with-thread-postgresql-connection
(lambda (conn)
(if build-server-build-id (if build-server-build-id
(select-build-by-build-server-and-build-server-build-id (select-build-by-build-server-and-build-server-build-id
conn conn
@ -64,7 +67,7 @@
(select-build-by-build-server-and-derivation-file-name (select-build-by-build-server-and-derivation-file-name
conn conn
build-server-id build-server-id
derivation-file-name)))) derivation-file-name)))))))
(if build (if build
(render-html (render-html
#:sxml #:sxml
@ -80,10 +83,13 @@
; guix-build-coordinator ; guix-build-coordinator
; doesn't mark builds as ; doesn't mark builds as
; failed-dependency ; failed-dependency
(parallel-via-thread-pool-channel
(with-thread-postgresql-connection
(lambda (conn)
(select-required-builds-that-failed (select-required-builds-that-failed
conn conn
build-server-id build-server-id
derivation-file-name) derivation-file-name))))
#f))))) #f)))))
(render-html (render-html
#:sxml (general-not-found #:sxml (general-not-found
@ -106,12 +112,11 @@
(define (handle-build-event-submission parsed-query-parameters (define (handle-build-event-submission parsed-query-parameters
build-server-id-string build-server-id-string
body body
conn
secret-key-base) secret-key-base)
(define build-server-id (define build-server-id
(string->number build-server-id-string)) (string->number build-server-id-string))
(define (handle-derivation-events items) (define (handle-derivation-events conn items)
(unless (null? items) (unless (null? items)
(let ((build-ids (let ((build-ids
(insert-builds conn (insert-builds conn
@ -132,30 +137,38 @@
items))))) items)))))
(define (process-items items) (define (process-items items)
(parallel-via-thread-pool-channel
(with-thread-postgresql-connection
(lambda (conn)
(with-postgresql-transaction (with-postgresql-transaction
conn conn
(lambda (conn) (lambda (conn)
(handle-derivation-events (handle-derivation-events
conn
(filter (lambda (item) (filter (lambda (item)
(let ((type (assoc-ref item "type"))) (let ((type (assoc-ref item "type")))
(if type (if type
(string=? type "build") (string=? type "build")
(begin (begin
(simple-format (current-error-port) (simple-format
(current-error-port)
"warning: unknown type for event: ~A\n" "warning: unknown type for event: ~A\n"
item) item)
#f)))) #f))))
items))))) items))))))))
(if (any-invalid-query-parameters? parsed-query-parameters) (if (any-invalid-query-parameters? parsed-query-parameters)
(render-json (render-json
'((error . "no token provided")) '((error . "no token provided"))
#:code 400) #:code 400)
(let ((provided-token (assq-ref parsed-query-parameters 'token)) (let ((provided-token (assq-ref parsed-query-parameters 'token))
(permitted-tokens (compute-tokens-for-build-server (permitted-tokens
conn (parallel-via-thread-pool-channel
(with-thread-postgresql-connection
(lambda (conn)
(compute-tokens-for-build-server conn
secret-key-base secret-key-base
build-server-id))) build-server-id))))))
(if (member provided-token (if (member provided-token
(map cdr permitted-tokens) (map cdr permitted-tokens)
string=?) string=?)
@ -201,25 +214,32 @@
'((error . "error")) '((error . "error"))
#:code 403))))) #:code 403)))))
(define (handle-signing-key-request conn id) (define (handle-signing-key-request id)
(render-html (render-html
#:sxml (view-signing-key #: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 (define (build-server-controller request
method-and-path-components method-and-path-components
mime-types mime-types
body body
conn
secret-key-base) secret-key-base)
(match method-and-path-components (match method-and-path-components
(('GET "build-servers") (('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 (render-build-servers mime-types
build-servers))) build-servers)))
(('GET "build-server" build-server-id) (('GET "build-server" build-server-id)
(let ((build-server (select-build-server conn (string->number (letpar& ((build-server
build-server-id)))) (with-thread-postgresql-connection
(lambda (conn)
(select-build-server conn (string->number
build-server-id))))))
(if build-server (if build-server
(render-build-server mime-types (render-build-server mime-types
build-server) build-server)
@ -231,7 +251,6 @@
`((derivation_file_name ,identity) `((derivation_file_name ,identity)
(build_server_build_id ,identity))))) (build_server_build_id ,identity)))))
(render-build mime-types (render-build mime-types
conn
(string->number build-server-id) (string->number build-server-id)
parsed-query-parameters))) parsed-query-parameters)))
(('POST "build-server" build-server-id "build-events") (('POST "build-server" build-server-id "build-events")
@ -242,9 +261,7 @@
(handle-build-event-submission parsed-query-parameters (handle-build-event-submission parsed-query-parameters
build-server-id build-server-id
body body
conn
secret-key-base))) secret-key-base)))
(('GET "build-server" "signing-key" id) (('GET "build-server" "signing-key" id)
(handle-signing-key-request conn (handle-signing-key-request (string->number id)))
(string->number id)))
(_ #f))) (_ #f)))

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

@ -18,6 +18,8 @@
(define-module (guix-data-service web build controller) (define-module (guix-data-service web build controller)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (ice-9 match) #: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 render)
#:use-module (guix-data-service web query-parameters) #:use-module (guix-data-service web query-parameters)
#:use-module (guix-data-service model build) #:use-module (guix-data-service model build)
@ -34,9 +36,11 @@
(string-append "unknown build status: " (string-append "unknown build status: "
status)))) status))))
(define (parse-build-server conn) (define parse-build-server
(lambda (v) (lambda (v)
(let ((build-servers (select-build-servers conn))) (letpar& ((build-servers
(with-thread-postgresql-connection
select-build-servers)))
(or (any (match-lambda (or (any (match-lambda
((id url lookup-all-derivations? lookup-builds?) ((id url lookup-all-derivations? lookup-builds?)
(if (eq? (string->number v) (if (eq? (string->number v)
@ -51,21 +55,19 @@
(define (build-controller request (define (build-controller request
method-and-path-components method-and-path-components
mime-types mime-types
body body)
conn)
(match method-and-path-components (match method-and-path-components
(('GET "builds") (('GET "builds")
(render-builds request (render-builds request
mime-types mime-types))
conn))
(_ #f))) (_ #f)))
(define (render-builds request mime-types conn) (define (render-builds request mime-types)
(let ((parsed-query-parameters (let ((parsed-query-parameters
(parse-query-parameters (parse-query-parameters
request request
`((build_status ,parse-build-status #:multi-value) `((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) (if (any-invalid-query-parameters? parsed-query-parameters)
(render-html (render-html
#:sxml (view-builds parsed-query-parameters #:sxml (view-builds parsed-query-parameters
@ -73,20 +75,29 @@
'() '()
'() '()
'())) '()))
(render-html (letpar& ((build-servers
#:sxml (view-builds parsed-query-parameters (with-thread-postgresql-connection
build-status-strings select-build-servers))
(map (match-lambda (build-stats
((id url lookup-all-derivations lookup-builds) (with-thread-postgresql-connection
(cons url id))) (lambda (conn)
(select-build-servers conn))
(select-build-stats (select-build-stats
conn conn
(assq-ref parsed-query-parameters (assq-ref parsed-query-parameters
'build_server)) 'build_server)))))
(builds-with-context
(with-thread-postgresql-connection
(lambda (conn)
(select-builds-with-context (select-builds-with-context
conn conn
(assq-ref parsed-query-parameters (assq-ref parsed-query-parameters
'build_status) 'build_status)
(assq-ref parsed-query-parameters (assq-ref parsed-query-parameters
'build_server))))))) 'build_server))))))
(render-html
#:sxml (view-builds parsed-query-parameters
build-status-strings
build-servers
build-stats
builds-with-context))))))

328
guix-data-service/web/compare/controller.scm
View file

@ -23,6 +23,8 @@
#:use-module (texinfo) #:use-module (texinfo)
#:use-module (texinfo html) #:use-module (texinfo html)
#:use-module (texinfo plain-text) #: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 sxml)
#:use-module (guix-data-service web util) #:use-module (guix-data-service web util)
#:use-module (guix-data-service web render) #:use-module (guix-data-service web render)
@ -48,35 +50,37 @@
(define (parse-build-status s) (define (parse-build-status s)
s) s)
(define (parse-commit conn) (define (parse-commit s)
(lambda (s) (if (parallel-via-thread-pool-channel
(if (guix-commit-exists? conn s) (with-thread-postgresql-connection
(lambda (conn)
(guix-commit-exists? conn s))))
s s
(make-invalid-query-parameter (make-invalid-query-parameter
s "unknown commit")))) s "unknown commit")))
(define (parse-derivation conn) (define (parse-derivation file-name)
(lambda (file-name) (if (parallel-via-thread-pool-channel
(if (select-derivation-by-file-name conn file-name) (with-thread-postgresql-connection
(lambda (conn)
(select-derivation-by-file-name conn file-name))))
file-name file-name
(make-invalid-query-parameter (make-invalid-query-parameter
file-name "unknown derivation")))) file-name "unknown derivation")))
(define (compare-controller request (define (compare-controller request
method-and-path-components method-and-path-components
mime-types mime-types
body body)
conn)
(match method-and-path-components (match method-and-path-components
(('GET "compare") (('GET "compare")
(let* ((parsed-query-parameters (let* ((parsed-query-parameters
(parse-query-parameters (parse-query-parameters
request request
`((base_commit ,(parse-commit conn) #:required) `((base_commit ,parse-commit #:required)
(target_commit ,(parse-commit conn) #:required) (target_commit ,parse-commit #:required)
(locale ,identity #:default "en_US.UTF-8"))))) (locale ,identity #:default "en_US.UTF-8")))))
(render-compare mime-types (render-compare mime-types
conn
parsed-query-parameters))) parsed-query-parameters)))
(('GET "compare-by-datetime") (('GET "compare-by-datetime")
(let* ((parsed-query-parameters (let* ((parsed-query-parameters
@ -88,28 +92,25 @@
(target_datetime ,parse-datetime #:required) (target_datetime ,parse-datetime #:required)
(locale ,identity #:default "en_US.UTF-8"))))) (locale ,identity #:default "en_US.UTF-8")))))
(render-compare-by-datetime mime-types (render-compare-by-datetime mime-types
conn
parsed-query-parameters))) parsed-query-parameters)))
(('GET "compare" "derivation") (('GET "compare" "derivation")
(let* ((parsed-query-parameters (let* ((parsed-query-parameters
(parse-query-parameters (parse-query-parameters
request request
`((base_derivation ,(parse-derivation conn) #:required) `((base_derivation ,parse-derivation #:required)
(target_derivation ,(parse-derivation conn) #:required))))) (target_derivation ,parse-derivation #:required)))))
(render-compare/derivation mime-types (render-compare/derivation mime-types
conn
parsed-query-parameters))) parsed-query-parameters)))
(('GET "compare" "derivations") (('GET "compare" "derivations")
(let* ((parsed-query-parameters (let* ((parsed-query-parameters
(parse-query-parameters (parse-query-parameters
request request
`((base_commit ,(parse-commit conn) #:required) `((base_commit ,parse-commit #:required)
(target_commit ,(parse-commit conn) #:required) (target_commit ,parse-commit #:required)
(system ,parse-system #:multi-value) (system ,parse-system #:multi-value)
(target ,parse-target #:multi-value) (target ,parse-target #:multi-value)
(build_status ,parse-build-status #:multi-value))))) (build_status ,parse-build-status #:multi-value)))))
(render-compare/derivations mime-types (render-compare/derivations mime-types
conn
parsed-query-parameters))) parsed-query-parameters)))
(('GET "compare-by-datetime" "derivations") (('GET "compare-by-datetime" "derivations")
(let* ((parsed-query-parameters (let* ((parsed-query-parameters
@ -126,16 +127,14 @@
'((base_commit base_datetime) '((base_commit base_datetime)
(target_commit target_datetime))))) (target_commit target_datetime)))))
(render-compare-by-datetime/derivations mime-types (render-compare-by-datetime/derivations mime-types
conn
parsed-query-parameters))) parsed-query-parameters)))
(('GET "compare" "packages") (('GET "compare" "packages")
(let* ((parsed-query-parameters (let* ((parsed-query-parameters
(parse-query-parameters (parse-query-parameters
request request
`((base_commit ,(parse-commit conn) #:required) `((base_commit ,parse-commit #:required)
(target_commit ,(parse-commit conn) #:required))))) (target_commit ,parse-commit #:required)))))
(render-compare/packages mime-types (render-compare/packages mime-types
conn
parsed-query-parameters))) parsed-query-parameters)))
(_ #f))) (_ #f)))
@ -148,16 +147,7 @@
(plain . ,(stexi->plain-text stexi))))) (plain . ,(stexi->plain-text stexi)))))
(define (render-compare mime-types (define (render-compare mime-types
conn
query-parameters) 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) (if (any-invalid-query-parameters? query-parameters)
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
'(application/json text/html) '(application/json text/html)
@ -166,32 +156,50 @@
(render-json (render-json
'((error . "invalid query")))) '((error . "invalid query"))))
(else (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 (render-html
#:sxml (compare-invalid-parameters #:sxml (compare-invalid-parameters
query-parameters query-parameters
(match (assq-ref query-parameters 'base_commit) base-job
(($ <invalid-query-parameter> value) target-job)))))
(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-revision-id (commit->revision-id (letpar& ((base-revision-id
(with-thread-postgresql-connection
(lambda (conn)
(commit->revision-id
conn conn
(assq-ref query-parameters 'base_commit))) (assq-ref query-parameters 'base_commit)))))
(target-revision-id (commit->revision-id (target-revision-id
(with-thread-postgresql-connection
(lambda (conn)
(commit->revision-id
conn conn
(assq-ref query-parameters 'target_commit))) (assq-ref query-parameters 'target_commit)))))
(locale (assq-ref query-parameters 'locale))) (locale
(assq-ref query-parameters 'locale)))
(let-values (let-values
(((base-packages-vhash target-packages-vhash) (((base-packages-vhash target-packages-vhash)
(package-data->package-data-vhashes (package-data->package-data-vhashes
(parallel-via-thread-pool-channel
(with-thread-postgresql-connection
(lambda (conn)
(package-differences-data conn (package-differences-data conn
base-revision-id base-revision-id
target-revision-id)))) target-revision-id)))))))
(let* ((new-packages (let ((new-packages
(package-data-vhashes->new-packages base-packages-vhash (package-data-vhashes->new-packages base-packages-vhash
target-packages-vhash)) target-packages-vhash))
(removed-packages (removed-packages
@ -199,18 +207,22 @@
target-packages-vhash)) target-packages-vhash))
(version-changes (version-changes
(package-data-version-changes base-packages-vhash (package-data-version-changes base-packages-vhash
target-packages-vhash)) target-packages-vhash)))
(lint-warnings-data (letpar& ((lint-warnings-data
(with-thread-postgresql-connection
(lambda (conn)
(group-list-by-first-n-fields (group-list-by-first-n-fields
2 2
(lint-warning-differences-data conn (lint-warning-differences-data conn
base-revision-id base-revision-id
target-revision-id target-revision-id
locale))) locale)))))
(channel-news-data (channel-news-data
(with-thread-postgresql-connection
(lambda (conn)
(channel-news-differences-data conn (channel-news-differences-data conn
base-revision-id base-revision-id
target-revision-id))) target-revision-id)))))
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
'(application/json text/html) '(application/json text/html)
mime-types) mime-types)
@ -255,22 +267,35 @@
version-changes)))) version-changes))))
#:extra-headers http-headers-for-unchanging-content)) #:extra-headers http-headers-for-unchanging-content))
(else (else
(render-html (letpar& ((lint-warnings-locale-options
#:sxml (compare query-parameters (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 (guix-revisions-cgit-url-bases
conn conn
(list base-revision-id (list base-revision-id
target-revision-id)) target-revision-id))))))
(render-html
#:sxml (compare query-parameters
cgit-url-bases
new-packages new-packages
removed-packages removed-packages
version-changes version-changes
lint-warnings-data lint-warnings-data
lint-warnings-locale-options lint-warnings-locale-options
channel-news-data) channel-news-data)
#:extra-headers http-headers-for-unchanging-content)))))))) #:extra-headers http-headers-for-unchanging-content))))))))))
(define (render-compare-by-datetime mime-types (define (render-compare-by-datetime mime-types
conn
query-parameters) query-parameters)
(if (any-invalid-query-parameters? query-parameters) (if (any-invalid-query-parameters? query-parameters)
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
@ -280,48 +305,68 @@
(render-json (render-json
'((error . "invalid query")))) '((error . "invalid query"))))
(else (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 (render-html
#:sxml (compare-invalid-parameters #:sxml (compare-invalid-parameters
query-parameters query-parameters
(match (assq-ref query-parameters 'base_commit) base-job
(($ <invalid-query-parameter> value) target-job)))))
(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)) (let ((base-branch (assq-ref query-parameters 'base_branch))
(base-datetime (assq-ref query-parameters 'base_datetime)) (base-datetime (assq-ref query-parameters 'base_datetime))
(target-branch (assq-ref query-parameters 'target_branch)) (target-branch (assq-ref query-parameters 'target_branch))
(target-datetime (assq-ref query-parameters 'target_datetime)) (target-datetime (assq-ref query-parameters 'target_datetime))
(locale (assq-ref query-parameters 'locale))) (locale (assq-ref query-parameters 'locale)))
(let* ((base-revision-details (letpar& ((base-revision-details
(select-guix-revision-for-branch-and-datetime conn (with-thread-postgresql-connection
(lambda (conn)
(select-guix-revision-for-branch-and-datetime
conn
base-branch base-branch
base-datetime)) base-datetime))))
(lint-warnings-locale-options (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 (map
(match-lambda (match-lambda
((locale) ((locale)
locale)) locale))
(with-thread-postgresql-connection
(lambda (conn)
(lint-warning-message-locales-for-revision (lint-warning-message-locales-for-revision
conn (second base-revision-details)))) conn
(base-revision-id (second base-revision-details)))))))
(let ((base-revision-id
(first base-revision-details)) (first base-revision-details))
(target-revision-details
(select-guix-revision-for-branch-and-datetime conn
target-branch
target-datetime))
(target-revision-id (target-revision-id
(first target-revision-details))) (first target-revision-details)))
(let-values (let-values
(((base-packages-vhash target-packages-vhash) (((base-packages-vhash target-packages-vhash)
(package-data->package-data-vhashes (package-data->package-data-vhashes
(parallel-via-thread-pool-channel
(with-thread-postgresql-connection
(lambda (conn)
(package-differences-data conn (package-differences-data conn
base-revision-id base-revision-id
target-revision-id)))) target-revision-id)))))))
(let* ((new-packages (let* ((new-packages
(package-data-vhashes->new-packages base-packages-vhash (package-data-vhashes->new-packages base-packages-vhash
target-packages-vhash)) target-packages-vhash))
@ -331,17 +376,13 @@
(version-changes (version-changes
(package-data-version-changes base-packages-vhash (package-data-version-changes base-packages-vhash
target-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-data
(parallel-via-thread-pool-channel
(with-thread-postgresql-connection
(lambda (conn)
(channel-news-differences-data conn (channel-news-differences-data conn
base-revision-id base-revision-id
target-revision-id))) target-revision-id))))))
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
'(application/json text/html) '(application/json text/html)
mime-types) mime-types)
@ -397,20 +438,31 @@
#:sxml (compare `(,@query-parameters #:sxml (compare `(,@query-parameters
(base_commit . ,(second base-revision-details)) (base_commit . ,(second base-revision-details))
(target_commit . ,(second target-revision-details))) (target_commit . ,(second target-revision-details)))
(parallel-via-thread-pool-channel
(with-thread-postgresql-connection
(lambda (conn)
(guix-revisions-cgit-url-bases (guix-revisions-cgit-url-bases
conn conn
(list base-revision-id (list base-revision-id
target-revision-id)) target-revision-id)))))
new-packages new-packages
removed-packages removed-packages
version-changes version-changes
lint-warnings-data (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 lint-warnings-locale-options
channel-news-data) channel-news-data)
#:extra-headers http-headers-for-unchanging-content))))))))) #:extra-headers http-headers-for-unchanging-content)))))))))))
(define (render-compare/derivation mime-types (define (render-compare/derivation mime-types
conn
query-parameters) query-parameters)
(if (any-invalid-query-parameters? query-parameters) (if (any-invalid-query-parameters? query-parameters)
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
@ -427,10 +479,12 @@
(let ((base-derivation (assq-ref query-parameters 'base_derivation)) (let ((base-derivation (assq-ref query-parameters 'base_derivation))
(target-derivation (assq-ref query-parameters 'target_derivation))) (target-derivation (assq-ref query-parameters 'target_derivation)))
(let ((data (letpar& ((data
(with-thread-postgresql-connection
(lambda (conn)
(derivation-differences-data conn (derivation-differences-data conn
base-derivation base-derivation
target-derivation))) target-derivation)))))
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
'(application/json text/html) '(application/json text/html)
mime-types) mime-types)
@ -446,7 +500,6 @@
#:extra-headers http-headers-for-unchanging-content))))))) #:extra-headers http-headers-for-unchanging-content)))))))
(define (render-compare/derivations mime-types (define (render-compare/derivations mime-types
conn
query-parameters) query-parameters)
(define (derivations->alist derivations) (define (derivations->alist derivations)
(map (match-lambda (map (match-lambda
@ -470,7 +523,8 @@
(render-html (render-html
#:sxml (compare/derivations #:sxml (compare/derivations
query-parameters query-parameters
(valid-systems conn) (parallel-via-thread-pool-channel
(with-thread-postgresql-connection valid-systems))
build-status-strings build-status-strings
'())))) '()))))
@ -479,15 +533,16 @@
(systems (assq-ref query-parameters 'system)) (systems (assq-ref query-parameters 'system))
(targets (assq-ref query-parameters 'target)) (targets (assq-ref query-parameters 'target))
(build-statuses (assq-ref query-parameters 'build_status))) (build-statuses (assq-ref query-parameters 'build_status)))
(let* (letpar& ((data
((data (with-thread-postgresql-connection
(lambda (conn)
(package-derivation-differences-data (package-derivation-differences-data
conn conn
(commit->revision-id conn base-commit) (commit->revision-id conn base-commit)
(commit->revision-id conn target-commit) (commit->revision-id conn target-commit)
#:systems systems #:systems systems
#:targets targets)) #:targets targets)))))
(names-and-versions (let ((names-and-versions
(package-derivation-data->names-and-versions data))) (package-derivation-data->names-and-versions data)))
(let-values (let-values
(((base-packages-vhash target-packages-vhash) (((base-packages-vhash target-packages-vhash)
@ -507,13 +562,13 @@
(render-html (render-html
#:sxml (compare/derivations #:sxml (compare/derivations
query-parameters query-parameters
(valid-systems conn) (parallel-via-thread-pool-channel
(with-thread-postgresql-connection valid-systems))
build-status-strings build-status-strings
derivation-changes) derivation-changes)
#:extra-headers http-headers-for-unchanging-content))))))))) #:extra-headers http-headers-for-unchanging-content))))))))))
(define (render-compare-by-datetime/derivations mime-types (define (render-compare-by-datetime/derivations mime-types
conn
query-parameters) query-parameters)
(define (derivations->alist derivations) (define (derivations->alist derivations)
(map (match-lambda (map (match-lambda
@ -537,7 +592,8 @@
(render-html (render-html
#:sxml (compare-by-datetime/derivations #:sxml (compare-by-datetime/derivations
query-parameters query-parameters
(valid-systems conn) (parallel-via-thread-pool-channel
(with-thread-postgresql-connection valid-systems))
build-status-strings build-status-strings
'() '()
'() '()
@ -550,22 +606,30 @@
(systems (assq-ref query-parameters 'system)) (systems (assq-ref query-parameters 'system))
(targets (assq-ref query-parameters 'target)) (targets (assq-ref query-parameters 'target))
(build-statuses (assq-ref query-parameters 'build_status))) (build-statuses (assq-ref query-parameters 'build_status)))
(let* (letpar&
((base-revision-details ((base-revision-details
(with-thread-postgresql-connection
(lambda (conn)
(select-guix-revision-for-branch-and-datetime conn (select-guix-revision-for-branch-and-datetime conn
base-branch base-branch
base-datetime)) base-datetime))))
(target-revision-details (target-revision-details
(with-thread-postgresql-connection
(lambda (conn)
(select-guix-revision-for-branch-and-datetime conn (select-guix-revision-for-branch-and-datetime conn
target-branch target-branch
target-datetime)) target-datetime)))))
(data (letpar&
(package-derivation-differences-data conn ((data
(with-thread-postgresql-connection
(lambda (conn)
(package-derivation-differences-data
conn
(first base-revision-details) (first base-revision-details)
(first target-revision-details) (first target-revision-details)
#:systems systems #:systems systems
#:targets targets)) #:targets targets)))))
(names-and-versions (let ((names-and-versions
(package-derivation-data->names-and-versions data))) (package-derivation-data->names-and-versions data)))
(let-values (let-values
(((base-packages-vhash target-packages-vhash) (((base-packages-vhash target-packages-vhash)
@ -585,15 +649,15 @@
(render-html (render-html
#:sxml (compare-by-datetime/derivations #:sxml (compare-by-datetime/derivations
query-parameters query-parameters
(valid-systems conn) (parallel-via-thread-pool-channel
(with-thread-postgresql-connection valid-systems))
build-status-strings build-status-strings
base-revision-details base-revision-details
target-revision-details target-revision-details
derivation-changes) derivation-changes)
#:extra-headers http-headers-for-unchanging-content))))))))) #:extra-headers http-headers-for-unchanging-content)))))))))))
(define (render-compare/packages mime-types (define (render-compare/packages mime-types
conn
query-parameters) query-parameters)
(define (package-data-vhash->json vh) (define (package-data-vhash->json vh)
(delete-duplicates (delete-duplicates
@ -612,29 +676,49 @@
(render-json (render-json
'((error . "invalid query")))) '((error . "invalid query"))))
(else (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 (render-html
#:sxml (compare-invalid-parameters #:sxml (compare-invalid-parameters
query-parameters query-parameters
(match (assq-ref query-parameters 'base_commit) base-job
(($ <invalid-query-parameter> value) target-job)))))
(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-commit (assq-ref query-parameters 'base_commit)) (let ((base-commit (assq-ref query-parameters 'base_commit))
(target-commit (assq-ref query-parameters 'target_commit))) (target-commit (assq-ref query-parameters 'target_commit)))
(let ((base-revision-id (commit->revision-id conn base-commit)) (letpar& ((base-revision-id
(target-revision-id (commit->revision-id conn target-commit))) (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 (let-values
(((base-packages-vhash target-packages-vhash) (((base-packages-vhash target-packages-vhash)
(package-data->package-data-vhashes (package-data->package-data-vhashes
(parallel-via-thread-pool-channel
(with-thread-postgresql-connection
(lambda (conn)
(package-differences-data conn (package-differences-data conn
base-revision-id base-revision-id
target-revision-id)))) target-revision-id)))))))
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
'(application/json text/html) '(application/json text/html)
mime-types) mime-types)

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

@ -19,6 +19,7 @@
(define-module (guix-data-service web controller) (define-module (guix-data-service web controller)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (ice-9 vlist) #:use-module (ice-9 vlist)
#:use-module (ice-9 threads)
#:use-module (ice-9 pretty-print) #:use-module (ice-9 pretty-print)
#:use-module (ice-9 textual-ports) #:use-module (ice-9 textual-ports)
#:use-module (ice-9 string-fun) #:use-module (ice-9 string-fun)
@ -35,6 +36,7 @@
#:use-module (squee) #:use-module (squee)
#:use-module (json) #:use-module (json)
#:use-module (prometheus) #:use-module (prometheus)
#:use-module (guix-data-service utils)
#:use-module (guix-data-service config) #:use-module (guix-data-service config)
#:use-module (guix-data-service comparison) #:use-module (guix-data-service comparison)
#:use-module (guix-data-service database) #:use-module (guix-data-service database)
@ -129,8 +131,20 @@
"_")) "_"))
#:labels '(name)))) #:labels '(name))))
pg-stat-fields))) pg-stat-fields)))
(lambda (conn) (lambda ()
(let ((metric-values (fetch-high-level-table-size-metrics conn))) (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 (for-each (match-lambda
((name row-estimate table-bytes index-bytes toast-bytes) ((name row-estimate table-bytes index-bytes toast-bytes)
@ -146,10 +160,10 @@
(metric-set table-toast-bytes-metric (metric-set table-toast-bytes-metric
toast-bytes toast-bytes
#:label-values `((name . ,name))))) #:label-values `((name . ,name)))))
metric-values)) metric-values)
(metric-set revisions-count-metric (metric-set revisions-count-metric
(count-guix-revisions conn)) guix-revisions-count)
(map (lambda (field-values) (map (lambda (field-values)
(let ((name (assq-ref field-values 'name))) (let ((name (assq-ref field-values 'name)))
@ -163,7 +177,7 @@
value value
#:label-values `((name . ,name)))))) #:label-values `((name . ,name))))))
field-values))) field-values)))
(fetch-pg-stat-user-tables-metrics conn)) pg-stat-user-tables-metrics)
(for-each (match-lambda (for-each (match-lambda
((repository-label completed count) ((repository-label completed count)
@ -173,27 +187,39 @@
#:label-values #:label-values
`((repository_label . ,repository-label) `((repository_label . ,repository-label)
(completed . ,(if completed "yes" "no")))))) (completed . ,(if completed "yes" "no"))))))
(select-load-new-guix-revision-job-metrics conn)) load-new-guix-revision-job-metrics)
(list (build-response (list (build-response
#:code 200 #:code 200
#:headers '((content-type . (text/plain)))) #:headers '((content-type . (text/plain))))
(lambda (port) (lambda (port)
(write-metrics registry 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)))))
(define (render-derivation conn derivation-file-name)
(let ((derivation (select-derivation-by-file-name conn
derivation-file-name)))
(if derivation (if derivation
(let ((derivation-inputs (select-derivation-inputs-by-derivation-id (letpar& ((derivation-inputs
(with-thread-postgresql-connection
(lambda (conn)
(select-derivation-inputs-by-derivation-id
conn conn
(first derivation))) (first derivation)))))
(derivation-outputs (select-derivation-outputs-by-derivation-id (derivation-outputs
(with-thread-postgresql-connection
(lambda (conn)
(select-derivation-outputs-by-derivation-id
conn conn
(first derivation))) (first derivation)))))
(builds (select-builds-with-context-by-derivation-file-name (builds
(with-thread-postgresql-connection
(lambda (conn)
(select-builds-with-context-by-derivation-file-name
conn conn
(second derivation)))) (second derivation))))))
(render-html (render-html
#:sxml (view-derivation derivation #:sxml (view-derivation derivation
derivation-inputs derivation-inputs
@ -207,19 +233,32 @@
"No derivation found with this file name.") "No derivation found with this file name.")
#:code 404)))) #:code 404))))
(define (render-json-derivation conn derivation-file-name) (define (render-json-derivation derivation-file-name)
(let ((derivation (select-derivation-by-file-name conn (let ((derivation
derivation-file-name))) (parallel-via-thread-pool-channel
(with-thread-postgresql-connection
(lambda (conn)
(select-derivation-by-file-name conn
derivation-file-name))))))
(if derivation (if derivation
(let ((derivation-inputs (select-derivation-inputs-by-derivation-id (letpar& ((derivation-inputs
(with-thread-postgresql-connection
(lambda (conn)
(select-derivation-inputs-by-derivation-id
conn conn
(first derivation))) (first derivation)))))
(derivation-outputs (select-derivation-outputs-by-derivation-id (derivation-outputs
(with-thread-postgresql-connection
(lambda (conn)
(select-derivation-outputs-by-derivation-id
conn conn
(first derivation))) (first derivation)))))
(derivation-sources (select-derivation-sources-by-derivation-id (derivation-sources
(with-thread-postgresql-connection
(lambda (conn)
(select-derivation-sources-by-derivation-id
conn conn
(first derivation)))) (first derivation))))))
(render-json (render-json
`((inputs . ,(list->vector `((inputs . ,(list->vector
(map (map
@ -255,19 +294,35 @@
env-var)))))))) env-var))))))))
(render-json '((error . "invalid path")))))) (render-json '((error . "invalid path"))))))
(define (render-formatted-derivation conn derivation-file-name) (define (render-formatted-derivation derivation-file-name)
(let ((derivation (select-derivation-by-file-name conn (let ((derivation
derivation-file-name))) (parallel-via-thread-pool-channel
(with-thread-postgresql-connection
(lambda (conn)
(select-derivation-by-file-name conn
derivation-file-name))))))
(if derivation (if derivation
(let ((derivation-inputs (select-derivation-inputs-by-derivation-id (letpar& ((derivation-inputs
(parallel-via-thread-pool-channel
(with-thread-postgresql-connection
(lambda (conn)
(select-derivation-inputs-by-derivation-id
conn conn
(first derivation))) (first derivation))))))
(derivation-outputs (select-derivation-outputs-by-derivation-id (derivation-outputs
(parallel-via-thread-pool-channel
(with-thread-postgresql-connection
(lambda (conn)
(select-derivation-outputs-by-derivation-id
conn conn
(first derivation))) (first derivation))))))
(derivation-sources (select-derivation-sources-by-derivation-id (derivation-sources
(parallel-via-thread-pool-channel
(with-thread-postgresql-connection
(lambda (conn)
(select-derivation-sources-by-derivation-id
conn conn
(first derivation)))) (first derivation)))))))
(render-html (render-html
#:sxml (view-formatted-derivation derivation #:sxml (view-formatted-derivation derivation
derivation-inputs derivation-inputs
@ -281,10 +336,14 @@
"No derivation found with this file name.") "No derivation found with this file name.")
#:code 404)))) #:code 404))))
(define (render-narinfos conn filename) (define (render-narinfos filename)
(let ((narinfos (select-nars-for-output (let ((narinfos
(parallel-via-thread-pool-channel
(with-thread-postgresql-connection
(lambda (conn)
(select-nars-for-output
conn conn
(string-append "/gnu/store/" filename)))) (string-append "/gnu/store/" filename)))))))
(if (null? narinfos) (if (null? narinfos)
(render-html (render-html
#:sxml (general-not-found #:sxml (general-not-found
@ -295,11 +354,17 @@
(render-html (render-html
#:sxml (view-narinfos narinfos))))) #:sxml (view-narinfos narinfos)))))
(define (render-store-item conn filename) (define (render-store-item filename)
(let ((derivation (select-derivation-by-output-filename conn filename))) (letpar& ((derivation
(with-thread-postgresql-connection
(lambda (conn)
(select-derivation-by-output-filename conn filename)))))
(match derivation (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 (render-html
#:sxml (general-not-found #:sxml (general-not-found
@ -310,29 +375,52 @@
(render-html (render-html
#:sxml (view-derivation-source-file #:sxml (view-derivation-source-file
filename filename
(select-derivation-source-file-nar-details-by-file-name conn (parallel-via-thread-pool-channel
filename)) (with-thread-postgresql-connection
(lambda (conn)
(select-derivation-source-file-nar-details-by-file-name
conn
filename)))))
#:extra-headers http-headers-for-unchanging-content)))) #:extra-headers http-headers-for-unchanging-content))))
(derivations (derivations
(render-html (letpar& ((derivations-using-store-item-list
#:sxml (view-store-item filename (with-thread-postgresql-connection
derivations (lambda (conn)
(map (lambda (derivation) (map (lambda (derivation)
(match derivation (match derivation
((file-name output-id rest ...) ((file-name output-id rest ...)
(select-derivations-using-output (select-derivations-using-output
conn output-id)))) conn output-id))))
derivations) derivations))))
(select-nars-for-output conn (nars
filename) (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 (select-builds-with-context-by-derivation-output
conn filename))))))) conn
filename)))))
(render-html
#:sxml (view-store-item filename
derivations
derivations-using-store-item-list
nars
builds)))))))
(define (render-json-store-item conn filename) (define (render-json-store-item filename)
(let ((derivation (select-derivation-by-output-filename conn filename))) (let ((derivation
(parallel-via-thread-pool-channel
(with-thread-postgresql-connection
(lambda (conn)
(select-derivation-by-output-filename conn filename))))))
(match derivation (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")))) (render-json '((error . "store item not found"))))
((id) ((id)
@ -343,10 +431,17 @@
(match-lambda (match-lambda
((key . value) ((key . value)
`((,key . ,value)))) `((,key . ,value))))
(parallel-via-thread-pool-channel
(with-thread-postgresql-connection
(lambda (conn)
(select-derivation-source-file-nar-details-by-file-name (select-derivation-source-file-nar-details-by-file-name
conn conn
filename))))))))) filename))))))))))))
(derivations (derivations
(letpar& ((nars
(with-thread-postgresql-connection
(lambda (conn)
(select-nars-for-output conn filename)))))
(render-json (render-json
`((nars . ,(list->vector `((nars . ,(list->vector
(map (map
@ -368,7 +463,7 @@
`((version . ,(assoc-ref signature "version")) `((version . ,(assoc-ref signature "version"))
(host-name . ,(assoc-ref signature "host_name")))) (host-name . ,(assoc-ref signature "host_name"))))
signatures)))))) signatures))))))
(select-nars-for-output conn filename)))) nars)))
(derivations (derivations
. ,(list->vector . ,(list->vector
(map (map
@ -377,9 +472,13 @@
`((filename . ,filename) `((filename . ,filename)
(derivations-using-store-item (derivations-using-store-item
. ,(list->vector . ,(list->vector
(map car (select-derivations-using-output (map car
conn output-id))))))) (parallel-via-thread-pool-channel
derivations))))))))) (with-thread-postgresql-connection
(lambda (conn)
(select-derivations-using-output
conn output-id))))))))))
derivations))))))))))
(define handle-static-assets (define handle-static-assets
(if assets-dir-in-store? (if assets-dir-in-store?
@ -393,7 +492,67 @@
mime-types body mime-types body
secret-key-base) secret-key-base)
(define (controller-thunk) (define (controller-thunk)
(actual-controller request
method-and-path-components
mime-types
body
secret-key-base))
(call-with-error-handling
controller-thunk
#:on-error 'backtrace
#:post-error (lambda args
(render-html #:sxml (error-page
(if (%show-error-details)
args
#f))
#:code 500))))
(define (actual-controller request
method-and-path-components
mime-types
body
secret-key-base)
(define path
(uri-path (request-uri request)))
(define (delegate-to f)
(or (f request
method-and-path-components
mime-types
body)
(render-html
#:sxml (general-not-found
"Page not found"
"")
#:code 404)))
(define (delegate-to-with-secret-key-base f)
(or (f request
method-and-path-components
mime-types
body
secret-key-base)
(render-html
#:sxml (general-not-found
"Page not found"
"")
#:code 404)))
(match method-and-path-components (match method-and-path-components
(('GET)
(render-html
#:sxml (index
(parallel-via-thread-pool-channel
(with-thread-postgresql-connection
(lambda (conn)
(map
(lambda (git-repository-details)
(cons
git-repository-details
(all-branches-with-most-recent-commit
conn (first git-repository-details))))
(all-git-repositories conn))))))))
(('GET "assets" rest ...) (('GET "assets" rest ...)
(or (handle-static-assets (string-join rest "/") (or (handle-static-assets (string-join rest "/")
(request-headers request)) (request-headers request))
@ -428,78 +587,19 @@
"README not found" "README not found"
"The README.html file does not exist") "The README.html file does not exist")
#:code 404)))) #:code 404))))
(_
(with-thread-postgresql-connection
(lambda (conn)
(controller-with-database-connection request
method-and-path-components
mime-types
body
conn
secret-key-base))))))
(call-with-error-handling
controller-thunk
#:on-error 'backtrace
#:post-error (lambda args
(render-html #:sxml (error-page
(if (%show-error-details)
args
#f))
#:code 500))))
(define (controller-with-database-connection request
method-and-path-components
mime-types
body
conn
secret-key-base)
(define path
(uri-path (request-uri request)))
(define (delegate-to f)
(or (f request
method-and-path-components
mime-types
body
conn)
(render-html
#:sxml (general-not-found
"Page not found"
"")
#:code 404)))
(define (delegate-to-with-secret-key-base f)
(or (f request
method-and-path-components
mime-types
body
conn
secret-key-base)
(render-html
#:sxml (general-not-found
"Page not found"
"")
#:code 404)))
(match method-and-path-components
(('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)))))
(('GET "builds") (('GET "builds")
(delegate-to build-controller)) (delegate-to build-controller))
(('GET "statistics") (('GET "statistics")
(letpar& ((guix-revisions-count
(with-thread-postgresql-connection count-guix-revisions))
(count-derivations
(with-thread-postgresql-connection count-derivations)))
(render-html (render-html
#:sxml (view-statistics (count-guix-revisions conn) #:sxml (view-statistics guix-revisions-count
(count-derivations conn)))) count-derivations))))
(('GET "metrics") (('GET "metrics")
(render-metrics conn)) (render-metrics))
(('GET "revision" args ...) (('GET "revision" args ...)
(delegate-to revision-controller)) (delegate-to revision-controller))
(('GET "repositories") (('GET "repositories")
@ -511,12 +611,11 @@
;; content negotiation, so just use the path from the request ;; content negotiation, so just use the path from the request
(let ((path (uri-path (request-uri request)))) (let ((path (uri-path (request-uri request))))
(if (string-suffix? ".drv" path) (if (string-suffix? ".drv" path)
(render-derivation conn path) (render-derivation path)
(render-store-item conn path)))) (render-store-item path))))
(('GET "gnu" "store" filename "formatted") (('GET "gnu" "store" filename "formatted")
(if (string-suffix? ".drv" filename) (if (string-suffix? ".drv" filename)
(render-formatted-derivation conn (render-formatted-derivation (string-append "/gnu/store/" filename))
(string-append "/gnu/store/" filename))
(render-html (render-html
#:sxml (general-not-found #:sxml (general-not-found
"Not a derivation" "Not a derivation"
@ -525,20 +624,22 @@
(('GET "gnu" "store" filename "plain") (('GET "gnu" "store" filename "plain")
(if (string-suffix? ".drv" filename) (if (string-suffix? ".drv" filename)
(let ((raw-drv (let ((raw-drv
(parallel-via-thread-pool-channel
(with-thread-postgresql-connection
(lambda (conn)
(select-serialized-derivation-by-file-name (select-serialized-derivation-by-file-name
conn conn
(string-append "/gnu/store/" filename)))) (string-append "/gnu/store/" filename)))))))
(if raw-drv (if raw-drv
(render-text raw-drv) (render-text raw-drv)
(not-found (request-uri request)))) (not-found (request-uri request))))
(not-found (request-uri request)))) (not-found (request-uri request))))
(('GET "gnu" "store" filename "narinfos") (('GET "gnu" "store" filename "narinfos")
(render-narinfos conn filename)) (render-narinfos filename))
(('GET "gnu" "store" filename "json") (('GET "gnu" "store" filename "json")
(if (string-suffix? ".drv" filename) (if (string-suffix? ".drv" filename)
(render-json-derivation conn (render-json-derivation (string-append "/gnu/store/" filename))
(string-append "/gnu/store/" filename)) (render-json-store-item (string-append "/gnu/store/" filename))))
(render-json-store-item conn (string-append "/gnu/store/" filename))))
(('GET "build-servers") (('GET "build-servers")
(delegate-to-with-secret-key-base build-server-controller)) (delegate-to-with-secret-key-base build-server-controller))
(('GET "dumps" _ ...) (('GET "dumps" _ ...)

3
guix-data-service/web/dumps/controller.scm
View file

@ -31,8 +31,7 @@
(define (dumps-controller request (define (dumps-controller request
method-and-path-components method-and-path-components
mime-types mime-types
body body)
conn)
(match method-and-path-components (match method-and-path-components
(('GET "dumps") (('GET "dumps")
(render-dumps request (render-dumps request

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

@ -17,6 +17,8 @@
(define-module (guix-data-service web jobs controller) (define-module (guix-data-service web jobs controller)
#:use-module (ice-9 match) #: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 render)
#:use-module (guix-data-service web query-parameters) #:use-module (guix-data-service web query-parameters)
#:use-module (guix-data-service web util) #:use-module (guix-data-service web util)
@ -27,8 +29,7 @@
(define (jobs-controller request (define (jobs-controller request
method-and-path-components method-and-path-components
mime-types mime-types
body body)
conn)
(match method-and-path-components (match method-and-path-components
(('GET "jobs") (('GET "jobs")
(let ((parsed-query-parameters (let ((parsed-query-parameters
@ -42,7 +43,6 @@
(all_results ,parse-checkbox-value))) (all_results ,parse-checkbox-value)))
'((limit_results all_results))))) '((limit_results all_results)))))
(render-jobs mime-types (render-jobs mime-types
conn
parsed-query-parameters))) parsed-query-parameters)))
(('GET "jobs" "events") (('GET "jobs" "events")
(let ((parsed-query-parameters (let ((parsed-query-parameters
@ -55,11 +55,9 @@
(all_results ,parse-checkbox-value))) (all_results ,parse-checkbox-value)))
'((limit_results all_results))))) '((limit_results all_results)))))
(render-job-events mime-types (render-job-events mime-types
conn
parsed-query-parameters))) parsed-query-parameters)))
(('GET "jobs" "queue") (('GET "jobs" "queue")
(render-job-queue mime-types (render-job-queue mime-types))
conn))
(('GET "job" job-id) (('GET "job" job-id)
(let ((parsed-query-parameters (let ((parsed-query-parameters
(parse-query-parameters (parse-query-parameters
@ -67,19 +65,23 @@
`((start_character ,parse-number) `((start_character ,parse-number)
(characters ,parse-number #:default 10000000))))) (characters ,parse-number #:default 10000000)))))
(render-job mime-types (render-job mime-types
conn
job-id job-id
parsed-query-parameters))) parsed-query-parameters)))
(_ #f))) (_ #f)))
(define (render-jobs mime-types conn query-parameters) (define (render-jobs mime-types query-parameters)
(let* ((limit-results (define limit-results (assq-ref query-parameters 'limit_results))
(assq-ref query-parameters 'limit_results))
(jobs (select-jobs-and-events (letpar& ((jobs
(with-thread-postgresql-connection
(lambda (conn)
(select-jobs-and-events
conn conn
(assq-ref query-parameters 'before_id) (assq-ref query-parameters 'before_id)
limit-results)) limit-results))))
(recent-events (select-recent-job-events conn))) (recent-events
(with-thread-postgresql-connection
select-recent-job-events)))
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
'(application/json text/html) '(application/json text/html)
mime-types) mime-types)
@ -113,29 +115,36 @@
(>= (length jobs) (>= (length jobs)
limit-results)))))))) limit-results))))))))
(define (render-job-events mime-types conn query-parameters) (define (render-job-events mime-types query-parameters)
(let* ((limit-results (letpar& ((recent-events
(assq-ref query-parameters 'limit_results)) (with-thread-postgresql-connection
(recent-events (select-recent-job-events (lambda (conn)
(select-recent-job-events
conn conn
;; TODO Ideally there wouldn't be a limit ;; TODO Ideally there wouldn't be a limit
#:limit (or limit-results 1000000)))) #:limit (or (assq-ref query-parameters 'limit_results)
1000000))))))
(render-html (render-html
#:sxml (view-job-events #:sxml (view-job-events
query-parameters query-parameters
recent-events)))) recent-events))))
(define (render-job-queue mime-types conn) (define (render-job-queue mime-types)
(render-html (render-html
#:sxml (view-job-queue #: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) (define (render-job mime-types job-id query-parameters)
(let ((log-text (log-for-job conn job-id (letpar& ((log-text
(with-thread-postgresql-connection
(lambda (conn)
(log-for-job conn job-id
#:character-limit #:character-limit
(assq-ref query-parameters 'characters) (assq-ref query-parameters 'characters)
#:start-character #:start-character
(assq-ref query-parameters 'start_character)))) (assq-ref query-parameters 'start_character))))))
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
'(text/plain text/html) '(text/plain text/html)
mime-types) mime-types)

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

@ -31,6 +31,8 @@
#:use-module (guix base32) #:use-module (guix base32)
#:use-module (guix base64) #:use-module (guix base64)
#:use-module (guix serialization) #: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 render)
#:use-module (guix-data-service web nar html) #:use-module (guix-data-service web nar html)
#:use-module (guix-data-service model derivation) #:use-module (guix-data-service model derivation)
@ -54,8 +56,7 @@
(define (nar-controller request (define (nar-controller request
method-and-path-components method-and-path-components
mime-types mime-types
body body)
conn)
(define (.narinfo-suffix s) (define (.narinfo-suffix s)
(string-suffix? ".narinfo" s)) (string-suffix? ".narinfo" s))
@ -78,7 +79,6 @@
(uri-decode (last (string-split path #\/))))) (uri-decode (last (string-split path #\/)))))
(render-nar request (render-nar request
mime-types mime-types
conn
(string-append "/gnu/store/" file-name)))) (string-append "/gnu/store/" file-name))))
(('GET "nar" "lzip" _) (('GET "nar" "lzip" _)
;; These routes are a little special, as the extensions aren't used for ;; These routes are a little special, as the extensions aren't used for
@ -88,22 +88,22 @@
(uri-decode (last (string-split path #\/))))) (uri-decode (last (string-split path #\/)))))
(render-lzip-nar request (render-lzip-nar request
mime-types mime-types
conn
(string-append "/gnu/store/" file-name)))) (string-append "/gnu/store/" file-name))))
(('GET (? .narinfo-suffix path)) (('GET (? .narinfo-suffix path))
(render-narinfo request (render-narinfo request
conn
(string-drop-right path (string-drop-right path
(string-length ".narinfo")))) (string-length ".narinfo"))))
(_ #f))) (_ #f)))
(define (render-nar request (define (render-nar request
mime-types mime-types
conn
file-name) file-name)
(or (or
(and=> (select-serialized-derivation-by-file-name conn (and=> (parallel-via-thread-pool-channel
file-name) (with-thread-postgresql-connection
(lambda (conn)
(select-serialized-derivation-by-file-name conn
file-name))))
(lambda (derivation-text) (lambda (derivation-text)
(let ((derivation-bytevector (let ((derivation-bytevector
(string->bytevector derivation-text (string->bytevector derivation-text
@ -127,10 +127,13 @@
(define (render-lzip-nar request (define (render-lzip-nar request
mime-types mime-types
conn
file-name) file-name)
(or (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) (lambda (data)
(list (build-response (list (build-response
#:code 200 #:code 200
@ -141,28 +144,34 @@
(not-found (request-uri request)))) (not-found (request-uri request))))
(define (render-narinfo request (define (render-narinfo request
conn
hash) hash)
(or (or
(and=> (select-derivation-by-file-name-hash conn (and=> (parallel-via-thread-pool-channel
hash) (with-thread-postgresql-connection
(lambda (conn)
(select-derivation-by-file-name-hash conn
hash))))
(lambda (derivation) (lambda (derivation)
(list (build-response (list (build-response
#:code 200 #:code 200
#:headers '((content-type . (application/x-narinfo)))) #:headers '((content-type . (application/x-narinfo))))
(let* ((derivation-file-name (let ((derivation-file-name (second derivation)))
(second derivation)) (letpar&
(derivation-text ((derivation-text
(with-thread-postgresql-connection
(lambda (conn)
(select-serialized-derivation-by-file-name (select-serialized-derivation-by-file-name
conn conn
derivation-file-name)) derivation-file-name))))
(derivation-bytevector
(string->bytevector derivation-text
"ISO-8859-1"))
(derivation-references (derivation-references
(with-thread-postgresql-connection
(lambda (conn)
(select-derivation-references-by-derivation-id (select-derivation-references-by-derivation-id
conn conn
(first derivation))) (first derivation))))))
(let* ((derivation-bytevector
(string->bytevector derivation-text
"ISO-8859-1"))
(nar-bytevector (nar-bytevector
(call-with-values (call-with-values
(lambda () (lambda ()
@ -183,9 +192,12 @@
(display (narinfo-string derivation-file-name (display (narinfo-string derivation-file-name
nar-bytevector nar-bytevector
derivation-references) derivation-references)
port)))))) port))))))))
(and=> (select-derivation-source-file-data-by-file-name-hash conn (and=> (parallel-via-thread-pool-channel
hash) (with-thread-postgresql-connection
(lambda (conn)
(select-derivation-source-file-data-by-file-name-hash conn
hash))))
(match-lambda (match-lambda
((store-path compression compressed-size ((store-path compression compressed-size
hash-algorithm hash uncompressed-size) hash-algorithm hash uncompressed-size)

177
guix-data-service/web/repository/controller.scm
View file

@ -19,6 +19,8 @@
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (web uri) #:use-module (web uri)
#:use-module (web request) #: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 render)
#:use-module (guix-data-service web query-parameters) #:use-module (guix-data-service web query-parameters)
#:use-module (guix-data-service web util) #:use-module (guix-data-service web util)
@ -36,14 +38,15 @@
(define (repository-controller request (define (repository-controller request
method-and-path-components method-and-path-components
mime-types mime-types
body body)
conn)
(define path (define path
(uri-path (request-uri request))) (uri-path (request-uri request)))
(match method-and-path-components (match method-and-path-components
(('GET "repositories") (('GET "repositories")
(let ((git-repositories (all-git-repositories conn))) (letpar& ((git-repositories
(with-thread-postgresql-connection
all-git-repositories)))
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
'(application/json text/html) '(application/json text/html)
mime-types) mime-types)
@ -62,11 +65,17 @@
#:sxml #:sxml
(view-git-repositories git-repositories)))))) (view-git-repositories git-repositories))))))
(('GET "repository" id) (('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) ((label url cgit-url-base)
(let ((branches (letpar& ((branches
(all-branches-with-most-recent-commit conn (with-thread-postgresql-connection
(string->number id)))) (lambda (conn)
(all-branches-with-most-recent-commit
conn
(string->number id))))))
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
'(application/json text/html) '(application/json text/html)
mime-types) mime-types)
@ -110,7 +119,9 @@
`((after_date ,parse-datetime) `((after_date ,parse-datetime)
(before_date ,parse-datetime) (before_date ,parse-datetime)
(limit_results ,parse-result-limit #:default 100))))) (limit_results ,parse-result-limit #:default 100)))))
(let ((revisions (letpar& ((revisions
(with-thread-postgresql-connection
(lambda (conn)
(most-recent-commits-for-branch (most-recent-commits-for-branch
conn conn
(string->number repository-id) (string->number repository-id)
@ -119,7 +130,7 @@
#:after-date (assq-ref parsed-query-parameters #:after-date (assq-ref parsed-query-parameters
'after_date) 'after_date)
#:before-date (assq-ref parsed-query-parameters #:before-date (assq-ref parsed-query-parameters
'before_date)))) 'before_date))))))
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
'(application/json text/html) '(application/json text/html)
mime-types) mime-types)
@ -144,11 +155,13 @@
parsed-query-parameters parsed-query-parameters
revisions)))))))) revisions))))))))
(('GET "repository" repository-id "branch" branch-name "package" package-name) (('GET "repository" repository-id "branch" branch-name "package" package-name)
(let ((package-versions (letpar& ((package-versions
(with-thread-postgresql-connection
(lambda (conn)
(package-versions-for-branch conn (package-versions-for-branch conn
(string->number repository-id) (string->number repository-id)
branch-name branch-name
package-name))) package-name)))))
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
'(application/json text/html) '(application/json text/html)
mime-types) mime-types)
@ -178,7 +191,6 @@
(('GET "repository" repository-id "branch" branch-name "package" package-name "derivation-history") (('GET "repository" repository-id "branch" branch-name "package" package-name "derivation-history")
(render-branch-package-derivation-history request (render-branch-package-derivation-history request
mime-types mime-types
conn
repository-id repository-id
branch-name branch-name
package-name)) package-name))
@ -186,27 +198,32 @@
"package" package-name "output-history") "package" package-name "output-history")
(render-branch-package-output-history request (render-branch-package-output-history request
mime-types mime-types
conn
repository-id repository-id
branch-name branch-name
package-name)) package-name))
(('GET "repository" repository-id "branch" branch-name "latest-processed-revision") (('GET "repository" repository-id "branch" branch-name "latest-processed-revision")
(let ((commit-hash (letpar& ((commit-hash
(latest-processed-commit-for-branch conn repository-id branch-name))) (with-thread-postgresql-connection
(lambda (conn)
(latest-processed-commit-for-branch conn
repository-id
branch-name)))))
(if commit-hash (if commit-hash
(render-view-revision mime-types (render-view-revision mime-types
conn
commit-hash commit-hash
#:path-base path #:path-base path
#:header-text #:header-text
`("Latest processed revision for branch " `("Latest processed revision for branch "
(samp ,branch-name))) (samp ,branch-name)))
(render-unknown-revision mime-types (render-unknown-revision mime-types
conn
commit-hash)))) commit-hash))))
(('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "packages") (('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "packages")
(let ((commit-hash (letpar& ((commit-hash
(latest-processed-commit-for-branch conn repository-id branch-name))) (with-thread-postgresql-connection
(lambda (conn)
(latest-processed-commit-for-branch conn
repository-id
branch-name)))))
(if commit-hash (if commit-hash
(let ((parsed-query-parameters (let ((parsed-query-parameters
(guard-against-mutually-exclusive-query-parameters (guard-against-mutually-exclusive-query-parameters
@ -227,7 +244,6 @@
(limit_results all_results))))) (limit_results all_results)))))
(render-revision-packages mime-types (render-revision-packages mime-types
conn
commit-hash commit-hash
parsed-query-parameters parsed-query-parameters
#:path-base path #:path-base path
@ -240,11 +256,14 @@
"/branch/" branch-name "/branch/" branch-name
"/latest-processed-revision"))) "/latest-processed-revision")))
(render-unknown-revision mime-types (render-unknown-revision mime-types
conn
commit-hash)))) commit-hash))))
(('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "package-derivations") (('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "package-derivations")
(let ((commit-hash (letpar& ((commit-hash
(latest-processed-commit-for-branch conn repository-id branch-name))) (with-thread-postgresql-connection
(lambda (conn)
(latest-processed-commit-for-branch conn
repository-id
branch-name)))))
(if commit-hash (if commit-hash
(let ((parsed-query-parameters (let ((parsed-query-parameters
(guard-against-mutually-exclusive-query-parameters (guard-against-mutually-exclusive-query-parameters
@ -265,39 +284,45 @@
'((limit_results all_results))))) '((limit_results all_results)))))
(render-revision-package-derivations mime-types (render-revision-package-derivations mime-types
conn
commit-hash commit-hash
parsed-query-parameters parsed-query-parameters
#:path-base path)) #:path-base path))
(render-unknown-revision mime-types (render-unknown-revision mime-types
conn
commit-hash)))) commit-hash))))
(('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "package-reproducibility") (('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "package-reproducibility")
(let ((commit-hash (letpar& ((commit-hash
(latest-processed-commit-for-branch conn repository-id branch-name))) (with-thread-postgresql-connection
(lambda (conn)
(latest-processed-commit-for-branch conn
repository-id
branch-name)))))
(if commit-hash (if commit-hash
(render-revision-package-reproduciblity mime-types (render-revision-package-reproduciblity mime-types
conn
commit-hash commit-hash
#:path-base path) #:path-base path)
(render-unknown-revision mime-types (render-unknown-revision mime-types
conn
commit-hash)))) commit-hash))))
(('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "package-substitute-availability") (('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "package-substitute-availability")
(let ((commit-hash (letpar& ((commit-hash
(latest-processed-commit-for-branch conn repository-id branch-name))) (with-thread-postgresql-connection
(lambda (conn)
(latest-processed-commit-for-branch conn
repository-id
branch-name)))))
(if commit-hash (if commit-hash
(render-revision-package-substitute-availability mime-types (render-revision-package-substitute-availability mime-types
conn
commit-hash commit-hash
#:path-base path) #:path-base path)
(render-unknown-revision mime-types (render-unknown-revision mime-types
conn
commit-hash)))) commit-hash))))
(('GET "repository" repository-id "branch" branch-name "latest-processed-revision" (('GET "repository" repository-id "branch" branch-name "latest-processed-revision"
"lint-warnings") "lint-warnings")
(let ((commit-hash (letpar& ((commit-hash
(latest-processed-commit-for-branch conn repository-id branch-name))) (with-thread-postgresql-connection
(lambda (conn)
(latest-processed-commit-for-branch conn
repository-id
branch-name)))))
(if commit-hash (if commit-hash
(let ((parsed-query-parameters (let ((parsed-query-parameters
(parse-query-parameters (parse-query-parameters
@ -312,7 +337,6 @@
"location")))))) "location"))))))
(render-revision-lint-warnings mime-types (render-revision-lint-warnings mime-types
conn
commit-hash commit-hash
parsed-query-parameters parsed-query-parameters
#:path-base path #:path-base path
@ -325,18 +349,20 @@
"/branch/" branch-name "/branch/" branch-name
"/latest-processed-revision"))) "/latest-processed-revision")))
(render-unknown-revision mime-types (render-unknown-revision mime-types
conn
commit-hash)))) commit-hash))))
(('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "package" name version) (('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "package" name version)
(let ((commit-hash (letpar& ((commit-hash
(latest-processed-commit-for-branch conn repository-id branch-name)) (with-thread-postgresql-connection
(parsed-query-parameters (lambda (conn)
(latest-processed-commit-for-branch conn
repository-id
branch-name)))))
(let ((parsed-query-parameters
(parse-query-parameters (parse-query-parameters
request request
`((locale ,identity #:default "en_US.UTF-8"))))) `((locale ,identity #:default "en_US.UTF-8")))))
(if commit-hash (if commit-hash
(render-revision-package-version mime-types (render-revision-package-version mime-types
conn
commit-hash commit-hash
name name
version version
@ -355,13 +381,14 @@
"/branch/" branch-name "/branch/" branch-name
"/package/" name)) "/package/" name))
(render-unknown-revision mime-types (render-unknown-revision mime-types
conn commit-hash)))))
commit-hash))))
(_ #f))) (_ #f)))
(define (parse-build-system conn) (define (parse-build-system)
(let ((systems (let ((systems
(valid-systems conn))) (parallel-via-thread-pool-channel
(with-thread-postgresql-connection
valid-systems))))
(lambda (s) (lambda (s)
(if (member s systems) (if (member s systems)
s s
@ -370,30 +397,33 @@
(define (render-branch-package-derivation-history request (define (render-branch-package-derivation-history request
mime-types mime-types
conn
repository-id repository-id
branch-name branch-name
package-name) package-name)
(let ((parsed-query-parameters (let ((parsed-query-parameters
(parse-query-parameters (parse-query-parameters
request request
`((system ,(parse-build-system conn) `((system ,(parse-build-system)
#:default "x86_64-linux") #:default "x86_64-linux")
(target ,parse-target (target ,parse-target
#:default ""))))) #:default "")))))
(let* ((system (let ((system
(assq-ref parsed-query-parameters 'system)) (assq-ref parsed-query-parameters 'system))
(target (target
(assq-ref parsed-query-parameters 'target)) (assq-ref parsed-query-parameters 'target)))
(package-derivations (letpar&
((package-derivations
(with-thread-postgresql-connection
(lambda (conn)
(package-derivations-for-branch conn (package-derivations-for-branch conn
(string->number repository-id) (string->number repository-id)
branch-name branch-name
system system
target target
package-name)) package-name))))
(build-server-urls (build-server-urls
(select-build-server-urls-by-id conn))) (with-thread-postgresql-connection
select-build-server-urls-by-id)))
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
'(application/json text/html) '(application/json text/html)
mime-types) mime-types)
@ -419,21 +449,25 @@
. ,(list->vector builds))))) . ,(list->vector builds)))))
package-derivations)))))) package-derivations))))))
(else (else
(letpar& ((systems
(with-thread-postgresql-connection
valid-systems))
(targets
(with-thread-postgresql-connection
valid-targets)))
(render-html (render-html
#:sxml (view-branch-package-derivations #:sxml (view-branch-package-derivations
parsed-query-parameters parsed-query-parameters
repository-id repository-id
branch-name branch-name
package-name package-name
(valid-systems conn) systems
(valid-targets->options (valid-targets->options targets)
(valid-targets conn))
build-server-urls build-server-urls
package-derivations))))))) package-derivations)))))))))
(define (render-branch-package-output-history request (define (render-branch-package-output-history request
mime-types mime-types
conn
repository-id repository-id
branch-name branch-name
package-name) package-name)
@ -442,26 +476,30 @@
request request
`((output ,identity `((output ,identity
#:default "out") #:default "out")
(system ,(parse-build-system conn) (system ,(parse-build-system)
#:default "x86_64-linux") #:default "x86_64-linux")
(target ,parse-target (target ,parse-target
#:default ""))))) #:default "")))))
(let* ((system (let ((system
(assq-ref parsed-query-parameters 'system)) (assq-ref parsed-query-parameters 'system))
(target (target
(assq-ref parsed-query-parameters 'target)) (assq-ref parsed-query-parameters 'target))
(output-name (output-name
(assq-ref parsed-query-parameters 'output)) (assq-ref parsed-query-parameters 'output)))
(package-outputs (letpar&
((package-outputs
(with-thread-postgresql-connection
(lambda (conn)
(package-outputs-for-branch conn (package-outputs-for-branch conn
(string->number repository-id) (string->number repository-id)
branch-name branch-name
system system
target target
package-name package-name
output-name)) output-name))))
(build-server-urls (build-server-urls
(select-build-server-urls-by-id conn))) (with-thread-postgresql-connection
select-build-server-urls-by-id)))
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
'(application/json text/html) '(application/json text/html)
mime-types) mime-types)
@ -487,6 +525,12 @@
. ,(list->vector builds))))) . ,(list->vector builds)))))
package-outputs)))))) package-outputs))))))
(else (else
(letpar& ((systems
(with-thread-postgresql-connection
valid-systems))
(targets
(with-thread-postgresql-connection
valid-targets)))
(render-html (render-html
#:sxml (view-branch-package-outputs #:sxml (view-branch-package-outputs
parsed-query-parameters parsed-query-parameters
@ -494,8 +538,7 @@
branch-name branch-name
package-name package-name
output-name output-name
(valid-systems conn) systems
(valid-targets->options (valid-targets->options targets)
(valid-targets conn))
build-server-urls build-server-urls
package-outputs))))))) package-outputs)))))))))

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

@ -24,6 +24,8 @@
#:use-module (texinfo html) #:use-module (texinfo html)
#:use-module (texinfo plain-text) #:use-module (texinfo plain-text)
#:use-module (json) #: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 render)
#:use-module (guix-data-service web sxml) #:use-module (guix-data-service web sxml)
#:use-module (guix-data-service web query-parameters) #:use-module (guix-data-service web query-parameters)
@ -75,9 +77,9 @@
(string-append "unknown build status: " (string-append "unknown build status: "
status)))) status))))
(define (parse-build-server conn) (define (parse-build-server v)
(lambda (v) (letpar& ((build-servers
(let ((build-servers (select-build-servers conn))) (with-thread-postgresql-connection select-build-servers)))
(or (any (match-lambda (or (any (match-lambda
((id url lookup-all-derivations? lookup-builds?) ((id url lookup-all-derivations? lookup-builds?)
(if (eq? (string->number v) (if (eq? (string->number v)
@ -87,40 +89,45 @@
build-servers) build-servers)
(make-invalid-query-parameter (make-invalid-query-parameter
v v
"unknown build server"))))) "unknown build server"))))
(define (revision-controller request (define (revision-controller request
method-and-path-components method-and-path-components
mime-types mime-types
body body)
conn)
(define path (define path
(uri-path (request-uri request))) (uri-path (request-uri request)))
(match method-and-path-components (match method-and-path-components
(('GET "revision" commit-hash) (if (guix-commit-exists? 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 (render-view-revision mime-types
conn
commit-hash commit-hash
#:path-base path) #:path-base path)
(render-unknown-revision mime-types (render-unknown-revision mime-types
conn
commit-hash))) commit-hash)))
(('GET "revision" commit-hash "news") (('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 (let ((parsed-query-parameters
(parse-query-parameters (parse-query-parameters
request request
`((lang ,identity #:multi-value))))) `((lang ,identity #:multi-value)))))
(render-revision-news mime-types (render-revision-news mime-types
conn
commit-hash commit-hash
parsed-query-parameters)) parsed-query-parameters))
(render-unknown-revision mime-types (render-unknown-revision mime-types
conn
commit-hash))) commit-hash)))
(('GET "revision" commit-hash "packages") (('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 (let ((parsed-query-parameters
(guard-against-mutually-exclusive-query-parameters (guard-against-mutually-exclusive-query-parameters
(parse-query-parameters (parse-query-parameters
@ -140,48 +147,52 @@
(limit_results all_results))))) (limit_results all_results)))))
(render-revision-packages mime-types (render-revision-packages mime-types
conn
commit-hash commit-hash
parsed-query-parameters parsed-query-parameters
#:path-base path)) #:path-base path))
(render-unknown-revision mime-types (render-unknown-revision mime-types
conn
commit-hash))) commit-hash)))
(('GET "revision" commit-hash "packages-translation-availability") (('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 (render-revision-packages-translation-availability mime-types
conn
commit-hash commit-hash
#:path-base path) #:path-base path)
(render-unknown-revision mime-types (render-unknown-revision mime-types
conn
commit-hash))) commit-hash)))
(('GET "revision" commit-hash "package" name) (('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 (render-revision-package mime-types
conn
commit-hash commit-hash
name) name)
(render-unknown-revision mime-types (render-unknown-revision mime-types
conn
commit-hash))) commit-hash)))
(('GET "revision" commit-hash "package" name version) (('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 (let ((parsed-query-parameters
(parse-query-parameters (parse-query-parameters
request request
`((locale ,identity #:default "en_US.UTF-8"))))) `((locale ,identity #:default "en_US.UTF-8")))))
(render-revision-package-version mime-types (render-revision-package-version mime-types
conn
commit-hash commit-hash
name name
version version
parsed-query-parameters)) parsed-query-parameters))
(render-unknown-revision mime-types (render-unknown-revision mime-types
conn
commit-hash))) commit-hash)))
(('GET "revision" commit-hash "package-derivations") (('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 (let ((parsed-query-parameters
(guard-against-mutually-exclusive-query-parameters (guard-against-mutually-exclusive-query-parameters
(parse-query-parameters (parse-query-parameters
@ -201,15 +212,16 @@
'((limit_results all_results))))) '((limit_results all_results)))))
(render-revision-package-derivations mime-types (render-revision-package-derivations mime-types
conn
commit-hash commit-hash
parsed-query-parameters parsed-query-parameters
#:path-base path)) #:path-base path))
(render-unknown-revision mime-types (render-unknown-revision mime-types
conn
commit-hash))) commit-hash)))
(('GET "revision" commit-hash "package-derivation-outputs") (('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 (let ((parsed-query-parameters
(guard-against-mutually-exclusive-query-parameters (guard-against-mutually-exclusive-query-parameters
(parse-query-parameters (parse-query-parameters
@ -231,62 +243,67 @@
'((limit_results all_results))))) '((limit_results all_results)))))
(render-revision-package-derivation-outputs mime-types (render-revision-package-derivation-outputs mime-types
conn
commit-hash commit-hash
parsed-query-parameters parsed-query-parameters
#:path-base path)) #:path-base path))
(render-unknown-revision mime-types (render-unknown-revision mime-types
conn
commit-hash))) commit-hash)))
(('GET "revision" commit-hash "system-tests") (('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 (let ((parsed-query-parameters
(parse-query-parameters (parse-query-parameters
request request
`((system ,parse-system #:default "x86_64-linux"))))) `((system ,parse-system #:default "x86_64-linux")))))
(render-revision-system-tests mime-types (render-revision-system-tests mime-types
conn
commit-hash commit-hash
parsed-query-parameters parsed-query-parameters
#:path-base path)) #:path-base path))
(render-unknown-revision mime-types (render-unknown-revision mime-types
conn
commit-hash))) commit-hash)))
(('GET "revision" commit-hash "channel-instances") (('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 (render-revision-channel-instances mime-types
conn
commit-hash commit-hash
#:path-base path) #:path-base path)
(render-unknown-revision mime-types (render-unknown-revision mime-types
conn
commit-hash))) commit-hash)))
(('GET "revision" commit-hash "package-substitute-availability") (('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 (render-revision-package-substitute-availability mime-types
conn
commit-hash commit-hash
#:path-base path) #:path-base path)
(render-unknown-revision mime-types (render-unknown-revision mime-types
conn
commit-hash))) commit-hash)))
(('GET "revision" commit-hash "package-reproducibility") (('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 (render-revision-package-reproduciblity mime-types
conn
commit-hash commit-hash
#:path-base path) #:path-base path)
(render-unknown-revision mime-types (render-unknown-revision mime-types
conn
commit-hash))) commit-hash)))
(('GET "revision" commit-hash "builds") (('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 (let ((parsed-query-parameters
(guard-against-mutually-exclusive-query-parameters (guard-against-mutually-exclusive-query-parameters
(parse-query-parameters (parse-query-parameters
request request
`((build_status ,parse-build-status #:multi-value) `((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") (system ,parse-system #:default "x86_64-linux")
(target ,parse-target #:default "") (target ,parse-target #:default "")
(limit_results ,parse-result-limit (limit_results ,parse-result-limit
@ -296,15 +313,16 @@
'((limit_results all_results))))) '((limit_results all_results)))))
(render-revision-builds mime-types (render-revision-builds mime-types
conn
commit-hash commit-hash
parsed-query-parameters parsed-query-parameters
#:path-base path)) #:path-base path))
(render-unknown-revision mime-types (render-unknown-revision mime-types
conn
commit-hash))) commit-hash)))
(('GET "revision" commit-hash "lint-warnings") (('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 (let ((parsed-query-parameters
(parse-query-parameters (parse-query-parameters
request request
@ -318,12 +336,10 @@
"location")))))) "location"))))))
(render-revision-lint-warnings mime-types (render-revision-lint-warnings mime-types
conn
commit-hash commit-hash
parsed-query-parameters parsed-query-parameters
#:path-base path)) #:path-base path))
(render-unknown-revision mime-types (render-unknown-revision mime-types
conn
commit-hash))) commit-hash)))
(_ #f))) (_ #f)))
@ -336,7 +352,7 @@
(plain . ,(stexi->plain-text stexi)) (plain . ,(stexi->plain-text stexi))
(locale . ,locale)))) (locale . ,locale))))
(define (render-unknown-revision mime-types conn commit-hash) (define (render-unknown-revision mime-types commit-hash)
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
'(application/json text/html) '(application/json text/html)
mime-types) mime-types)
@ -345,31 +361,55 @@
'((unknown_commit . ,commit-hash)) '((unknown_commit . ,commit-hash))
#:code 404)) #:code 404))
(else (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 (render-html
#:code 404 #:code 404
#:sxml (unknown-revision #:sxml (unknown-revision
commit-hash commit-hash
(select-job-for-commit job
conn commit-hash) git-repositories-and-branches
(git-branches-with-repository-details-for-commit conn commit-hash) jobs-and-events))))))
(select-jobs-and-events-for-commit conn commit-hash))))))
(define* (render-view-revision mime-types (define* (render-view-revision mime-types
conn
commit-hash commit-hash
#:key path-base #:key path-base
(header-text (header-text
`("Revision " (samp ,commit-hash)))) `("Revision " (samp ,commit-hash))))
(let ((packages-count (letpar& ((packages-count
(count-packages-in-revision conn commit-hash)) (with-thread-postgresql-connection
(lambda (conn)
(count-packages-in-revision conn commit-hash))))
(git-repositories-and-branches (git-repositories-and-branches
(git-branches-with-repository-details-for-commit conn commit-hash)) (with-thread-postgresql-connection
(lambda (conn)
(git-branches-with-repository-details-for-commit conn
commit-hash))))
(derivations-counts (derivations-counts
(count-packages-derivations-in-revision conn commit-hash)) (with-thread-postgresql-connection
(lambda (conn)
(count-packages-derivations-in-revision conn commit-hash))))
(jobs-and-events (jobs-and-events
(select-jobs-and-events-for-commit conn commit-hash)) (with-thread-postgresql-connection
(lambda (conn)
(select-jobs-and-events-for-commit conn commit-hash))))
(lint-warning-counts (lint-warning-counts
(lint-warning-count-by-lint-checker-for-revision conn commit-hash))) (with-thread-postgresql-connection
(lambda (conn)
(lint-warning-count-by-lint-checker-for-revision conn
commit-hash)))))
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
'(application/json text/html) '(application/json text/html)
mime-types) mime-types)
@ -404,7 +444,6 @@
#:extra-headers http-headers-for-unchanging-content))))) #:extra-headers http-headers-for-unchanging-content)))))
(define* (render-revision-system-tests mime-types (define* (render-revision-system-tests mime-types
conn
commit-hash commit-hash
query-parameters query-parameters
#:key #:key
@ -413,11 +452,13 @@
`("Revision " (samp ,commit-hash))) `("Revision " (samp ,commit-hash)))
(header-link (header-link
(string-append "/revision/" commit-hash))) (string-append "/revision/" commit-hash)))
(let ((system-tests (letpar& ((system-tests
(with-thread-postgresql-connection
(lambda (conn)
(select-system-tests-for-guix-revision (select-system-tests-for-guix-revision
conn conn
(assq-ref query-parameters 'system) (assq-ref query-parameters 'system)
commit-hash))) commit-hash)))))
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
'(application/json text/html) '(application/json text/html)
mime-types) mime-types)
@ -440,20 +481,25 @@
(builds . ,(list->vector builds))))) (builds . ,(list->vector builds)))))
system-tests)))))) system-tests))))))
(else (else
(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 (render-html
#:sxml (view-revision-system-tests #:sxml (view-revision-system-tests
commit-hash commit-hash
system-tests system-tests
(git-repositories-containing-commit conn git-repositories
commit-hash) systems
(valid-systems conn)
query-parameters query-parameters
#:path-base path-base #:path-base path-base
#:header-text header-text #:header-text header-text
#:header-link header-link)))))) #:header-link header-link)))))))
(define* (render-revision-channel-instances mime-types (define* (render-revision-channel-instances mime-types
conn
commit-hash commit-hash
#:key #:key
(path-base "/revision/") (path-base "/revision/")
@ -462,8 +508,10 @@
(header-link (header-link
(string-append "/revision/" (string-append "/revision/"
commit-hash))) commit-hash)))
(let ((channel-instances (letpar& ((channel-instances
(select-channel-instances-for-guix-revision conn commit-hash))) (with-thread-postgresql-connection
(lambda (conn)
(select-channel-instances-for-guix-revision conn commit-hash)))))
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
'(application/json text/html) '(application/json text/html)
mime-types) mime-types)
@ -487,13 +535,16 @@
#:header-link header-link)))))) #:header-link header-link))))))
(define* (render-revision-package-substitute-availability mime-types (define* (render-revision-package-substitute-availability mime-types
conn
commit-hash commit-hash
#:key path-base) #:key path-base)
(let ((substitute-availability (letpar& ((substitute-availability
(select-package-output-availability-for-revision conn commit-hash)) (with-thread-postgresql-connection
(lambda (conn)
(select-package-output-availability-for-revision conn
commit-hash))))
(build-server-urls (build-server-urls
(select-build-server-urls-by-id conn))) (with-thread-postgresql-connection
select-build-server-urls-by-id)))
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
'(application/json text/html) '(application/json text/html)
mime-types) mime-types)
@ -508,11 +559,12 @@
build-server-urls)))))) build-server-urls))))))
(define* (render-revision-package-reproduciblity mime-types (define* (render-revision-package-reproduciblity mime-types
conn
commit-hash commit-hash
#:key path-base) #:key path-base)
(let ((output-consistency (letpar& ((output-consistency
(select-output-consistency-for-revision conn commit-hash))) (with-thread-postgresql-connection
(lambda (conn)
(select-output-consistency-for-revision conn commit-hash)))))
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
'(application/json text/html) '(application/json text/html)
mime-types) mime-types)
@ -526,7 +578,6 @@
output-consistency)))))) output-consistency))))))
(define (render-revision-news mime-types (define (render-revision-news mime-types
conn
commit-hash commit-hash
query-parameters) query-parameters)
(if (any-invalid-query-parameters? query-parameters) (if (any-invalid-query-parameters? query-parameters)
@ -541,9 +592,12 @@
#:sxml (view-revision-news commit-hash #:sxml (view-revision-news commit-hash
query-parameters query-parameters
'())))) '()))))
(let ((news-entries (letpar& ((news-entries
(select-channel-news-entries-contained-in-guix-revision conn (with-thread-postgresql-connection
commit-hash))) (lambda (conn)
(select-channel-news-entries-contained-in-guix-revision
conn
commit-hash)))))
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
'(application/json text/html) '(application/json text/html)
mime-types) mime-types)
@ -558,7 +612,6 @@
#:extra-headers http-headers-for-unchanging-content)))))) #:extra-headers http-headers-for-unchanging-content))))))
(define* (render-revision-packages mime-types (define* (render-revision-packages mime-types
conn
commit-hash commit-hash
query-parameters query-parameters
#:key #:key
@ -589,16 +642,20 @@
'() '()
#f #f
#f #f
#f
#:path-base path-base #:path-base path-base
#:header-text header-text #:header-text header-text
#:header-link header-link)))) #:header-link header-link))))
(let* ((search-query (assq-ref query-parameters 'search_query)) (let ((search-query (assq-ref query-parameters 'search_query))
(limit-results (or (assq-ref query-parameters 'limit_results) (limit-results (or (assq-ref query-parameters 'limit_results)
99999)) ; TODO There shouldn't be a limit 99999)) ; TODO There shouldn't be a limit
(fields (assq-ref query-parameters 'field)) (fields (assq-ref query-parameters 'field))
(locale (assq-ref query-parameters 'locale)) (locale (assq-ref query-parameters 'locale)))
(packages (letpar&
((packages
(with-thread-postgresql-connection
(lambda (conn)
(if search-query (if search-query
(search-packages-in-revision (search-packages-in-revision
conn conn
@ -611,11 +668,13 @@
commit-hash commit-hash
#:limit-results limit-results #:limit-results limit-results
#:after-name (assq-ref query-parameters 'after_name) #:after-name (assq-ref query-parameters 'after_name)
#:locale (assq-ref query-parameters 'locale)))) #:locale (assq-ref query-parameters 'locale))))))
(git-repositories (git-repositories
(with-thread-postgresql-connection
(lambda (conn)
(git-repositories-containing-commit conn (git-repositories-containing-commit conn
commit-hash)) commit-hash)))))
(show-next-page? (let ((show-next-page?
(and (not search-query) (and (not search-query)
(>= (length packages) (>= (length packages)
limit-results))) limit-results)))
@ -664,11 +723,14 @@
packages)))) packages))))
#:extra-headers http-headers-for-unchanging-content)) #:extra-headers http-headers-for-unchanging-content))
(else (else
(let ((locale-options (letpar&
((locale-options
(with-thread-postgresql-connection
(lambda (conn)
(description-and-synopsis-locale-options (description-and-synopsis-locale-options
(package-description-and-synopsis-locale-options-guix-revision (package-description-and-synopsis-locale-options-guix-revision
conn conn
(commit->revision-id conn commit-hash))))) (commit->revision-id conn commit-hash)))))))
(render-html (render-html
#:sxml (view-revision-packages commit-hash #:sxml (view-revision-packages commit-hash
query-parameters query-parameters
@ -680,10 +742,9 @@
#:path-base path-base #:path-base path-base
#:header-text header-text #:header-text header-text
#:header-link header-link) #:header-link header-link)
#:extra-headers http-headers-for-unchanging-content))))))) #:extra-headers http-headers-for-unchanging-content)))))))))
(define* (render-revision-packages-translation-availability mime-types (define* (render-revision-packages-translation-availability mime-types
conn
commit-hash commit-hash
#:key #:key
path-base path-base
@ -692,14 +753,20 @@
"/revision/" commit-hash)) "/revision/" commit-hash))
(header-text (header-text
`("Revision " (samp ,commit-hash)))) `("Revision " (samp ,commit-hash))))
(let ((package-synopsis-counts (letpar& ((package-synopsis-counts
(with-thread-postgresql-connection
(lambda (conn)
(synopsis-counts-by-locale conn (synopsis-counts-by-locale conn
(commit->revision-id conn (commit->revision-id
commit-hash))) conn
commit-hash)))))
(package-description-counts (package-description-counts
(with-thread-postgresql-connection
(lambda (conn)
(description-counts-by-locale conn (description-counts-by-locale conn
(commit->revision-id conn (commit->revision-id
commit-hash)))) conn
commit-hash))))))
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
'(application/json text/html) '(application/json text/html)
mime-types) mime-types)
@ -718,7 +785,6 @@
#:header-text header-text)))))) #:header-text header-text))))))
(define* (render-revision-package mime-types (define* (render-revision-package mime-types
conn
commit-hash commit-hash
name name
#:key #:key
@ -729,13 +795,17 @@
(header-link (header-link
(string-append (string-append
"/revision/" commit-hash))) "/revision/" commit-hash)))
(let ((package-versions (letpar& ((package-versions
(with-thread-postgresql-connection
(lambda (conn)
(select-package-versions-for-revision conn (select-package-versions-for-revision conn
commit-hash commit-hash
name)) name))))
(git-repositories-and-branches (git-repositories-and-branches
(with-thread-postgresql-connection
(lambda (conn)
(git-branches-with-repository-details-for-commit conn (git-branches-with-repository-details-for-commit conn
commit-hash))) commit-hash)))))
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
'(application/json text/html) '(application/json text/html)
mime-types) mime-types)
@ -755,7 +825,6 @@
#:extra-headers http-headers-for-unchanging-content))))) #:extra-headers http-headers-for-unchanging-content)))))
(define* (render-revision-package-version mime-types (define* (render-revision-package-version mime-types
conn
commit-hash commit-hash
name name
version version
@ -774,36 +843,48 @@
(match-lambda (match-lambda
((locale) ((locale)
locale)) locale))
(parallel-via-thread-pool-channel
(with-thread-postgresql-connection
(lambda (conn)
(delete-duplicates (delete-duplicates
(append (append
(package-description-and-synopsis-locale-options-guix-revision (package-description-and-synopsis-locale-options-guix-revision
conn (commit->revision-id conn commit-hash)) conn (commit->revision-id conn commit-hash))
(lint-warning-message-locales-for-revision conn commit-hash))))) (lint-warning-message-locales-for-revision conn commit-hash))))))))
(let* ((locale (assq-ref query-parameters 'locale)) (define locale (assq-ref query-parameters 'locale))
(metadata
(letpar& ((metadata
(with-thread-postgresql-connection
(lambda (conn)
(select-package-metadata-by-revision-name-and-version (select-package-metadata-by-revision-name-and-version
conn conn
commit-hash commit-hash
name name
version version
locale)) locale))))
(derivations (derivations
(with-thread-postgresql-connection
(lambda (conn)
(select-derivations-by-revision-name-and-version (select-derivations-by-revision-name-and-version
conn conn
commit-hash commit-hash
name name
version)) version))))
(git-repositories (git-repositories
(with-thread-postgresql-connection
(lambda (conn)
(git-repositories-containing-commit conn (git-repositories-containing-commit conn
commit-hash)) commit-hash))))
(lint-warnings (lint-warnings
(with-thread-postgresql-connection
(lambda (conn)
(select-lint-warnings-by-revision-package-name-and-version (select-lint-warnings-by-revision-package-name-and-version
conn conn
commit-hash commit-hash
name name
version version
#:locale locale))) #:locale locale)))))
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
'(application/json text/html) '(application/json text/html)
mime-types) mime-types)
@ -843,7 +924,6 @@
#:extra-headers http-headers-for-unchanging-content))))) #:extra-headers http-headers-for-unchanging-content)))))
(define* (render-revision-package-derivations mime-types (define* (render-revision-package-derivations mime-types
conn
commit-hash commit-hash
query-parameters query-parameters
#:key #:key
@ -861,27 +941,34 @@
(render-json (render-json
`((error . "invalid query")))) `((error . "invalid query"))))
(else (else
(letpar& ((systems
(with-thread-postgresql-connection valid-systems))
(targets
(with-thread-postgresql-connection valid-targets)))
(render-html (render-html
#:sxml (view-revision-package-derivations commit-hash #:sxml (view-revision-package-derivations commit-hash
query-parameters query-parameters
(valid-systems conn) systems
(valid-targets->options (valid-targets->options
(valid-targets conn)) targets)
'() '()
'() '()
#f #f
#:path-base path-base #:path-base path-base
#:header-text header-text #:header-text header-text
#:header-link header-link)))) #:header-link header-link)))))
(let* ((limit-results (let ((limit-results
(assq-ref query-parameters 'limit_results)) (assq-ref query-parameters 'limit_results))
(all-results (all-results
(assq-ref query-parameters 'all_results)) (assq-ref query-parameters 'all_results))
(search-query (search-query
(assq-ref query-parameters 'search_query)) (assq-ref query-parameters 'search_query))
(fields (fields
(assq-ref query-parameters 'field)) (assq-ref query-parameters 'field)))
(derivations (letpar&
((derivations
(with-thread-postgresql-connection
(lambda (conn)
(if search-query (if search-query
(search-package-derivations-in-revision (search-package-derivations-in-revision
conn conn
@ -903,10 +990,11 @@
#:minimum-builds (assq-ref query-parameters 'minimum_builds) #:minimum-builds (assq-ref query-parameters 'minimum_builds)
#:limit-results limit-results #:limit-results limit-results
#:after-name (assq-ref query-parameters 'after_name) #:after-name (assq-ref query-parameters 'after_name)
#:include-builds? (member "builds" fields)))) #:include-builds? (member "builds" fields))))))
(build-server-urls (build-server-urls
(select-build-server-urls-by-id conn)) (with-thread-postgresql-connection
(show-next-page? select-build-server-urls-by-id)))
(let ((show-next-page?
(if all-results (if all-results
#f #f
(and (not (null? derivations)) (and (not (null? derivations))
@ -938,23 +1026,25 @@
(builds . ,builds)))) (builds . ,builds))))
derivations)))))) derivations))))))
(else (else
(letpar& ((systems
(with-thread-postgresql-connection valid-systems))
(targets
(with-thread-postgresql-connection valid-targets)))
(render-html (render-html
#:sxml (view-revision-package-derivations #:sxml (view-revision-package-derivations
commit-hash commit-hash
query-parameters query-parameters
(valid-systems conn) systems
(valid-targets->options (valid-targets->options targets)
(valid-targets conn))
derivations derivations
build-server-urls build-server-urls
show-next-page? show-next-page?
#:path-base path-base #:path-base path-base
#:header-text header-text #:header-text header-text
#:header-link header-link))))))) #:header-link header-link))))))))))
(define* (render-revision-package-derivation-outputs (define* (render-revision-package-derivation-outputs
mime-types mime-types
conn
commit-hash commit-hash
query-parameters query-parameters
#:key #:key
@ -964,7 +1054,8 @@
(header-link (header-link
(string-append "/revision/" commit-hash))) (string-append "/revision/" commit-hash)))
(define build-server-urls (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) (if (any-invalid-query-parameters? query-parameters)
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
@ -974,24 +1065,30 @@
(render-json (render-json
`((error . "invalid query")))) `((error . "invalid query"))))
(else (else
(letpar& ((systems
(with-thread-postgresql-connection valid-systems))
(targets
(with-thread-postgresql-connection valid-targets)))
(render-html (render-html
#:sxml (view-revision-package-derivation-outputs #:sxml (view-revision-package-derivation-outputs
commit-hash commit-hash
query-parameters query-parameters
'() '()
build-server-urls build-server-urls
(valid-systems conn) systems
(valid-targets->options (valid-targets->options targets)
(valid-targets conn))
#f #f
#:path-base path-base #:path-base path-base
#:header-text header-text #:header-text header-text
#:header-link header-link)))) #:header-link header-link)))))
(let* ((limit-results (let ((limit-results
(assq-ref query-parameters 'limit_results)) (assq-ref query-parameters 'limit_results))
(all-results (all-results
(assq-ref query-parameters 'all_results)) (assq-ref query-parameters 'all_results)))
(derivation-outputs (letpar&
((derivation-outputs
(with-thread-postgresql-connection
(lambda (conn)
(select-derivation-outputs-in-revision (select-derivation-outputs-in-revision
conn conn
commit-hash commit-hash
@ -1005,8 +1102,8 @@
#:system (assq-ref query-parameters 'system) #:system (assq-ref query-parameters 'system)
#:target (assq-ref query-parameters 'target) #:target (assq-ref query-parameters 'target)
#:limit-results limit-results #:limit-results limit-results
#:after-path (assq-ref query-parameters 'after_path))) #:after-path (assq-ref query-parameters 'after_path))))))
(show-next-page? (let ((show-next-page?
(if all-results (if all-results
#f #f
(>= (length derivation-outputs) (>= (length derivation-outputs)
@ -1018,22 +1115,24 @@
(render-json (render-json
`())) `()))
(else (else
(letpar& ((systems
(with-thread-postgresql-connection valid-systems))
(targets
(with-thread-postgresql-connection valid-targets)))
(render-html (render-html
#:sxml (view-revision-package-derivation-outputs #:sxml (view-revision-package-derivation-outputs
commit-hash commit-hash
query-parameters query-parameters
derivation-outputs derivation-outputs
build-server-urls build-server-urls
(valid-systems conn) systems
(valid-targets->options (valid-targets->options targets)
(valid-targets conn))
show-next-page? show-next-page?
#:path-base path-base #:path-base path-base
#:header-text header-text #:header-text header-text
#:header-link header-link))))))) #:header-link header-link))))))))))
(define* (render-revision-builds mime-types (define* (render-revision-builds mime-types
conn
commit-hash commit-hash
query-parameters query-parameters
#:key #:key
@ -1043,37 +1142,47 @@
(header-link (header-link
(string-append "/revision/" commit-hash))) (string-append "/revision/" commit-hash)))
(if (any-invalid-query-parameters? query-parameters) (if (any-invalid-query-parameters? query-parameters)
(letpar& ((systems
(with-thread-postgresql-connection valid-systems))
(targets
(with-thread-postgresql-connection valid-targets)))
(render-html (render-html
#:sxml (view-revision-builds query-parameters #:sxml
(view-revision-builds query-parameters
commit-hash commit-hash
build-status-strings build-status-strings
(valid-systems conn) systems
(valid-targets->options (valid-targets->options targets)
(valid-targets conn))
'() '()
'() '()
'())) '())))
(let ((system (assq-ref query-parameters 'system)) (let ((system (assq-ref query-parameters 'system))
(target (assq-ref query-parameters 'target))) (target (assq-ref query-parameters 'target)))
(render-html (letpar& ((systems
#:sxml (view-revision-builds query-parameters (with-thread-postgresql-connection valid-systems))
commit-hash (targets
build-status-strings (with-thread-postgresql-connection valid-targets))
(valid-systems conn) (build-server-options
(valid-targets->options (with-thread-postgresql-connection
(valid-targets conn)) (lambda (conn)
(map (match-lambda (map (match-lambda
((id url lookup-all-derivations ((id url lookup-all-derivations
lookup-builds) lookup-builds)
(cons url id))) (cons url id)))
(select-build-servers conn)) (select-build-servers conn)))))
(stats
(with-thread-postgresql-connection
(lambda (conn)
(select-build-stats (select-build-stats
conn conn
(assq-ref query-parameters (assq-ref query-parameters
'build_server) 'build_server)
#:revision-commit commit-hash #:revision-commit commit-hash
#:system system #:system system
#:target target) #:target target))))
(builds
(with-thread-postgresql-connection
(lambda (conn)
(select-builds-with-context (select-builds-with-context
conn conn
(assq-ref query-parameters (assq-ref query-parameters
@ -1084,10 +1193,18 @@
#:system system #:system system
#:target target #:target target
#:limit (assq-ref query-parameters #:limit (assq-ref query-parameters
'limit_results))))))) '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 (define* (render-revision-lint-warnings mime-types
conn
commit-hash commit-hash
query-parameters query-parameters
#:key #:key
@ -1097,18 +1214,24 @@
(header-link (header-link
(string-append "/revision/" commit-hash))) (string-append "/revision/" commit-hash)))
(define lint-checker-options (define lint-checker-options
(parallel-via-thread-pool-channel
(with-thread-postgresql-connection
(lambda (conn)
(map (match-lambda (map (match-lambda
((name description network-dependent) ((name description network-dependent)
(cons (string-append name ": " description ) (cons (string-append name ": " description )
name))) name)))
(lint-checkers-for-revision conn commit-hash))) (lint-checkers-for-revision conn commit-hash))))))
(define lint-warnings-locale-options (define lint-warnings-locale-options
(parallel-via-thread-pool-channel
(with-thread-postgresql-connection
(lambda (conn)
(map (map
(match-lambda (match-lambda
((locale) ((locale)
locale)) locale))
(lint-warning-message-locales-for-revision conn commit-hash))) (lint-warning-message-locales-for-revision conn commit-hash))))))
(if (any-invalid-query-parameters? query-parameters) (if (any-invalid-query-parameters? query-parameters)
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
@ -1125,25 +1248,31 @@
'() '()
lint-checker-options lint-checker-options
lint-warnings-locale-options lint-warnings-locale-options
#t ; any-translated-lint-warnings?
#:path-base path-base #:path-base path-base
#:header-text header-text #:header-text header-text
#:header-link header-link)))) #:header-link header-link))))
(let* ((locale (assq-ref query-parameters 'locale)) (let ((locale (assq-ref query-parameters 'locale))
(package-query (assq-ref query-parameters 'package_query)) (package-query (assq-ref query-parameters 'package_query))
(linters (assq-ref query-parameters 'linter)) (linters (assq-ref query-parameters 'linter))
(message-query (assq-ref query-parameters 'message_query)) (message-query (assq-ref query-parameters 'message_query))
(fields (assq-ref query-parameters 'field)) (fields (assq-ref query-parameters 'field)))
(git-repositories (letpar&
((git-repositories
(with-thread-postgresql-connection
(lambda (conn)
(git-repositories-containing-commit conn (git-repositories-containing-commit conn
commit-hash)) commit-hash))))
(lint-warnings (lint-warnings
(with-thread-postgresql-connection
(lambda (conn)
(lint-warnings-for-guix-revision conn commit-hash (lint-warnings-for-guix-revision conn commit-hash
#:locale locale #:locale locale
#:package-query package-query #:package-query package-query
#:linters linters #:linters linters
#:message-query message-query)) #:message-query message-query)))))
(any-translated-lint-warnings? (let ((any-translated-lint-warnings?
(any-translated-lint-warnings? lint-warnings locale))) (any-translated-lint-warnings? lint-warnings locale)))
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
'(application/json text/html) '(application/json text/html)
@ -1190,4 +1319,4 @@
#:path-base path-base #:path-base path-base
#:header-text header-text #:header-text header-text
#:header-link header-link) #:header-link header-link)
#:extra-headers http-headers-for-unchanging-content)))))) #:extra-headers http-headers-for-unchanging-content))))))))