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

105
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,15 +56,18 @@
(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
(if build-server-build-id (parallel-via-thread-pool-channel
(select-build-by-build-server-and-build-server-build-id (with-thread-postgresql-connection
conn (lambda (conn)
build-server-id (if build-server-build-id
build-server-build-id) (select-build-by-build-server-and-build-server-build-id
(select-build-by-build-server-and-derivation-file-name conn
conn build-server-id
build-server-id build-server-build-id)
derivation-file-name)))) (select-build-by-build-server-and-derivation-file-name
conn
build-server-id
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
(select-required-builds-that-failed (parallel-via-thread-pool-channel
conn (with-thread-postgresql-connection
build-server-id (lambda (conn)
derivation-file-name) (select-required-builds-that-failed
conn
build-server-id
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)
(with-postgresql-transaction (parallel-via-thread-pool-channel
conn (with-thread-postgresql-connection
(lambda (conn) (lambda (conn)
(handle-derivation-events (with-postgresql-transaction
(filter (lambda (item) conn
(let ((type (assoc-ref item "type"))) (lambda (conn)
(if type (handle-derivation-events
(string=? type "build") conn
(begin (filter (lambda (item)
(simple-format (current-error-port) (let ((type (assoc-ref item "type")))
"warning: unknown type for event: ~A\n" (if type
item) (string=? type "build")
#f)))) (begin
items))))) (simple-format
(current-error-port)
"warning: unknown type for event: ~A\n"
item)
#f))))
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
secret-key-base (with-thread-postgresql-connection
build-server-id))) (lambda (conn)
(compute-tokens-for-build-server conn
secret-key-base
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)))

61
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
(select-builds-with-context (with-thread-postgresql-connection
conn (lambda (conn)
(assq-ref parsed-query-parameters (select-builds-with-context
'build_status) conn
(assq-ref parsed-query-parameters (assq-ref parsed-query-parameters
'build_server))))))) 'build_status)
(assq-ref parsed-query-parameters
'build_server))))))
(render-html
#:sxml (view-builds parsed-query-parameters
build-status-strings
build-servers
build-stats
builds-with-context))))))

740
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
s (lambda (conn)
(make-invalid-query-parameter (guix-commit-exists? conn s))))
s "unknown commit")))) s
(make-invalid-query-parameter
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
file-name (lambda (conn)
(make-invalid-query-parameter (select-derivation-by-file-name conn file-name))))
file-name "unknown derivation")))) file-name
(make-invalid-query-parameter
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,17 +127,15 @@
'((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)))
(define (texinfo->variants-alist s) (define (texinfo->variants-alist s)
@ -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,195 +156,79 @@
(render-json (render-json
'((error . "invalid query")))) '((error . "invalid query"))))
(else (else
(render-html (letpar& ((base-job
#:sxml (compare-invalid-parameters (match (assq-ref query-parameters 'base_commit)
query-parameters (($ <invalid-query-parameter> value)
(match (assq-ref query-parameters 'base_commit) (with-thread-postgresql-connection
(($ <invalid-query-parameter> value) (lambda (conn)
(select-job-for-commit conn value)) (select-job-for-commit conn value))))
(_ #f)) (_ #f)))
(match (assq-ref query-parameters 'target_commit) (target-job
(($ <invalid-query-parameter> value) (match (assq-ref query-parameters 'target_commit)
(select-job-for-commit conn value)) (($ <invalid-query-parameter> value)
(_ #f)))))) (with-thread-postgresql-connection
(lambda (conn)
(select-job-for-commit conn value))))
(_ #f))))
(render-html
#:sxml (compare-invalid-parameters
query-parameters
base-job
target-job)))))
(let ((base-revision-id (commit->revision-id (letpar& ((base-revision-id
conn (with-thread-postgresql-connection
(assq-ref query-parameters 'base_commit))) (lambda (conn)
(target-revision-id (commit->revision-id (commit->revision-id
conn conn
(assq-ref query-parameters 'target_commit))) (assq-ref query-parameters 'base_commit)))))
(locale (assq-ref query-parameters 'locale))) (target-revision-id
(with-thread-postgresql-connection
(lambda (conn)
(commit->revision-id
conn
(assq-ref query-parameters 'target_commit)))))
(locale
(assq-ref query-parameters 'locale)))
(let-values (let-values
(((base-packages-vhash target-packages-vhash) (((base-packages-vhash target-packages-vhash)
(package-data->package-data-vhashes (package-data->package-data-vhashes
(package-differences-data conn (parallel-via-thread-pool-channel
base-revision-id (with-thread-postgresql-connection
target-revision-id)))) (lambda (conn)
(let* ((new-packages (package-differences-data conn
(package-data-vhashes->new-packages base-packages-vhash base-revision-id
target-packages-vhash)) target-revision-id)))))))
(removed-packages (let ((new-packages
(package-data-vhashes->removed-packages base-packages-vhash (package-data-vhashes->new-packages base-packages-vhash
target-packages-vhash)) target-packages-vhash))
(version-changes (removed-packages
(package-data-version-changes base-packages-vhash (package-data-vhashes->removed-packages base-packages-vhash
target-packages-vhash)) target-packages-vhash))
(lint-warnings-data (version-changes
(group-list-by-first-n-fields (package-data-version-changes base-packages-vhash
2 target-packages-vhash)))
(lint-warning-differences-data conn (letpar& ((lint-warnings-data
base-revision-id (with-thread-postgresql-connection
target-revision-id (lambda (conn)
locale))) (group-list-by-first-n-fields
(channel-news-data 2
(channel-news-differences-data conn (lint-warning-differences-data conn
base-revision-id base-revision-id
target-revision-id))) target-revision-id
(case (most-appropriate-mime-type locale)))))
'(application/json text/html) (channel-news-data
mime-types) (with-thread-postgresql-connection
((application/json) (lambda (conn)
(render-json (channel-news-differences-data conn
`((channel-news . ,(list->vector base-revision-id
(map target-revision-id)))))
(match-lambda
((commit tag title_text body_text change)
`(,@(if (null? commit)
'()
`((commit . ,commit)))
,@(if (null? tag)
'()
`((tag . ,tag)))
(title-text
. ,(map
(match-lambda
((lang . text)
(cons
lang
(texinfo->variants-alist text))))
title_text))
(body-text
. ,(map
(match-lambda
((lang . text)
(cons
lang
(texinfo->variants-alist text))))
body_text))
(change . ,change))))
channel-news-data)))
(new-packages . ,(list->vector new-packages))
(removed-packages . ,(list->vector removed-packages))
(version-changes . ,(list->vector
(map
(match-lambda
((name data ...)
`((name . ,name)
,@data)))
version-changes))))
#:extra-headers http-headers-for-unchanging-content))
(else
(render-html
#:sxml (compare query-parameters
(guix-revisions-cgit-url-bases
conn
(list base-revision-id
target-revision-id))
new-packages
removed-packages
version-changes
lint-warnings-data
lint-warnings-locale-options
channel-news-data)
#:extra-headers http-headers-for-unchanging-content))))))))
(define (render-compare-by-datetime mime-types
conn
query-parameters)
(if (any-invalid-query-parameters? query-parameters)
(case (most-appropriate-mime-type
'(application/json text/html)
mime-types)
((application/json)
(render-json
'((error . "invalid query"))))
(else
(render-html
#:sxml (compare-invalid-parameters
query-parameters
(match (assq-ref query-parameters 'base_commit)
(($ <invalid-query-parameter> value)
(select-job-for-commit conn value))
(_ #f))
(match (assq-ref query-parameters 'target_commit)
(($ <invalid-query-parameter> value)
(select-job-for-commit conn value))
(_ #f))))))
(let ((base-branch (assq-ref query-parameters 'base_branch))
(base-datetime (assq-ref query-parameters 'base_datetime))
(target-branch (assq-ref query-parameters 'target_branch))
(target-datetime (assq-ref query-parameters 'target_datetime))
(locale (assq-ref query-parameters 'locale)))
(let* ((base-revision-details
(select-guix-revision-for-branch-and-datetime conn
base-branch
base-datetime))
(lint-warnings-locale-options
(map
(match-lambda
((locale)
locale))
(lint-warning-message-locales-for-revision
conn (second base-revision-details))))
(base-revision-id
(first base-revision-details))
(target-revision-details
(select-guix-revision-for-branch-and-datetime conn
target-branch
target-datetime))
(target-revision-id
(first target-revision-details)))
(let-values
(((base-packages-vhash target-packages-vhash)
(package-data->package-data-vhashes
(package-differences-data conn
base-revision-id
target-revision-id))))
(let* ((new-packages
(package-data-vhashes->new-packages base-packages-vhash
target-packages-vhash))
(removed-packages
(package-data-vhashes->removed-packages base-packages-vhash
target-packages-vhash))
(version-changes
(package-data-version-changes base-packages-vhash
target-packages-vhash))
(lint-warnings-data
(group-list-by-first-n-fields
2
(lint-warning-differences-data conn
base-revision-id
target-revision-id
locale)))
(channel-news-data
(channel-news-differences-data conn
base-revision-id
target-revision-id)))
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
'(application/json text/html) '(application/json text/html)
mime-types) mime-types)
((application/json) ((application/json)
(render-json (render-json
`((revisions `((channel-news . ,(list->vector
. ((base
. ((commit . ,(second base-revision-details))
(datetime . ,(fifth base-revision-details))))
(target
. ((commit . ,(second target-revision-details))
(datetime . ,(fifth target-revision-details))))))
(channel-news . ,(list->vector
(map (map
(match-lambda (match-lambda
((commit tag title_text body_text change) ((commit tag title_text body_text change)
@ -393,24 +267,202 @@
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
(base_commit . ,(second base-revision-details)) (match-lambda
(target_commit . ,(second target-revision-details))) ((locale)
(guix-revisions-cgit-url-bases locale))
conn (with-thread-postgresql-connection
(list base-revision-id (lambda (conn)
target-revision-id)) (lint-warning-message-locales-for-revision
new-packages conn
removed-packages (assq-ref query-parameters 'target_commit))))))
version-changes (cgit-url-bases
lint-warnings-data (with-thread-postgresql-connection
lint-warnings-locale-options (lambda (conn)
channel-news-data) (guix-revisions-cgit-url-bases
#:extra-headers http-headers-for-unchanging-content))))))))) conn
(list base-revision-id
target-revision-id))))))
(render-html
#:sxml (compare query-parameters
cgit-url-bases
new-packages
removed-packages
version-changes
lint-warnings-data
lint-warnings-locale-options
channel-news-data)
#:extra-headers http-headers-for-unchanging-content))))))))))
(define (render-compare-by-datetime mime-types
query-parameters)
(if (any-invalid-query-parameters? query-parameters)
(case (most-appropriate-mime-type
'(application/json text/html)
mime-types)
((application/json)
(render-json
'((error . "invalid query"))))
(else
(letpar& ((base-job
(match (assq-ref query-parameters 'base_commit)
(($ <invalid-query-parameter> value)
(with-thread-postgresql-connection
(lambda (conn)
(select-job-for-commit conn value))))
(_ #f)))
(target-job
(match (assq-ref query-parameters 'target_commit)
(($ <invalid-query-parameter> value)
(with-thread-postgresql-connection
(lambda (conn)
(select-job-for-commit conn value))))
(_ #f))))
(render-html
#:sxml (compare-invalid-parameters
query-parameters
base-job
target-job)))))
(let ((base-branch (assq-ref query-parameters 'base_branch))
(base-datetime (assq-ref query-parameters 'base_datetime))
(target-branch (assq-ref query-parameters 'target_branch))
(target-datetime (assq-ref query-parameters 'target_datetime))
(locale (assq-ref query-parameters 'locale)))
(letpar& ((base-revision-details
(with-thread-postgresql-connection
(lambda (conn)
(select-guix-revision-for-branch-and-datetime
conn
base-branch
base-datetime))))
(target-revision-details
(with-thread-postgresql-connection
(lambda (conn)
(select-guix-revision-for-branch-and-datetime
conn
target-branch
target-datetime)))))
(letpar& ((lint-warnings-locale-options
(map
(match-lambda
((locale)
locale))
(with-thread-postgresql-connection
(lambda (conn)
(lint-warning-message-locales-for-revision
conn
(second base-revision-details)))))))
(let ((base-revision-id
(first base-revision-details))
(target-revision-id
(first target-revision-details)))
(let-values
(((base-packages-vhash target-packages-vhash)
(package-data->package-data-vhashes
(parallel-via-thread-pool-channel
(with-thread-postgresql-connection
(lambda (conn)
(package-differences-data conn
base-revision-id
target-revision-id)))))))
(let* ((new-packages
(package-data-vhashes->new-packages base-packages-vhash
target-packages-vhash))
(removed-packages
(package-data-vhashes->removed-packages base-packages-vhash
target-packages-vhash))
(version-changes
(package-data-version-changes base-packages-vhash
target-packages-vhash))
(channel-news-data
(parallel-via-thread-pool-channel
(with-thread-postgresql-connection
(lambda (conn)
(channel-news-differences-data conn
base-revision-id
target-revision-id))))))
(case (most-appropriate-mime-type
'(application/json text/html)
mime-types)
((application/json)
(render-json
`((revisions
. ((base
. ((commit . ,(second base-revision-details))
(datetime . ,(fifth base-revision-details))))
(target
. ((commit . ,(second target-revision-details))
(datetime . ,(fifth target-revision-details))))))
(channel-news . ,(list->vector
(map
(match-lambda
((commit tag title_text body_text change)
`(,@(if (null? commit)
'()
`((commit . ,commit)))
,@(if (null? tag)
'()
`((tag . ,tag)))
(title-text
. ,(map
(match-lambda
((lang . text)
(cons
lang
(texinfo->variants-alist text))))
title_text))
(body-text
. ,(map
(match-lambda
((lang . text)
(cons
lang
(texinfo->variants-alist text))))
body_text))
(change . ,change))))
channel-news-data)))
(new-packages . ,(list->vector new-packages))
(removed-packages . ,(list->vector removed-packages))
(version-changes . ,(list->vector
(map
(match-lambda
((name data ...)
`((name . ,name)
,@data)))
version-changes))))
#:extra-headers http-headers-for-unchanging-content))
(else
(render-html
#:sxml (compare `(,@query-parameters
(base_commit . ,(second base-revision-details))
(target_commit . ,(second target-revision-details)))
(parallel-via-thread-pool-channel
(with-thread-postgresql-connection
(lambda (conn)
(guix-revisions-cgit-url-bases
conn
(list base-revision-id
target-revision-id)))))
new-packages
removed-packages
version-changes
(parallel-via-thread-pool-channel
(group-list-by-first-n-fields
2
(with-thread-postgresql-connection
(lambda (conn)
(lint-warning-differences-data
conn
base-revision-id
target-revision-id
locale)))))
lint-warnings-locale-options
channel-news-data)
#:extra-headers http-headers-for-unchanging-content)))))))))))
(define (render-compare/derivation mime-types (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
(derivation-differences-data conn (with-thread-postgresql-connection
base-derivation (lambda (conn)
target-derivation))) (derivation-differences-data conn
base-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,41 +533,42 @@
(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
(package-derivation-differences-data (lambda (conn)
conn (package-derivation-differences-data
(commit->revision-id conn base-commit) conn
(commit->revision-id conn target-commit) (commit->revision-id conn base-commit)
#:systems systems (commit->revision-id conn target-commit)
#:targets targets)) #:systems systems
(names-and-versions #:targets targets)))))
(package-derivation-data->names-and-versions data))) (let ((names-and-versions
(let-values (package-derivation-data->names-and-versions data)))
(((base-packages-vhash target-packages-vhash) (let-values
(package-derivation-data->package-derivation-data-vhashes data))) (((base-packages-vhash target-packages-vhash)
(let ((derivation-changes (package-derivation-data->package-derivation-data-vhashes data)))
(package-derivation-data-changes names-and-versions (let ((derivation-changes
base-packages-vhash (package-derivation-data-changes names-and-versions
target-packages-vhash))) base-packages-vhash
(case (most-appropriate-mime-type target-packages-vhash)))
'(application/json text/html) (case (most-appropriate-mime-type
mime-types) '(application/json text/html)
((application/json) mime-types)
(render-json ((application/json)
derivation-changes (render-json
#:extra-headers http-headers-for-unchanging-content)) derivation-changes
(else #:extra-headers http-headers-for-unchanging-content))
(render-html (else
#:sxml (compare/derivations (render-html
query-parameters #:sxml (compare/derivations
(valid-systems conn) query-parameters
build-status-strings (parallel-via-thread-pool-channel
derivation-changes) (with-thread-postgresql-connection valid-systems))
#:extra-headers http-headers-for-unchanging-content))))))))) build-status-strings
derivation-changes)
#: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,50 +606,58 @@
(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
(select-guix-revision-for-branch-and-datetime conn (with-thread-postgresql-connection
base-branch (lambda (conn)
base-datetime)) (select-guix-revision-for-branch-and-datetime conn
base-branch
base-datetime))))
(target-revision-details (target-revision-details
(select-guix-revision-for-branch-and-datetime conn (with-thread-postgresql-connection
target-branch (lambda (conn)
target-datetime)) (select-guix-revision-for-branch-and-datetime conn
(data target-branch
(package-derivation-differences-data conn target-datetime)))))
(first base-revision-details) (letpar&
(first target-revision-details) ((data
#:systems systems (with-thread-postgresql-connection
#:targets targets)) (lambda (conn)
(names-and-versions (package-derivation-differences-data
(package-derivation-data->names-and-versions data))) conn
(let-values (first base-revision-details)
(((base-packages-vhash target-packages-vhash) (first target-revision-details)
(package-derivation-data->package-derivation-data-vhashes data))) #:systems systems
(let ((derivation-changes #:targets targets)))))
(package-derivation-data-changes names-and-versions (let ((names-and-versions
base-packages-vhash (package-derivation-data->names-and-versions data)))
target-packages-vhash))) (let-values
(case (most-appropriate-mime-type (((base-packages-vhash target-packages-vhash)
'(application/json text/html) (package-derivation-data->package-derivation-data-vhashes data)))
mime-types) (let ((derivation-changes
((application/json) (package-derivation-data-changes names-and-versions
(render-json base-packages-vhash
derivation-changes target-packages-vhash)))
#:extra-headers http-headers-for-unchanging-content)) (case (most-appropriate-mime-type
(else '(application/json text/html)
(render-html mime-types)
#:sxml (compare-by-datetime/derivations ((application/json)
query-parameters (render-json
(valid-systems conn) derivation-changes
build-status-strings #:extra-headers http-headers-for-unchanging-content))
base-revision-details (else
target-revision-details (render-html
derivation-changes) #:sxml (compare-by-datetime/derivations
#:extra-headers http-headers-for-unchanging-content))))))))) query-parameters
(parallel-via-thread-pool-channel
(with-thread-postgresql-connection valid-systems))
build-status-strings
base-revision-details
target-revision-details
derivation-changes)
#:extra-headers http-headers-for-unchanging-content)))))))))))
(define (render-compare/packages mime-types (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
(package-differences-data conn (parallel-via-thread-pool-channel
base-revision-id (with-thread-postgresql-connection
target-revision-id)))) (lambda (conn)
(package-differences-data conn
base-revision-id
target-revision-id)))))))
(case (most-appropriate-mime-type (case (most-appropriate-mime-type
'(application/json text/html) '(application/json text/html)
mime-types) mime-types)

509
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,54 +160,66 @@
(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)))
(for-each (for-each
(match-lambda (match-lambda
(('name . _) #f) (('name . _) #f)
((field . value) ((field . value)
(let ((metric (or (assq-ref pg-stat-metrics field) (let ((metric (or (assq-ref pg-stat-metrics field)
(error field)))) (error field))))
(metric-set metric (metric-set metric
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)
(metric-set (metric-set
load-new-guix-revision-job-count load-new-guix-revision-job-count
count count
#: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
conn (with-thread-postgresql-connection
(first derivation))) (lambda (conn)
(derivation-outputs (select-derivation-outputs-by-derivation-id (select-derivation-inputs-by-derivation-id
conn
(first derivation)))
(builds (select-builds-with-context-by-derivation-file-name
conn conn
(second derivation)))) (first derivation)))))
(derivation-outputs
(with-thread-postgresql-connection
(lambda (conn)
(select-derivation-outputs-by-derivation-id
conn
(first derivation)))))
(builds
(with-thread-postgresql-connection
(lambda (conn)
(select-builds-with-context-by-derivation-file-name
conn
(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
(if derivation (with-thread-postgresql-connection
(let ((derivation-inputs (select-derivation-inputs-by-derivation-id (lambda (conn)
conn (select-derivation-by-file-name conn
(first derivation))) derivation-file-name))))))
(derivation-outputs (select-derivation-outputs-by-derivation-id (if derivation
conn (letpar& ((derivation-inputs
(first derivation))) (with-thread-postgresql-connection
(derivation-sources (select-derivation-sources-by-derivation-id (lambda (conn)
conn (select-derivation-inputs-by-derivation-id
(first derivation)))) conn
(first derivation)))))
(derivation-outputs
(with-thread-postgresql-connection
(lambda (conn)
(select-derivation-outputs-by-derivation-id
conn
(first derivation)))))
(derivation-sources
(with-thread-postgresql-connection
(lambda (conn)
(select-derivation-sources-by-derivation-id
conn
(first derivation))))))
(render-json (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
conn (parallel-via-thread-pool-channel
(first derivation))) (with-thread-postgresql-connection
(derivation-outputs (select-derivation-outputs-by-derivation-id (lambda (conn)
conn (select-derivation-inputs-by-derivation-id
(first derivation))) conn
(derivation-sources (select-derivation-sources-by-derivation-id (first derivation))))))
conn (derivation-outputs
(first derivation)))) (parallel-via-thread-pool-channel
(with-thread-postgresql-connection
(lambda (conn)
(select-derivation-outputs-by-derivation-id
conn
(first derivation))))))
(derivation-sources
(parallel-via-thread-pool-channel
(with-thread-postgresql-connection
(lambda (conn)
(select-derivation-sources-by-derivation-id
conn
(first derivation)))))))
(render-html (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
conn (parallel-via-thread-pool-channel
(string-append "/gnu/store/" filename)))) (with-thread-postgresql-connection
(lambda (conn)
(select-nars-for-output
conn
(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
(select-builds-with-context-by-derivation-output (lambda (conn)
conn filename))))))) (select-nars-for-output conn filename))))
(builds
(with-thread-postgresql-connection
(lambda (conn)
(select-builds-with-context-by-derivation-output
conn
filename)))))
(render-html
#:sxml (view-store-item filename
derivations
derivations-using-store-item-list
nars
builds)))))))
(define (render-json-store-item 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,43 +431,54 @@
(match-lambda (match-lambda
((key . value) ((key . value)
`((,key . ,value)))) `((,key . ,value))))
(select-derivation-source-file-nar-details-by-file-name (parallel-via-thread-pool-channel
conn (with-thread-postgresql-connection
filename))))))))) (lambda (conn)
(select-derivation-source-file-nar-details-by-file-name
conn
filename))))))))))))
(derivations (derivations
(render-json (letpar& ((nars
`((nars . ,(list->vector (with-thread-postgresql-connection
(map (lambda (conn)
(match-lambda (select-nars-for-output conn filename)))))
((_ hash _ urls signatures) (render-json
`((hash . ,hash) `((nars . ,(list->vector
(urls (map
. ,(list->vector (match-lambda
(map ((_ hash _ urls signatures)
(lambda (url-data) `((hash . ,hash)
`((size . ,(assoc-ref url-data "size")) (urls
(compression . ,(assoc-ref url-data "compression")) . ,(list->vector
(url . ,(assoc-ref url-data "url")))) (map
urls))) (lambda (url-data)
(signatures `((size . ,(assoc-ref url-data "size"))
. ,(list->vector (compression . ,(assoc-ref url-data "compression"))
(map (url . ,(assoc-ref url-data "url"))))
(lambda (signature) urls)))
`((version . ,(assoc-ref signature "version")) (signatures
(host-name . ,(assoc-ref signature "host_name")))) . ,(list->vector
signatures)))))) (map
(select-nars-for-output conn filename)))) (lambda (signature)
(derivations `((version . ,(assoc-ref signature "version"))
. ,(list->vector (host-name . ,(assoc-ref signature "host_name"))))
(map signatures))))))
(match-lambda nars)))
((filename output-id) (derivations
`((filename . ,filename) . ,(list->vector
(derivations-using-store-item (map
. ,(list->vector (match-lambda
(map car (select-derivations-using-output ((filename output-id)
conn output-id))))))) `((filename . ,filename)
derivations))))))))) (derivations-using-store-item
. ,(list->vector
(map car
(parallel-via-thread-pool-channel
(with-thread-postgresql-connection
(lambda (conn)
(select-derivations-using-output
conn output-id))))))))))
derivations))))))))))
(define handle-static-assets (define handle-static-assets
(if assets-dir-in-store? (if assets-dir-in-store?
@ -393,50 +492,12 @@
mime-types body mime-types body
secret-key-base) secret-key-base)
(define (controller-thunk) (define (controller-thunk)
(match method-and-path-components (actual-controller request
(('GET "assets" rest ...) method-and-path-components
(or (handle-static-assets (string-join rest "/") mime-types
(request-headers request)) body
(not-found (request-uri request)))) secret-key-base))
(('GET "healthcheck")
(let ((database-status
(catch
#t
(lambda ()
(with-postgresql-connection
"web healthcheck"
(lambda (conn)
(number? (count-guix-revisions conn)))))
(lambda (key . args)
#f))))
(render-json
`((status . ,(if database-status
"ok"
"not ok")))
#:code (if (eq? database-status
#t)
200
500))))
(('GET "README")
(let ((filename (string-append (%config 'doc-dir) "/README.html")))
(if (file-exists? filename)
(render-html
#:sxml (readme (call-with-input-file filename
get-string-all)))
(render-html
#:sxml (general-not-found
"README not found"
"The README.html file does not exist")
#:code 404))))
(_
(with-thread-postgresql-connection
(lambda (conn)
(controller-with-database-connection request
method-and-path-components
mime-types
body
conn
secret-key-base))))))
(call-with-error-handling (call-with-error-handling
controller-thunk controller-thunk
#:on-error 'backtrace #:on-error 'backtrace
@ -447,12 +508,11 @@
#f)) #f))
#:code 500)))) #:code 500))))
(define (controller-with-database-connection request (define (actual-controller request
method-and-path-components method-and-path-components
mime-types mime-types
body body
conn secret-key-base)
secret-key-base)
(define path (define path
(uri-path (request-uri request))) (uri-path (request-uri request)))
@ -460,8 +520,7 @@
(or (f request (or (f request
method-and-path-components method-and-path-components
mime-types mime-types
body body)
conn)
(render-html (render-html
#:sxml (general-not-found #:sxml (general-not-found
"Page not found" "Page not found"
@ -473,7 +532,6 @@
method-and-path-components method-and-path-components
mime-types mime-types
body body
conn
secret-key-base) secret-key-base)
(render-html (render-html
#:sxml (general-not-found #:sxml (general-not-found
@ -485,21 +543,63 @@
(('GET) (('GET)
(render-html (render-html
#:sxml (index #:sxml (index
(map (parallel-via-thread-pool-channel
(lambda (git-repository-details) (with-thread-postgresql-connection
(cons (lambda (conn)
git-repository-details (map
(all-branches-with-most-recent-commit (lambda (git-repository-details)
conn (first git-repository-details)))) (cons
(all-git-repositories conn))))) git-repository-details
(all-branches-with-most-recent-commit
conn (first git-repository-details))))
(all-git-repositories conn))))))))
(('GET "assets" rest ...)
(or (handle-static-assets (string-join rest "/")
(request-headers request))
(not-found (request-uri request))))
(('GET "healthcheck")
(let ((database-status
(catch
#t
(lambda ()
(with-postgresql-connection
"web healthcheck"
(lambda (conn)
(number? (count-guix-revisions conn)))))
(lambda (key . args)
#f))))
(render-json
`((status . ,(if database-status
"ok"
"not ok")))
#:code (if (eq? database-status
#t)
200
500))))
(('GET "README")
(let ((filename (string-append (%config 'doc-dir) "/README.html")))
(if (file-exists? filename)
(render-html
#:sxml (readme (call-with-input-file filename
get-string-all)))
(render-html
#:sxml (general-not-found
"README not found"
"The README.html file does not exist")
#:code 404))))
(('GET "builds") (('GET "builds")
(delegate-to build-controller)) (delegate-to build-controller))
(('GET "statistics") (('GET "statistics")
(render-html (letpar& ((guix-revisions-count
#:sxml (view-statistics (count-guix-revisions conn) (with-thread-postgresql-connection count-guix-revisions))
(count-derivations conn)))) (count-derivations
(with-thread-postgresql-connection count-derivations)))
(render-html
#:sxml (view-statistics guix-revisions-count
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
(select-serialized-derivation-by-file-name (parallel-via-thread-pool-channel
conn (with-thread-postgresql-connection
(string-append "/gnu/store/" filename)))) (lambda (conn)
(select-serialized-derivation-by-file-name
conn
(string-append "/gnu/store/" filename)))))))
(if raw-drv (if raw-drv
(render-text raw-drv) (render-text raw-drv)
(not-found (request-uri request)))) (not-found (request-uri request))))
(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

69
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
conn (with-thread-postgresql-connection
(assq-ref query-parameters 'before_id) (lambda (conn)
limit-results)) (select-jobs-and-events
(recent-events (select-recent-job-events conn))) conn
(assq-ref query-parameters 'before_id)
limit-results))))
(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)
conn (select-recent-job-events
;; TODO Ideally there wouldn't be a limit conn
#:limit (or limit-results 1000000)))) ;; TODO Ideally there wouldn't be a limit
#: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
#:character-limit (with-thread-postgresql-connection
(assq-ref query-parameters 'characters) (lambda (conn)
#:start-character (log-for-job conn job-id
(assq-ref query-parameters 'start_character)))) #:character-limit
(assq-ref query-parameters 'characters)
#: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)

108
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,51 +144,60 @@
(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
(select-serialized-derivation-by-file-name (with-thread-postgresql-connection
conn (lambda (conn)
derivation-file-name)) (select-serialized-derivation-by-file-name
(derivation-bytevector conn
(string->bytevector derivation-text derivation-file-name))))
"ISO-8859-1"))
(derivation-references (derivation-references
(select-derivation-references-by-derivation-id (with-thread-postgresql-connection
conn (lambda (conn)
(first derivation))) (select-derivation-references-by-derivation-id
(nar-bytevector conn
(call-with-values (first derivation))))))
(lambda () (let* ((derivation-bytevector
(open-bytevector-output-port)) (string->bytevector derivation-text
(lambda (port get-bytevector) "ISO-8859-1"))
(write-file-tree (nar-bytevector
derivation-file-name (call-with-values
port (lambda ()
#:file-type+size (open-bytevector-output-port))
(lambda (file) (lambda (port get-bytevector)
(values 'regular (write-file-tree
(bytevector-length derivation-bytevector))) derivation-file-name
#:file-port port
(lambda (file) #:file-type+size
(open-bytevector-input-port derivation-bytevector))) (lambda (file)
(get-bytevector))))) (values 'regular
(lambda (port) (bytevector-length derivation-bytevector)))
(display (narinfo-string derivation-file-name #:file-port
nar-bytevector (lambda (file)
derivation-references) (open-bytevector-input-port derivation-bytevector)))
port)))))) (get-bytevector)))))
(and=> (select-derivation-source-file-data-by-file-name-hash conn (lambda (port)
hash) (display (narinfo-string derivation-file-name
nar-bytevector
derivation-references)
port))))))))
(and=> (parallel-via-thread-pool-channel
(with-thread-postgresql-connection
(lambda (conn)
(select-derivation-source-file-data-by-file-name-hash conn
hash))))
(match-lambda (match-lambda
((store-path compression compressed-size ((store-path compression compressed-size
hash-algorithm hash uncompressed-size) hash-algorithm hash uncompressed-size)

411
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,16 +119,18 @@
`((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
(most-recent-commits-for-branch (with-thread-postgresql-connection
conn (lambda (conn)
(string->number repository-id) (most-recent-commits-for-branch
branch-name conn
#:limit (assq-ref parsed-query-parameters 'limit_results) (string->number repository-id)
#:after-date (assq-ref parsed-query-parameters branch-name
'after_date) #:limit (assq-ref parsed-query-parameters 'limit_results)
#:before-date (assq-ref parsed-query-parameters #:after-date (assq-ref parsed-query-parameters
'before_date)))) 'after_date)
#:before-date (assq-ref parsed-query-parameters
'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
(package-versions-for-branch conn (with-thread-postgresql-connection
(string->number repository-id) (lambda (conn)
branch-name (package-versions-for-branch conn
package-name))) (string->number repository-id)
branch-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,43 +349,46 @@
"/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)
(parse-query-parameters (latest-processed-commit-for-branch conn
request repository-id
`((locale ,identity #:default "en_US.UTF-8"))))) branch-name)))))
(if commit-hash (let ((parsed-query-parameters
(render-revision-package-version mime-types (parse-query-parameters
conn request
commit-hash `((locale ,identity #:default "en_US.UTF-8")))))
name (if commit-hash
version (render-revision-package-version mime-types
parsed-query-parameters commit-hash
#:header-text name
`("Latest processed revision for branch " version
(samp ,branch-name)) parsed-query-parameters
#:header-link #:header-text
(string-append `("Latest processed revision for branch "
"/repository/" repository-id (samp ,branch-name))
"/branch/" branch-name #:header-link
"/latest-processed-revision") (string-append
#:version-history-link "/repository/" repository-id
(string-append "/branch/" branch-name
"/repository/" repository-id "/latest-processed-revision")
"/branch/" branch-name #:version-history-link
"/package/" name)) (string-append
(render-unknown-revision mime-types "/repository/" repository-id
conn "/branch/" branch-name
commit-hash)))) "/package/" name))
(_ #f))) (render-unknown-revision mime-types
commit-hash)))))
(_ #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,70 +397,77 @@
(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-for-branch conn ((package-derivations
(string->number repository-id) (with-thread-postgresql-connection
branch-name (lambda (conn)
system (package-derivations-for-branch conn
target (string->number repository-id)
package-name)) branch-name
system
target
package-name))))
(build-server-urls (build-server-urls
(select-build-server-urls-by-id conn))) (with-thread-postgresql-connection
(case (most-appropriate-mime-type select-build-server-urls-by-id)))
'(application/json text/html) (case (most-appropriate-mime-type
mime-types) '(application/json text/html)
((application/json) mime-types)
(render-json ((application/json)
`((derivations . ,(list->vector (render-json
(map (match-lambda `((derivations . ,(list->vector
((package-version derivation-file-name (map (match-lambda
first-guix-revision-commit ((package-version derivation-file-name
first-datetime first-guix-revision-commit
last-guix-revision-commit first-datetime
last-datetime last-guix-revision-commit
builds) last-datetime
`((version . ,package-version) builds)
(derivation . ,derivation-file-name) `((version . ,package-version)
(first_revision (derivation . ,derivation-file-name)
. ((commit . ,first-guix-revision-commit) (first_revision
(datetime . ,first-datetime))) . ((commit . ,first-guix-revision-commit)
(last_revision (datetime . ,first-datetime)))
. ((commit . ,last-guix-revision-commit) (last_revision
(datetime . ,last-datetime))) . ((commit . ,last-guix-revision-commit)
(builds (datetime . ,last-datetime)))
. ,(list->vector builds))))) (builds
package-derivations)))))) . ,(list->vector builds)))))
(else package-derivations))))))
(render-html (else
#:sxml (view-branch-package-derivations (letpar& ((systems
parsed-query-parameters (with-thread-postgresql-connection
repository-id valid-systems))
branch-name (targets
package-name (with-thread-postgresql-connection
(valid-systems conn) valid-targets)))
(valid-targets->options (render-html
(valid-targets conn)) #:sxml (view-branch-package-derivations
build-server-urls parsed-query-parameters
package-derivations))))))) repository-id
branch-name
package-name
systems
(valid-targets->options targets)
build-server-urls
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,60 +476,69 @@
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-for-branch conn ((package-outputs
(string->number repository-id) (with-thread-postgresql-connection
branch-name (lambda (conn)
system (package-outputs-for-branch conn
target (string->number repository-id)
package-name branch-name
output-name)) system
target
package-name
output-name))))
(build-server-urls (build-server-urls
(select-build-server-urls-by-id conn))) (with-thread-postgresql-connection
(case (most-appropriate-mime-type select-build-server-urls-by-id)))
'(application/json text/html) (case (most-appropriate-mime-type
mime-types) '(application/json text/html)
((application/json) mime-types)
(render-json ((application/json)
`((derivations . ,(list->vector (render-json
(map (match-lambda `((derivations . ,(list->vector
((package-version derivation-file-name (map (match-lambda
first-guix-revision-commit ((package-version derivation-file-name
first-datetime first-guix-revision-commit
last-guix-revision-commit first-datetime
last-datetime last-guix-revision-commit
builds) last-datetime
`((version . ,package-version) builds)
(derivation . ,derivation-file-name) `((version . ,package-version)
(first_revision (derivation . ,derivation-file-name)
. ((commit . ,first-guix-revision-commit) (first_revision
(datetime . ,first-datetime))) . ((commit . ,first-guix-revision-commit)
(last_revision (datetime . ,first-datetime)))
. ((commit . ,last-guix-revision-commit) (last_revision
(datetime . ,last-datetime))) . ((commit . ,last-guix-revision-commit)
(builds (datetime . ,last-datetime)))
. ,(list->vector builds))))) (builds
package-outputs)))))) . ,(list->vector builds)))))
(else package-outputs))))))
(render-html (else
#:sxml (view-branch-package-outputs (letpar& ((systems
parsed-query-parameters (with-thread-postgresql-connection
repository-id valid-systems))
branch-name (targets
package-name (with-thread-postgresql-connection
output-name valid-targets)))
(valid-systems conn) (render-html
(valid-targets->options #:sxml (view-branch-package-outputs
(valid-targets conn)) parsed-query-parameters
build-server-urls repository-id
package-outputs))))))) branch-name
package-name
output-name
systems
(valid-targets->options targets)
build-server-urls
package-outputs)))))))))

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

File diff suppressed because it is too large Load diff