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

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

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

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

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

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

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

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

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

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

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

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

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