mirror of
git://git.savannah.gnu.org/guix/data-service.git
synced 2023-12-14 03:23:03 +01:00
Completely rework the way db connections are handled during requests
Previously, a connection was passed through the code handling the request. When queries were performed, this could block the thread though, potentially leaving the server unable to serve other requests. Instead, this now runs queries in a pool of threads. This should remove the possibility of blocking the threads used by the web server, and in doing so, some of the queries have been parallelised. I''m still not sure about the naming and syntax, but I think the functionality is a sort of step forward.
This commit is contained in:
Christopher Baines
parent
e2e55c69de
commit
c3c9c07f9a
|
|
@ -20,6 +20,7 @@
|
|||
#:use-module (ice-9 match)
|
||||
#:use-module (rnrs bytevectors)
|
||||
#:use-module (json)
|
||||
#:use-module (guix-data-service utils)
|
||||
#:use-module (guix-data-service database)
|
||||
#:use-module (guix-data-service web render)
|
||||
#:use-module (guix-data-service web query-parameters)
|
||||
|
|
@ -36,7 +37,6 @@
|
|||
#:export (build-server-controller))
|
||||
|
||||
(define (render-build mime-types
|
||||
conn
|
||||
build-server-id
|
||||
query-parameters)
|
||||
(if (any-invalid-query-parameters? query-parameters)
|
||||
|
|
@ -56,15 +56,18 @@
|
|||
(build-server-build-id
|
||||
(assq-ref query-parameters 'build_server_build_id))
|
||||
(build
|
||||
(if build-server-build-id
|
||||
(select-build-by-build-server-and-build-server-build-id
|
||||
conn
|
||||
build-server-id
|
||||
build-server-build-id)
|
||||
(select-build-by-build-server-and-derivation-file-name
|
||||
conn
|
||||
build-server-id
|
||||
derivation-file-name))))
|
||||
(parallel-via-thread-pool-channel
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(if build-server-build-id
|
||||
(select-build-by-build-server-and-build-server-build-id
|
||||
conn
|
||||
build-server-id
|
||||
build-server-build-id)
|
||||
(select-build-by-build-server-and-derivation-file-name
|
||||
conn
|
||||
build-server-id
|
||||
derivation-file-name)))))))
|
||||
(if build
|
||||
(render-html
|
||||
#:sxml
|
||||
|
|
@ -80,10 +83,13 @@
|
|||
; guix-build-coordinator
|
||||
; doesn't mark builds as
|
||||
; failed-dependency
|
||||
(select-required-builds-that-failed
|
||||
conn
|
||||
build-server-id
|
||||
derivation-file-name)
|
||||
(parallel-via-thread-pool-channel
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(select-required-builds-that-failed
|
||||
conn
|
||||
build-server-id
|
||||
derivation-file-name))))
|
||||
#f)))))
|
||||
(render-html
|
||||
#:sxml (general-not-found
|
||||
|
|
@ -106,12 +112,11 @@
|
|||
(define (handle-build-event-submission parsed-query-parameters
|
||||
build-server-id-string
|
||||
body
|
||||
conn
|
||||
secret-key-base)
|
||||
(define build-server-id
|
||||
(string->number build-server-id-string))
|
||||
|
||||
(define (handle-derivation-events items)
|
||||
(define (handle-derivation-events conn items)
|
||||
(unless (null? items)
|
||||
(let ((build-ids
|
||||
(insert-builds conn
|
||||
|
|
@ -132,30 +137,38 @@
|
|||
items)))))
|
||||
|
||||
(define (process-items items)
|
||||
(with-postgresql-transaction
|
||||
conn
|
||||
(lambda (conn)
|
||||
(handle-derivation-events
|
||||
(filter (lambda (item)
|
||||
(let ((type (assoc-ref item "type")))
|
||||
(if type
|
||||
(string=? type "build")
|
||||
(begin
|
||||
(simple-format (current-error-port)
|
||||
"warning: unknown type for event: ~A\n"
|
||||
item)
|
||||
#f))))
|
||||
items)))))
|
||||
(parallel-via-thread-pool-channel
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(with-postgresql-transaction
|
||||
conn
|
||||
(lambda (conn)
|
||||
(handle-derivation-events
|
||||
conn
|
||||
(filter (lambda (item)
|
||||
(let ((type (assoc-ref item "type")))
|
||||
(if type
|
||||
(string=? type "build")
|
||||
(begin
|
||||
(simple-format
|
||||
(current-error-port)
|
||||
"warning: unknown type for event: ~A\n"
|
||||
item)
|
||||
#f))))
|
||||
items))))))))
|
||||
|
||||
(if (any-invalid-query-parameters? parsed-query-parameters)
|
||||
(render-json
|
||||
'((error . "no token provided"))
|
||||
#:code 400)
|
||||
(let ((provided-token (assq-ref parsed-query-parameters 'token))
|
||||
(permitted-tokens (compute-tokens-for-build-server
|
||||
conn
|
||||
secret-key-base
|
||||
build-server-id)))
|
||||
(permitted-tokens
|
||||
(parallel-via-thread-pool-channel
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(compute-tokens-for-build-server conn
|
||||
secret-key-base
|
||||
build-server-id))))))
|
||||
(if (member provided-token
|
||||
(map cdr permitted-tokens)
|
||||
string=?)
|
||||
|
|
@ -201,25 +214,32 @@
|
|||
'((error . "error"))
|
||||
#:code 403)))))
|
||||
|
||||
(define (handle-signing-key-request conn id)
|
||||
(define (handle-signing-key-request id)
|
||||
(render-html
|
||||
#:sxml (view-signing-key
|
||||
(select-signing-key conn id))))
|
||||
(parallel-via-thread-pool-channel
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(select-signing-key conn id)))))))
|
||||
|
||||
(define (build-server-controller request
|
||||
method-and-path-components
|
||||
mime-types
|
||||
body
|
||||
conn
|
||||
secret-key-base)
|
||||
(match method-and-path-components
|
||||
(('GET "build-servers")
|
||||
(let ((build-servers (select-build-servers conn)))
|
||||
(letpar& ((build-servers
|
||||
(with-thread-postgresql-connection
|
||||
select-build-servers)))
|
||||
(render-build-servers mime-types
|
||||
build-servers)))
|
||||
(('GET "build-server" build-server-id)
|
||||
(let ((build-server (select-build-server conn (string->number
|
||||
build-server-id))))
|
||||
(letpar& ((build-server
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(select-build-server conn (string->number
|
||||
build-server-id))))))
|
||||
(if build-server
|
||||
(render-build-server mime-types
|
||||
build-server)
|
||||
|
|
@ -231,7 +251,6 @@
|
|||
`((derivation_file_name ,identity)
|
||||
(build_server_build_id ,identity)))))
|
||||
(render-build mime-types
|
||||
conn
|
||||
(string->number build-server-id)
|
||||
parsed-query-parameters)))
|
||||
(('POST "build-server" build-server-id "build-events")
|
||||
|
|
@ -242,9 +261,7 @@
|
|||
(handle-build-event-submission parsed-query-parameters
|
||||
build-server-id
|
||||
body
|
||||
conn
|
||||
secret-key-base)))
|
||||
(('GET "build-server" "signing-key" id)
|
||||
(handle-signing-key-request conn
|
||||
(string->number id)))
|
||||
(handle-signing-key-request (string->number id)))
|
||||
(_ #f)))
|
||||
|
|
|
|||
|
|
@ -18,6 +18,8 @@
|
|||
(define-module (guix-data-service web build controller)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (guix-data-service utils)
|
||||
#:use-module (guix-data-service database)
|
||||
#:use-module (guix-data-service web render)
|
||||
#:use-module (guix-data-service web query-parameters)
|
||||
#:use-module (guix-data-service model build)
|
||||
|
|
@ -34,9 +36,11 @@
|
|||
(string-append "unknown build status: "
|
||||
status))))
|
||||
|
||||
(define (parse-build-server conn)
|
||||
(define parse-build-server
|
||||
(lambda (v)
|
||||
(let ((build-servers (select-build-servers conn)))
|
||||
(letpar& ((build-servers
|
||||
(with-thread-postgresql-connection
|
||||
select-build-servers)))
|
||||
(or (any (match-lambda
|
||||
((id url lookup-all-derivations? lookup-builds?)
|
||||
(if (eq? (string->number v)
|
||||
|
|
@ -51,21 +55,19 @@
|
|||
(define (build-controller request
|
||||
method-and-path-components
|
||||
mime-types
|
||||
body
|
||||
conn)
|
||||
body)
|
||||
(match method-and-path-components
|
||||
(('GET "builds")
|
||||
(render-builds request
|
||||
mime-types
|
||||
conn))
|
||||
mime-types))
|
||||
(_ #f)))
|
||||
|
||||
(define (render-builds request mime-types conn)
|
||||
(define (render-builds request mime-types)
|
||||
(let ((parsed-query-parameters
|
||||
(parse-query-parameters
|
||||
request
|
||||
`((build_status ,parse-build-status #:multi-value)
|
||||
(build_server ,(parse-build-server conn) #:multi-value)))))
|
||||
(build_server ,parse-build-server #:multi-value)))))
|
||||
(if (any-invalid-query-parameters? parsed-query-parameters)
|
||||
(render-html
|
||||
#:sxml (view-builds parsed-query-parameters
|
||||
|
|
@ -73,20 +75,29 @@
|
|||
'()
|
||||
'()
|
||||
'()))
|
||||
(render-html
|
||||
#:sxml (view-builds parsed-query-parameters
|
||||
build-status-strings
|
||||
(map (match-lambda
|
||||
((id url lookup-all-derivations lookup-builds)
|
||||
(cons url id)))
|
||||
(select-build-servers conn))
|
||||
(select-build-stats
|
||||
conn
|
||||
(assq-ref parsed-query-parameters
|
||||
'build_server))
|
||||
(select-builds-with-context
|
||||
conn
|
||||
(assq-ref parsed-query-parameters
|
||||
'build_status)
|
||||
(assq-ref parsed-query-parameters
|
||||
'build_server)))))))
|
||||
(letpar& ((build-servers
|
||||
(with-thread-postgresql-connection
|
||||
select-build-servers))
|
||||
(build-stats
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(select-build-stats
|
||||
conn
|
||||
(assq-ref parsed-query-parameters
|
||||
'build_server)))))
|
||||
(builds-with-context
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(select-builds-with-context
|
||||
conn
|
||||
(assq-ref parsed-query-parameters
|
||||
'build_status)
|
||||
(assq-ref parsed-query-parameters
|
||||
'build_server))))))
|
||||
|
||||
(render-html
|
||||
#:sxml (view-builds parsed-query-parameters
|
||||
build-status-strings
|
||||
build-servers
|
||||
build-stats
|
||||
builds-with-context))))))
|
||||
|
|
|
|||
|
|
@ -23,6 +23,8 @@
|
|||
#:use-module (texinfo)
|
||||
#:use-module (texinfo html)
|
||||
#:use-module (texinfo plain-text)
|
||||
#:use-module (guix-data-service utils)
|
||||
#:use-module (guix-data-service database)
|
||||
#:use-module (guix-data-service web sxml)
|
||||
#:use-module (guix-data-service web util)
|
||||
#:use-module (guix-data-service web render)
|
||||
|
|
@ -48,35 +50,37 @@
|
|||
(define (parse-build-status s)
|
||||
s)
|
||||
|
||||
(define (parse-commit conn)
|
||||
(lambda (s)
|
||||
(if (guix-commit-exists? conn s)
|
||||
s
|
||||
(make-invalid-query-parameter
|
||||
s "unknown commit"))))
|
||||
(define (parse-commit s)
|
||||
(if (parallel-via-thread-pool-channel
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(guix-commit-exists? conn s))))
|
||||
s
|
||||
(make-invalid-query-parameter
|
||||
s "unknown commit")))
|
||||
|
||||
(define (parse-derivation conn)
|
||||
(lambda (file-name)
|
||||
(if (select-derivation-by-file-name conn file-name)
|
||||
file-name
|
||||
(make-invalid-query-parameter
|
||||
file-name "unknown derivation"))))
|
||||
(define (parse-derivation file-name)
|
||||
(if (parallel-via-thread-pool-channel
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(select-derivation-by-file-name conn file-name))))
|
||||
file-name
|
||||
(make-invalid-query-parameter
|
||||
file-name "unknown derivation")))
|
||||
|
||||
(define (compare-controller request
|
||||
method-and-path-components
|
||||
mime-types
|
||||
body
|
||||
conn)
|
||||
body)
|
||||
(match method-and-path-components
|
||||
(('GET "compare")
|
||||
(let* ((parsed-query-parameters
|
||||
(parse-query-parameters
|
||||
request
|
||||
`((base_commit ,(parse-commit conn) #:required)
|
||||
(target_commit ,(parse-commit conn) #:required)
|
||||
`((base_commit ,parse-commit #:required)
|
||||
(target_commit ,parse-commit #:required)
|
||||
(locale ,identity #:default "en_US.UTF-8")))))
|
||||
(render-compare mime-types
|
||||
conn
|
||||
parsed-query-parameters)))
|
||||
(('GET "compare-by-datetime")
|
||||
(let* ((parsed-query-parameters
|
||||
|
|
@ -88,28 +92,25 @@
|
|||
(target_datetime ,parse-datetime #:required)
|
||||
(locale ,identity #:default "en_US.UTF-8")))))
|
||||
(render-compare-by-datetime mime-types
|
||||
conn
|
||||
parsed-query-parameters)))
|
||||
(('GET "compare" "derivation")
|
||||
(let* ((parsed-query-parameters
|
||||
(parse-query-parameters
|
||||
request
|
||||
`((base_derivation ,(parse-derivation conn) #:required)
|
||||
(target_derivation ,(parse-derivation conn) #:required)))))
|
||||
`((base_derivation ,parse-derivation #:required)
|
||||
(target_derivation ,parse-derivation #:required)))))
|
||||
(render-compare/derivation mime-types
|
||||
conn
|
||||
parsed-query-parameters)))
|
||||
(('GET "compare" "derivations")
|
||||
(let* ((parsed-query-parameters
|
||||
(parse-query-parameters
|
||||
request
|
||||
`((base_commit ,(parse-commit conn) #:required)
|
||||
(target_commit ,(parse-commit conn) #:required)
|
||||
`((base_commit ,parse-commit #:required)
|
||||
(target_commit ,parse-commit #:required)
|
||||
(system ,parse-system #:multi-value)
|
||||
(target ,parse-target #:multi-value)
|
||||
(build_status ,parse-build-status #:multi-value)))))
|
||||
(render-compare/derivations mime-types
|
||||
conn
|
||||
parsed-query-parameters)))
|
||||
(('GET "compare-by-datetime" "derivations")
|
||||
(let* ((parsed-query-parameters
|
||||
|
|
@ -126,17 +127,15 @@
|
|||
'((base_commit base_datetime)
|
||||
(target_commit target_datetime)))))
|
||||
(render-compare-by-datetime/derivations mime-types
|
||||
conn
|
||||
parsed-query-parameters)))
|
||||
(('GET "compare" "packages")
|
||||
(let* ((parsed-query-parameters
|
||||
(parse-query-parameters
|
||||
request
|
||||
`((base_commit ,(parse-commit conn) #:required)
|
||||
(target_commit ,(parse-commit conn) #:required)))))
|
||||
`((base_commit ,parse-commit #:required)
|
||||
(target_commit ,parse-commit #:required)))))
|
||||
(render-compare/packages mime-types
|
||||
conn
|
||||
parsed-query-parameters)))
|
||||
parsed-query-parameters)))
|
||||
(_ #f)))
|
||||
|
||||
(define (texinfo->variants-alist s)
|
||||
|
|
@ -148,16 +147,7 @@
|
|||
(plain . ,(stexi->plain-text stexi)))))
|
||||
|
||||
(define (render-compare mime-types
|
||||
conn
|
||||
query-parameters)
|
||||
(define lint-warnings-locale-options
|
||||
(map
|
||||
(match-lambda
|
||||
((locale)
|
||||
locale))
|
||||
(lint-warning-message-locales-for-revision
|
||||
conn (assq-ref query-parameters 'target_commit))))
|
||||
|
||||
(if (any-invalid-query-parameters? query-parameters)
|
||||
(case (most-appropriate-mime-type
|
||||
'(application/json text/html)
|
||||
|
|
@ -166,195 +156,79 @@
|
|||
(render-json
|
||||
'((error . "invalid query"))))
|
||||
(else
|
||||
(render-html
|
||||
#:sxml (compare-invalid-parameters
|
||||
query-parameters
|
||||
(match (assq-ref query-parameters 'base_commit)
|
||||
(($ <invalid-query-parameter> value)
|
||||
(select-job-for-commit conn value))
|
||||
(_ #f))
|
||||
(match (assq-ref query-parameters 'target_commit)
|
||||
(($ <invalid-query-parameter> value)
|
||||
(select-job-for-commit conn value))
|
||||
(_ #f))))))
|
||||
(letpar& ((base-job
|
||||
(match (assq-ref query-parameters 'base_commit)
|
||||
(($ <invalid-query-parameter> value)
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(select-job-for-commit conn value))))
|
||||
(_ #f)))
|
||||
(target-job
|
||||
(match (assq-ref query-parameters 'target_commit)
|
||||
(($ <invalid-query-parameter> value)
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(select-job-for-commit conn value))))
|
||||
(_ #f))))
|
||||
(render-html
|
||||
#:sxml (compare-invalid-parameters
|
||||
query-parameters
|
||||
base-job
|
||||
target-job)))))
|
||||
|
||||
(let ((base-revision-id (commit->revision-id
|
||||
conn
|
||||
(assq-ref query-parameters 'base_commit)))
|
||||
(target-revision-id (commit->revision-id
|
||||
conn
|
||||
(assq-ref query-parameters 'target_commit)))
|
||||
(locale (assq-ref query-parameters 'locale)))
|
||||
(letpar& ((base-revision-id
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(commit->revision-id
|
||||
conn
|
||||
(assq-ref query-parameters 'base_commit)))))
|
||||
(target-revision-id
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(commit->revision-id
|
||||
conn
|
||||
(assq-ref query-parameters 'target_commit)))))
|
||||
(locale
|
||||
(assq-ref query-parameters 'locale)))
|
||||
(let-values
|
||||
(((base-packages-vhash target-packages-vhash)
|
||||
(package-data->package-data-vhashes
|
||||
(package-differences-data conn
|
||||
base-revision-id
|
||||
target-revision-id))))
|
||||
(let* ((new-packages
|
||||
(package-data-vhashes->new-packages base-packages-vhash
|
||||
target-packages-vhash))
|
||||
(removed-packages
|
||||
(package-data-vhashes->removed-packages base-packages-vhash
|
||||
target-packages-vhash))
|
||||
(version-changes
|
||||
(package-data-version-changes base-packages-vhash
|
||||
target-packages-vhash))
|
||||
(lint-warnings-data
|
||||
(group-list-by-first-n-fields
|
||||
2
|
||||
(lint-warning-differences-data conn
|
||||
base-revision-id
|
||||
target-revision-id
|
||||
locale)))
|
||||
(channel-news-data
|
||||
(channel-news-differences-data conn
|
||||
base-revision-id
|
||||
target-revision-id)))
|
||||
(case (most-appropriate-mime-type
|
||||
'(application/json text/html)
|
||||
mime-types)
|
||||
((application/json)
|
||||
(render-json
|
||||
`((channel-news . ,(list->vector
|
||||
(map
|
||||
(match-lambda
|
||||
((commit tag title_text body_text change)
|
||||
`(,@(if (null? commit)
|
||||
'()
|
||||
`((commit . ,commit)))
|
||||
,@(if (null? tag)
|
||||
'()
|
||||
`((tag . ,tag)))
|
||||
(title-text
|
||||
. ,(map
|
||||
(match-lambda
|
||||
((lang . text)
|
||||
(cons
|
||||
lang
|
||||
(texinfo->variants-alist text))))
|
||||
title_text))
|
||||
(body-text
|
||||
. ,(map
|
||||
(match-lambda
|
||||
((lang . text)
|
||||
(cons
|
||||
lang
|
||||
(texinfo->variants-alist text))))
|
||||
body_text))
|
||||
(change . ,change))))
|
||||
channel-news-data)))
|
||||
(new-packages . ,(list->vector new-packages))
|
||||
(removed-packages . ,(list->vector removed-packages))
|
||||
(version-changes . ,(list->vector
|
||||
(map
|
||||
(match-lambda
|
||||
((name data ...)
|
||||
`((name . ,name)
|
||||
,@data)))
|
||||
version-changes))))
|
||||
#:extra-headers http-headers-for-unchanging-content))
|
||||
(else
|
||||
(render-html
|
||||
#:sxml (compare query-parameters
|
||||
(guix-revisions-cgit-url-bases
|
||||
conn
|
||||
(list base-revision-id
|
||||
target-revision-id))
|
||||
new-packages
|
||||
removed-packages
|
||||
version-changes
|
||||
lint-warnings-data
|
||||
lint-warnings-locale-options
|
||||
channel-news-data)
|
||||
#:extra-headers http-headers-for-unchanging-content))))))))
|
||||
|
||||
(define (render-compare-by-datetime mime-types
|
||||
conn
|
||||
query-parameters)
|
||||
(if (any-invalid-query-parameters? query-parameters)
|
||||
(case (most-appropriate-mime-type
|
||||
'(application/json text/html)
|
||||
mime-types)
|
||||
((application/json)
|
||||
(render-json
|
||||
'((error . "invalid query"))))
|
||||
(else
|
||||
(render-html
|
||||
#:sxml (compare-invalid-parameters
|
||||
query-parameters
|
||||
(match (assq-ref query-parameters 'base_commit)
|
||||
(($ <invalid-query-parameter> value)
|
||||
(select-job-for-commit conn value))
|
||||
(_ #f))
|
||||
(match (assq-ref query-parameters 'target_commit)
|
||||
(($ <invalid-query-parameter> value)
|
||||
(select-job-for-commit conn value))
|
||||
(_ #f))))))
|
||||
|
||||
(let ((base-branch (assq-ref query-parameters 'base_branch))
|
||||
(base-datetime (assq-ref query-parameters 'base_datetime))
|
||||
(target-branch (assq-ref query-parameters 'target_branch))
|
||||
(target-datetime (assq-ref query-parameters 'target_datetime))
|
||||
(locale (assq-ref query-parameters 'locale)))
|
||||
(let* ((base-revision-details
|
||||
(select-guix-revision-for-branch-and-datetime conn
|
||||
base-branch
|
||||
base-datetime))
|
||||
(lint-warnings-locale-options
|
||||
(map
|
||||
(match-lambda
|
||||
((locale)
|
||||
locale))
|
||||
(lint-warning-message-locales-for-revision
|
||||
conn (second base-revision-details))))
|
||||
(base-revision-id
|
||||
(first base-revision-details))
|
||||
(target-revision-details
|
||||
(select-guix-revision-for-branch-and-datetime conn
|
||||
target-branch
|
||||
target-datetime))
|
||||
(target-revision-id
|
||||
(first target-revision-details)))
|
||||
(let-values
|
||||
(((base-packages-vhash target-packages-vhash)
|
||||
(package-data->package-data-vhashes
|
||||
(package-differences-data conn
|
||||
base-revision-id
|
||||
target-revision-id))))
|
||||
(let* ((new-packages
|
||||
(package-data-vhashes->new-packages base-packages-vhash
|
||||
target-packages-vhash))
|
||||
(removed-packages
|
||||
(package-data-vhashes->removed-packages base-packages-vhash
|
||||
target-packages-vhash))
|
||||
(version-changes
|
||||
(package-data-version-changes base-packages-vhash
|
||||
target-packages-vhash))
|
||||
(lint-warnings-data
|
||||
(group-list-by-first-n-fields
|
||||
2
|
||||
(lint-warning-differences-data conn
|
||||
base-revision-id
|
||||
target-revision-id
|
||||
locale)))
|
||||
(channel-news-data
|
||||
(channel-news-differences-data conn
|
||||
base-revision-id
|
||||
target-revision-id)))
|
||||
(parallel-via-thread-pool-channel
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(package-differences-data conn
|
||||
base-revision-id
|
||||
target-revision-id)))))))
|
||||
(let ((new-packages
|
||||
(package-data-vhashes->new-packages base-packages-vhash
|
||||
target-packages-vhash))
|
||||
(removed-packages
|
||||
(package-data-vhashes->removed-packages base-packages-vhash
|
||||
target-packages-vhash))
|
||||
(version-changes
|
||||
(package-data-version-changes base-packages-vhash
|
||||
target-packages-vhash)))
|
||||
(letpar& ((lint-warnings-data
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(group-list-by-first-n-fields
|
||||
2
|
||||
(lint-warning-differences-data conn
|
||||
base-revision-id
|
||||
target-revision-id
|
||||
locale)))))
|
||||
(channel-news-data
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(channel-news-differences-data conn
|
||||
base-revision-id
|
||||
target-revision-id)))))
|
||||
(case (most-appropriate-mime-type
|
||||
'(application/json text/html)
|
||||
mime-types)
|
||||
((application/json)
|
||||
(render-json
|
||||
`((revisions
|
||||
. ((base
|
||||
. ((commit . ,(second base-revision-details))
|
||||
(datetime . ,(fifth base-revision-details))))
|
||||
(target
|
||||
. ((commit . ,(second target-revision-details))
|
||||
(datetime . ,(fifth target-revision-details))))))
|
||||
(channel-news . ,(list->vector
|
||||
`((channel-news . ,(list->vector
|
||||
(map
|
||||
(match-lambda
|
||||
((commit tag title_text body_text change)
|
||||
|
|
@ -393,24 +267,202 @@
|
|||
version-changes))))
|
||||
#:extra-headers http-headers-for-unchanging-content))
|
||||
(else
|
||||
(render-html
|
||||
#:sxml (compare `(,@query-parameters
|
||||
(base_commit . ,(second base-revision-details))
|
||||
(target_commit . ,(second target-revision-details)))
|
||||
(guix-revisions-cgit-url-bases
|
||||
conn
|
||||
(list base-revision-id
|
||||
target-revision-id))
|
||||
new-packages
|
||||
removed-packages
|
||||
version-changes
|
||||
lint-warnings-data
|
||||
lint-warnings-locale-options
|
||||
channel-news-data)
|
||||
#:extra-headers http-headers-for-unchanging-content)))))))))
|
||||
(letpar& ((lint-warnings-locale-options
|
||||
(map
|
||||
(match-lambda
|
||||
((locale)
|
||||
locale))
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(lint-warning-message-locales-for-revision
|
||||
conn
|
||||
(assq-ref query-parameters 'target_commit))))))
|
||||
(cgit-url-bases
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(guix-revisions-cgit-url-bases
|
||||
conn
|
||||
(list base-revision-id
|
||||
target-revision-id))))))
|
||||
(render-html
|
||||
#:sxml (compare query-parameters
|
||||
cgit-url-bases
|
||||
new-packages
|
||||
removed-packages
|
||||
version-changes
|
||||
lint-warnings-data
|
||||
lint-warnings-locale-options
|
||||
channel-news-data)
|
||||
#:extra-headers http-headers-for-unchanging-content))))))))))
|
||||
|
||||
(define (render-compare-by-datetime mime-types
|
||||
query-parameters)
|
||||
(if (any-invalid-query-parameters? query-parameters)
|
||||
(case (most-appropriate-mime-type
|
||||
'(application/json text/html)
|
||||
mime-types)
|
||||
((application/json)
|
||||
(render-json
|
||||
'((error . "invalid query"))))
|
||||
(else
|
||||
(letpar& ((base-job
|
||||
(match (assq-ref query-parameters 'base_commit)
|
||||
(($ <invalid-query-parameter> value)
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(select-job-for-commit conn value))))
|
||||
(_ #f)))
|
||||
(target-job
|
||||
(match (assq-ref query-parameters 'target_commit)
|
||||
(($ <invalid-query-parameter> value)
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(select-job-for-commit conn value))))
|
||||
(_ #f))))
|
||||
(render-html
|
||||
#:sxml (compare-invalid-parameters
|
||||
query-parameters
|
||||
base-job
|
||||
target-job)))))
|
||||
|
||||
(let ((base-branch (assq-ref query-parameters 'base_branch))
|
||||
(base-datetime (assq-ref query-parameters 'base_datetime))
|
||||
(target-branch (assq-ref query-parameters 'target_branch))
|
||||
(target-datetime (assq-ref query-parameters 'target_datetime))
|
||||
(locale (assq-ref query-parameters 'locale)))
|
||||
(letpar& ((base-revision-details
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(select-guix-revision-for-branch-and-datetime
|
||||
conn
|
||||
base-branch
|
||||
base-datetime))))
|
||||
(target-revision-details
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(select-guix-revision-for-branch-and-datetime
|
||||
conn
|
||||
target-branch
|
||||
target-datetime)))))
|
||||
(letpar& ((lint-warnings-locale-options
|
||||
(map
|
||||
(match-lambda
|
||||
((locale)
|
||||
locale))
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(lint-warning-message-locales-for-revision
|
||||
conn
|
||||
(second base-revision-details)))))))
|
||||
(let ((base-revision-id
|
||||
(first base-revision-details))
|
||||
(target-revision-id
|
||||
(first target-revision-details)))
|
||||
(let-values
|
||||
(((base-packages-vhash target-packages-vhash)
|
||||
(package-data->package-data-vhashes
|
||||
(parallel-via-thread-pool-channel
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(package-differences-data conn
|
||||
base-revision-id
|
||||
target-revision-id)))))))
|
||||
(let* ((new-packages
|
||||
(package-data-vhashes->new-packages base-packages-vhash
|
||||
target-packages-vhash))
|
||||
(removed-packages
|
||||
(package-data-vhashes->removed-packages base-packages-vhash
|
||||
target-packages-vhash))
|
||||
(version-changes
|
||||
(package-data-version-changes base-packages-vhash
|
||||
target-packages-vhash))
|
||||
(channel-news-data
|
||||
(parallel-via-thread-pool-channel
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(channel-news-differences-data conn
|
||||
base-revision-id
|
||||
target-revision-id))))))
|
||||
(case (most-appropriate-mime-type
|
||||
'(application/json text/html)
|
||||
mime-types)
|
||||
((application/json)
|
||||
(render-json
|
||||
`((revisions
|
||||
. ((base
|
||||
. ((commit . ,(second base-revision-details))
|
||||
(datetime . ,(fifth base-revision-details))))
|
||||
(target
|
||||
. ((commit . ,(second target-revision-details))
|
||||
(datetime . ,(fifth target-revision-details))))))
|
||||
(channel-news . ,(list->vector
|
||||
(map
|
||||
(match-lambda
|
||||
((commit tag title_text body_text change)
|
||||
`(,@(if (null? commit)
|
||||
'()
|
||||
`((commit . ,commit)))
|
||||
,@(if (null? tag)
|
||||
'()
|
||||
`((tag . ,tag)))
|
||||
(title-text
|
||||
. ,(map
|
||||
(match-lambda
|
||||
((lang . text)
|
||||
(cons
|
||||
lang
|
||||
(texinfo->variants-alist text))))
|
||||
title_text))
|
||||
(body-text
|
||||
. ,(map
|
||||
(match-lambda
|
||||
((lang . text)
|
||||
(cons
|
||||
lang
|
||||
(texinfo->variants-alist text))))
|
||||
body_text))
|
||||
(change . ,change))))
|
||||
channel-news-data)))
|
||||
(new-packages . ,(list->vector new-packages))
|
||||
(removed-packages . ,(list->vector removed-packages))
|
||||
(version-changes . ,(list->vector
|
||||
(map
|
||||
(match-lambda
|
||||
((name data ...)
|
||||
`((name . ,name)
|
||||
,@data)))
|
||||
version-changes))))
|
||||
#:extra-headers http-headers-for-unchanging-content))
|
||||
(else
|
||||
(render-html
|
||||
#:sxml (compare `(,@query-parameters
|
||||
(base_commit . ,(second base-revision-details))
|
||||
(target_commit . ,(second target-revision-details)))
|
||||
(parallel-via-thread-pool-channel
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(guix-revisions-cgit-url-bases
|
||||
conn
|
||||
(list base-revision-id
|
||||
target-revision-id)))))
|
||||
new-packages
|
||||
removed-packages
|
||||
version-changes
|
||||
(parallel-via-thread-pool-channel
|
||||
(group-list-by-first-n-fields
|
||||
2
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(lint-warning-differences-data
|
||||
conn
|
||||
base-revision-id
|
||||
target-revision-id
|
||||
locale)))))
|
||||
lint-warnings-locale-options
|
||||
channel-news-data)
|
||||
#:extra-headers http-headers-for-unchanging-content)))))))))))
|
||||
|
||||
(define (render-compare/derivation mime-types
|
||||
conn
|
||||
query-parameters)
|
||||
(if (any-invalid-query-parameters? query-parameters)
|
||||
(case (most-appropriate-mime-type
|
||||
|
|
@ -427,10 +479,12 @@
|
|||
|
||||
(let ((base-derivation (assq-ref query-parameters 'base_derivation))
|
||||
(target-derivation (assq-ref query-parameters 'target_derivation)))
|
||||
(let ((data
|
||||
(derivation-differences-data conn
|
||||
base-derivation
|
||||
target-derivation)))
|
||||
(letpar& ((data
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(derivation-differences-data conn
|
||||
base-derivation
|
||||
target-derivation)))))
|
||||
(case (most-appropriate-mime-type
|
||||
'(application/json text/html)
|
||||
mime-types)
|
||||
|
|
@ -446,7 +500,6 @@
|
|||
#:extra-headers http-headers-for-unchanging-content)))))))
|
||||
|
||||
(define (render-compare/derivations mime-types
|
||||
conn
|
||||
query-parameters)
|
||||
(define (derivations->alist derivations)
|
||||
(map (match-lambda
|
||||
|
|
@ -470,7 +523,8 @@
|
|||
(render-html
|
||||
#:sxml (compare/derivations
|
||||
query-parameters
|
||||
(valid-systems conn)
|
||||
(parallel-via-thread-pool-channel
|
||||
(with-thread-postgresql-connection valid-systems))
|
||||
build-status-strings
|
||||
'()))))
|
||||
|
||||
|
|
@ -479,41 +533,42 @@
|
|||
(systems (assq-ref query-parameters 'system))
|
||||
(targets (assq-ref query-parameters 'target))
|
||||
(build-statuses (assq-ref query-parameters 'build_status)))
|
||||
(let*
|
||||
((data
|
||||
(package-derivation-differences-data
|
||||
conn
|
||||
(commit->revision-id conn base-commit)
|
||||
(commit->revision-id conn target-commit)
|
||||
#:systems systems
|
||||
#:targets targets))
|
||||
(names-and-versions
|
||||
(package-derivation-data->names-and-versions data)))
|
||||
(let-values
|
||||
(((base-packages-vhash target-packages-vhash)
|
||||
(package-derivation-data->package-derivation-data-vhashes data)))
|
||||
(let ((derivation-changes
|
||||
(package-derivation-data-changes names-and-versions
|
||||
base-packages-vhash
|
||||
target-packages-vhash)))
|
||||
(case (most-appropriate-mime-type
|
||||
'(application/json text/html)
|
||||
mime-types)
|
||||
((application/json)
|
||||
(render-json
|
||||
derivation-changes
|
||||
#:extra-headers http-headers-for-unchanging-content))
|
||||
(else
|
||||
(render-html
|
||||
#:sxml (compare/derivations
|
||||
query-parameters
|
||||
(valid-systems conn)
|
||||
build-status-strings
|
||||
derivation-changes)
|
||||
#:extra-headers http-headers-for-unchanging-content)))))))))
|
||||
(letpar& ((data
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(package-derivation-differences-data
|
||||
conn
|
||||
(commit->revision-id conn base-commit)
|
||||
(commit->revision-id conn target-commit)
|
||||
#:systems systems
|
||||
#:targets targets)))))
|
||||
(let ((names-and-versions
|
||||
(package-derivation-data->names-and-versions data)))
|
||||
(let-values
|
||||
(((base-packages-vhash target-packages-vhash)
|
||||
(package-derivation-data->package-derivation-data-vhashes data)))
|
||||
(let ((derivation-changes
|
||||
(package-derivation-data-changes names-and-versions
|
||||
base-packages-vhash
|
||||
target-packages-vhash)))
|
||||
(case (most-appropriate-mime-type
|
||||
'(application/json text/html)
|
||||
mime-types)
|
||||
((application/json)
|
||||
(render-json
|
||||
derivation-changes
|
||||
#:extra-headers http-headers-for-unchanging-content))
|
||||
(else
|
||||
(render-html
|
||||
#:sxml (compare/derivations
|
||||
query-parameters
|
||||
(parallel-via-thread-pool-channel
|
||||
(with-thread-postgresql-connection valid-systems))
|
||||
build-status-strings
|
||||
derivation-changes)
|
||||
#:extra-headers http-headers-for-unchanging-content))))))))))
|
||||
|
||||
(define (render-compare-by-datetime/derivations mime-types
|
||||
conn
|
||||
query-parameters)
|
||||
(define (derivations->alist derivations)
|
||||
(map (match-lambda
|
||||
|
|
@ -537,7 +592,8 @@
|
|||
(render-html
|
||||
#:sxml (compare-by-datetime/derivations
|
||||
query-parameters
|
||||
(valid-systems conn)
|
||||
(parallel-via-thread-pool-channel
|
||||
(with-thread-postgresql-connection valid-systems))
|
||||
build-status-strings
|
||||
'()
|
||||
'()
|
||||
|
|
@ -550,50 +606,58 @@
|
|||
(systems (assq-ref query-parameters 'system))
|
||||
(targets (assq-ref query-parameters 'target))
|
||||
(build-statuses (assq-ref query-parameters 'build_status)))
|
||||
(let*
|
||||
(letpar&
|
||||
((base-revision-details
|
||||
(select-guix-revision-for-branch-and-datetime conn
|
||||
base-branch
|
||||
base-datetime))
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(select-guix-revision-for-branch-and-datetime conn
|
||||
base-branch
|
||||
base-datetime))))
|
||||
(target-revision-details
|
||||
(select-guix-revision-for-branch-and-datetime conn
|
||||
target-branch
|
||||
target-datetime))
|
||||
(data
|
||||
(package-derivation-differences-data conn
|
||||
(first base-revision-details)
|
||||
(first target-revision-details)
|
||||
#:systems systems
|
||||
#:targets targets))
|
||||
(names-and-versions
|
||||
(package-derivation-data->names-and-versions data)))
|
||||
(let-values
|
||||
(((base-packages-vhash target-packages-vhash)
|
||||
(package-derivation-data->package-derivation-data-vhashes data)))
|
||||
(let ((derivation-changes
|
||||
(package-derivation-data-changes names-and-versions
|
||||
base-packages-vhash
|
||||
target-packages-vhash)))
|
||||
(case (most-appropriate-mime-type
|
||||
'(application/json text/html)
|
||||
mime-types)
|
||||
((application/json)
|
||||
(render-json
|
||||
derivation-changes
|
||||
#:extra-headers http-headers-for-unchanging-content))
|
||||
(else
|
||||
(render-html
|
||||
#:sxml (compare-by-datetime/derivations
|
||||
query-parameters
|
||||
(valid-systems conn)
|
||||
build-status-strings
|
||||
base-revision-details
|
||||
target-revision-details
|
||||
derivation-changes)
|
||||
#:extra-headers http-headers-for-unchanging-content)))))))))
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(select-guix-revision-for-branch-and-datetime conn
|
||||
target-branch
|
||||
target-datetime)))))
|
||||
(letpar&
|
||||
((data
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(package-derivation-differences-data
|
||||
conn
|
||||
(first base-revision-details)
|
||||
(first target-revision-details)
|
||||
#:systems systems
|
||||
#:targets targets)))))
|
||||
(let ((names-and-versions
|
||||
(package-derivation-data->names-and-versions data)))
|
||||
(let-values
|
||||
(((base-packages-vhash target-packages-vhash)
|
||||
(package-derivation-data->package-derivation-data-vhashes data)))
|
||||
(let ((derivation-changes
|
||||
(package-derivation-data-changes names-and-versions
|
||||
base-packages-vhash
|
||||
target-packages-vhash)))
|
||||
(case (most-appropriate-mime-type
|
||||
'(application/json text/html)
|
||||
mime-types)
|
||||
((application/json)
|
||||
(render-json
|
||||
derivation-changes
|
||||
#:extra-headers http-headers-for-unchanging-content))
|
||||
(else
|
||||
(render-html
|
||||
#:sxml (compare-by-datetime/derivations
|
||||
query-parameters
|
||||
(parallel-via-thread-pool-channel
|
||||
(with-thread-postgresql-connection valid-systems))
|
||||
build-status-strings
|
||||
base-revision-details
|
||||
target-revision-details
|
||||
derivation-changes)
|
||||
#:extra-headers http-headers-for-unchanging-content)))))))))))
|
||||
|
||||
(define (render-compare/packages mime-types
|
||||
conn
|
||||
query-parameters)
|
||||
(define (package-data-vhash->json vh)
|
||||
(delete-duplicates
|
||||
|
|
@ -612,29 +676,49 @@
|
|||
(render-json
|
||||
'((error . "invalid query"))))
|
||||
(else
|
||||
(letpar& ((base-job
|
||||
(match (assq-ref query-parameters 'base_commit)
|
||||
(($ <invalid-query-parameter> value)
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(select-job-for-commit conn value))))
|
||||
(_ #f)))
|
||||
(target-job
|
||||
(match (assq-ref query-parameters 'target_commit)
|
||||
(($ <invalid-query-parameter> value)
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(select-job-for-commit conn value))))
|
||||
(_ #f))))
|
||||
(render-html
|
||||
#:sxml (compare-invalid-parameters
|
||||
query-parameters
|
||||
(match (assq-ref query-parameters 'base_commit)
|
||||
(($ <invalid-query-parameter> value)
|
||||
(select-job-for-commit conn value))
|
||||
(_ #f))
|
||||
(match (assq-ref query-parameters 'target_commit)
|
||||
(($ <invalid-query-parameter> value)
|
||||
(select-job-for-commit conn value))
|
||||
(_ #f))))))
|
||||
base-job
|
||||
target-job)))))
|
||||
|
||||
(let ((base-commit (assq-ref query-parameters 'base_commit))
|
||||
(target-commit (assq-ref query-parameters 'target_commit)))
|
||||
(let ((base-revision-id (commit->revision-id conn base-commit))
|
||||
(target-revision-id (commit->revision-id conn target-commit)))
|
||||
|
||||
(letpar& ((base-revision-id
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(commit->revision-id
|
||||
conn
|
||||
base-commit))))
|
||||
(target-revision-id
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(commit->revision-id
|
||||
conn
|
||||
target-commit)))))
|
||||
(let-values
|
||||
(((base-packages-vhash target-packages-vhash)
|
||||
(package-data->package-data-vhashes
|
||||
(package-differences-data conn
|
||||
base-revision-id
|
||||
target-revision-id))))
|
||||
(parallel-via-thread-pool-channel
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(package-differences-data conn
|
||||
base-revision-id
|
||||
target-revision-id)))))))
|
||||
(case (most-appropriate-mime-type
|
||||
'(application/json text/html)
|
||||
mime-types)
|
||||
|
|
|
|||
|
|
@ -19,6 +19,7 @@
|
|||
(define-module (guix-data-service web controller)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (ice-9 vlist)
|
||||
#:use-module (ice-9 threads)
|
||||
#:use-module (ice-9 pretty-print)
|
||||
#:use-module (ice-9 textual-ports)
|
||||
#:use-module (ice-9 string-fun)
|
||||
|
|
@ -35,6 +36,7 @@
|
|||
#:use-module (squee)
|
||||
#:use-module (json)
|
||||
#:use-module (prometheus)
|
||||
#:use-module (guix-data-service utils)
|
||||
#:use-module (guix-data-service config)
|
||||
#:use-module (guix-data-service comparison)
|
||||
#:use-module (guix-data-service database)
|
||||
|
|
@ -129,8 +131,20 @@
|
|||
"_"))
|
||||
#:labels '(name))))
|
||||
pg-stat-fields)))
|
||||
(lambda (conn)
|
||||
(let ((metric-values (fetch-high-level-table-size-metrics conn)))
|
||||
(lambda ()
|
||||
(letpar& ((metric-values
|
||||
(with-thread-postgresql-connection
|
||||
fetch-high-level-table-size-metrics))
|
||||
(guix-revisions-count
|
||||
(with-thread-postgresql-connection
|
||||
count-guix-revisions))
|
||||
(pg-stat-user-tables-metrics
|
||||
(with-thread-postgresql-connection
|
||||
fetch-pg-stat-user-tables-metrics))
|
||||
(load-new-guix-revision-job-metrics
|
||||
(with-thread-postgresql-connection
|
||||
select-load-new-guix-revision-job-metrics)))
|
||||
|
||||
(for-each (match-lambda
|
||||
((name row-estimate table-bytes index-bytes toast-bytes)
|
||||
|
||||
|
|
@ -146,54 +160,66 @@
|
|||
(metric-set table-toast-bytes-metric
|
||||
toast-bytes
|
||||
#:label-values `((name . ,name)))))
|
||||
metric-values))
|
||||
metric-values)
|
||||
|
||||
(metric-set revisions-count-metric
|
||||
(count-guix-revisions conn))
|
||||
(metric-set revisions-count-metric
|
||||
guix-revisions-count)
|
||||
|
||||
(map (lambda (field-values)
|
||||
(let ((name (assq-ref field-values 'name)))
|
||||
(for-each
|
||||
(match-lambda
|
||||
(('name . _) #f)
|
||||
((field . value)
|
||||
(let ((metric (or (assq-ref pg-stat-metrics field)
|
||||
(error field))))
|
||||
(metric-set metric
|
||||
value
|
||||
#:label-values `((name . ,name))))))
|
||||
field-values)))
|
||||
(fetch-pg-stat-user-tables-metrics conn))
|
||||
(map (lambda (field-values)
|
||||
(let ((name (assq-ref field-values 'name)))
|
||||
(for-each
|
||||
(match-lambda
|
||||
(('name . _) #f)
|
||||
((field . value)
|
||||
(let ((metric (or (assq-ref pg-stat-metrics field)
|
||||
(error field))))
|
||||
(metric-set metric
|
||||
value
|
||||
#:label-values `((name . ,name))))))
|
||||
field-values)))
|
||||
pg-stat-user-tables-metrics)
|
||||
|
||||
(for-each (match-lambda
|
||||
((repository-label completed count)
|
||||
(metric-set
|
||||
load-new-guix-revision-job-count
|
||||
count
|
||||
#:label-values
|
||||
`((repository_label . ,repository-label)
|
||||
(completed . ,(if completed "yes" "no"))))))
|
||||
(select-load-new-guix-revision-job-metrics conn))
|
||||
(for-each (match-lambda
|
||||
((repository-label completed count)
|
||||
(metric-set
|
||||
load-new-guix-revision-job-count
|
||||
count
|
||||
#:label-values
|
||||
`((repository_label . ,repository-label)
|
||||
(completed . ,(if completed "yes" "no"))))))
|
||||
load-new-guix-revision-job-metrics)
|
||||
|
||||
(list (build-response
|
||||
#:code 200
|
||||
#:headers '((content-type . (text/plain))))
|
||||
(lambda (port)
|
||||
(write-metrics registry port))))))
|
||||
(list (build-response
|
||||
#:code 200
|
||||
#:headers '((content-type . (text/plain))))
|
||||
(lambda (port)
|
||||
(write-metrics registry port)))))))
|
||||
|
||||
(define (render-derivation derivation-file-name)
|
||||
(letpar& ((derivation
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(select-derivation-by-file-name conn derivation-file-name)))))
|
||||
|
||||
(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
|
||||
conn
|
||||
(first derivation)))
|
||||
(derivation-outputs (select-derivation-outputs-by-derivation-id
|
||||
conn
|
||||
(first derivation)))
|
||||
(builds (select-builds-with-context-by-derivation-file-name
|
||||
(letpar& ((derivation-inputs
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(select-derivation-inputs-by-derivation-id
|
||||
conn
|
||||
(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
|
||||
#:sxml (view-derivation derivation
|
||||
derivation-inputs
|
||||
|
|
@ -207,19 +233,32 @@
|
|||
"No derivation found with this file name.")
|
||||
#:code 404))))
|
||||
|
||||
(define (render-json-derivation conn derivation-file-name)
|
||||
(let ((derivation (select-derivation-by-file-name conn
|
||||
derivation-file-name)))
|
||||
(if derivation
|
||||
(let ((derivation-inputs (select-derivation-inputs-by-derivation-id
|
||||
conn
|
||||
(first derivation)))
|
||||
(derivation-outputs (select-derivation-outputs-by-derivation-id
|
||||
conn
|
||||
(first derivation)))
|
||||
(derivation-sources (select-derivation-sources-by-derivation-id
|
||||
conn
|
||||
(first derivation))))
|
||||
(define (render-json-derivation derivation-file-name)
|
||||
(let ((derivation
|
||||
(parallel-via-thread-pool-channel
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(select-derivation-by-file-name conn
|
||||
derivation-file-name))))))
|
||||
(if derivation
|
||||
(letpar& ((derivation-inputs
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(select-derivation-inputs-by-derivation-id
|
||||
conn
|
||||
(first derivation)))))
|
||||
(derivation-outputs
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(select-derivation-outputs-by-derivation-id
|
||||
conn
|
||||
(first derivation)))))
|
||||
(derivation-sources
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(select-derivation-sources-by-derivation-id
|
||||
conn
|
||||
(first derivation))))))
|
||||
(render-json
|
||||
`((inputs . ,(list->vector
|
||||
(map
|
||||
|
|
@ -255,19 +294,35 @@
|
|||
env-var))))))))
|
||||
(render-json '((error . "invalid path"))))))
|
||||
|
||||
(define (render-formatted-derivation conn derivation-file-name)
|
||||
(let ((derivation (select-derivation-by-file-name conn
|
||||
derivation-file-name)))
|
||||
(define (render-formatted-derivation derivation-file-name)
|
||||
(let ((derivation
|
||||
(parallel-via-thread-pool-channel
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(select-derivation-by-file-name conn
|
||||
derivation-file-name))))))
|
||||
(if derivation
|
||||
(let ((derivation-inputs (select-derivation-inputs-by-derivation-id
|
||||
conn
|
||||
(first derivation)))
|
||||
(derivation-outputs (select-derivation-outputs-by-derivation-id
|
||||
conn
|
||||
(first derivation)))
|
||||
(derivation-sources (select-derivation-sources-by-derivation-id
|
||||
conn
|
||||
(first derivation))))
|
||||
(letpar& ((derivation-inputs
|
||||
(parallel-via-thread-pool-channel
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(select-derivation-inputs-by-derivation-id
|
||||
conn
|
||||
(first derivation))))))
|
||||
(derivation-outputs
|
||||
(parallel-via-thread-pool-channel
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(select-derivation-outputs-by-derivation-id
|
||||
conn
|
||||
(first derivation))))))
|
||||
(derivation-sources
|
||||
(parallel-via-thread-pool-channel
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(select-derivation-sources-by-derivation-id
|
||||
conn
|
||||
(first derivation)))))))
|
||||
(render-html
|
||||
#:sxml (view-formatted-derivation derivation
|
||||
derivation-inputs
|
||||
|
|
@ -281,10 +336,14 @@
|
|||
"No derivation found with this file name.")
|
||||
#:code 404))))
|
||||
|
||||
(define (render-narinfos conn filename)
|
||||
(let ((narinfos (select-nars-for-output
|
||||
conn
|
||||
(string-append "/gnu/store/" filename))))
|
||||
(define (render-narinfos filename)
|
||||
(let ((narinfos
|
||||
(parallel-via-thread-pool-channel
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(select-nars-for-output
|
||||
conn
|
||||
(string-append "/gnu/store/" filename)))))))
|
||||
(if (null? narinfos)
|
||||
(render-html
|
||||
#:sxml (general-not-found
|
||||
|
|
@ -295,11 +354,17 @@
|
|||
(render-html
|
||||
#:sxml (view-narinfos narinfos)))))
|
||||
|
||||
(define (render-store-item conn filename)
|
||||
(let ((derivation (select-derivation-by-output-filename conn filename)))
|
||||
(define (render-store-item filename)
|
||||
(letpar& ((derivation
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(select-derivation-by-output-filename conn filename)))))
|
||||
(match derivation
|
||||
(()
|
||||
(match (select-derivation-source-file-by-store-path conn filename)
|
||||
(match (parallel-via-thread-pool-channel
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(select-derivation-source-file-by-store-path conn filename))))
|
||||
(()
|
||||
(render-html
|
||||
#:sxml (general-not-found
|
||||
|
|
@ -310,29 +375,52 @@
|
|||
(render-html
|
||||
#:sxml (view-derivation-source-file
|
||||
filename
|
||||
(select-derivation-source-file-nar-details-by-file-name conn
|
||||
filename))
|
||||
(parallel-via-thread-pool-channel
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(select-derivation-source-file-nar-details-by-file-name
|
||||
conn
|
||||
filename)))))
|
||||
#:extra-headers http-headers-for-unchanging-content))))
|
||||
(derivations
|
||||
(render-html
|
||||
#:sxml (view-store-item filename
|
||||
derivations
|
||||
(map (lambda (derivation)
|
||||
(match derivation
|
||||
((file-name output-id rest ...)
|
||||
(select-derivations-using-output
|
||||
conn output-id))))
|
||||
derivations)
|
||||
(select-nars-for-output conn
|
||||
filename)
|
||||
(select-builds-with-context-by-derivation-output
|
||||
conn filename)))))))
|
||||
(letpar& ((derivations-using-store-item-list
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(map (lambda (derivation)
|
||||
(match derivation
|
||||
((file-name output-id rest ...)
|
||||
(select-derivations-using-output
|
||||
conn output-id))))
|
||||
derivations))))
|
||||
(nars
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(select-nars-for-output conn filename))))
|
||||
(builds
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(select-builds-with-context-by-derivation-output
|
||||
conn
|
||||
filename)))))
|
||||
(render-html
|
||||
#:sxml (view-store-item filename
|
||||
derivations
|
||||
derivations-using-store-item-list
|
||||
nars
|
||||
builds)))))))
|
||||
|
||||
(define (render-json-store-item 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,43 +431,54 @@
|
|||
(match-lambda
|
||||
((key . value)
|
||||
`((,key . ,value))))
|
||||
(select-derivation-source-file-nar-details-by-file-name
|
||||
conn
|
||||
filename)))))))))
|
||||
(parallel-via-thread-pool-channel
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(select-derivation-source-file-nar-details-by-file-name
|
||||
conn
|
||||
filename))))))))))))
|
||||
(derivations
|
||||
(render-json
|
||||
`((nars . ,(list->vector
|
||||
(map
|
||||
(match-lambda
|
||||
((_ hash _ urls signatures)
|
||||
`((hash . ,hash)
|
||||
(urls
|
||||
. ,(list->vector
|
||||
(map
|
||||
(lambda (url-data)
|
||||
`((size . ,(assoc-ref url-data "size"))
|
||||
(compression . ,(assoc-ref url-data "compression"))
|
||||
(url . ,(assoc-ref url-data "url"))))
|
||||
urls)))
|
||||
(signatures
|
||||
. ,(list->vector
|
||||
(map
|
||||
(lambda (signature)
|
||||
`((version . ,(assoc-ref signature "version"))
|
||||
(host-name . ,(assoc-ref signature "host_name"))))
|
||||
signatures))))))
|
||||
(select-nars-for-output conn filename))))
|
||||
(derivations
|
||||
. ,(list->vector
|
||||
(map
|
||||
(match-lambda
|
||||
((filename output-id)
|
||||
`((filename . ,filename)
|
||||
(derivations-using-store-item
|
||||
. ,(list->vector
|
||||
(map car (select-derivations-using-output
|
||||
conn output-id)))))))
|
||||
derivations)))))))))
|
||||
(letpar& ((nars
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(select-nars-for-output conn filename)))))
|
||||
(render-json
|
||||
`((nars . ,(list->vector
|
||||
(map
|
||||
(match-lambda
|
||||
((_ hash _ urls signatures)
|
||||
`((hash . ,hash)
|
||||
(urls
|
||||
. ,(list->vector
|
||||
(map
|
||||
(lambda (url-data)
|
||||
`((size . ,(assoc-ref url-data "size"))
|
||||
(compression . ,(assoc-ref url-data "compression"))
|
||||
(url . ,(assoc-ref url-data "url"))))
|
||||
urls)))
|
||||
(signatures
|
||||
. ,(list->vector
|
||||
(map
|
||||
(lambda (signature)
|
||||
`((version . ,(assoc-ref signature "version"))
|
||||
(host-name . ,(assoc-ref signature "host_name"))))
|
||||
signatures))))))
|
||||
nars)))
|
||||
(derivations
|
||||
. ,(list->vector
|
||||
(map
|
||||
(match-lambda
|
||||
((filename output-id)
|
||||
`((filename . ,filename)
|
||||
(derivations-using-store-item
|
||||
. ,(list->vector
|
||||
(map car
|
||||
(parallel-via-thread-pool-channel
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(select-derivations-using-output
|
||||
conn output-id))))))))))
|
||||
derivations))))))))))
|
||||
|
||||
(define handle-static-assets
|
||||
(if assets-dir-in-store?
|
||||
|
|
@ -393,50 +492,12 @@
|
|||
mime-types body
|
||||
secret-key-base)
|
||||
(define (controller-thunk)
|
||||
(match method-and-path-components
|
||||
(('GET "assets" rest ...)
|
||||
(or (handle-static-assets (string-join rest "/")
|
||||
(request-headers request))
|
||||
(not-found (request-uri request))))
|
||||
(('GET "healthcheck")
|
||||
(let ((database-status
|
||||
(catch
|
||||
#t
|
||||
(lambda ()
|
||||
(with-postgresql-connection
|
||||
"web healthcheck"
|
||||
(lambda (conn)
|
||||
(number? (count-guix-revisions conn)))))
|
||||
(lambda (key . args)
|
||||
#f))))
|
||||
(render-json
|
||||
`((status . ,(if database-status
|
||||
"ok"
|
||||
"not ok")))
|
||||
#:code (if (eq? database-status
|
||||
#t)
|
||||
200
|
||||
500))))
|
||||
(('GET "README")
|
||||
(let ((filename (string-append (%config 'doc-dir) "/README.html")))
|
||||
(if (file-exists? filename)
|
||||
(render-html
|
||||
#:sxml (readme (call-with-input-file filename
|
||||
get-string-all)))
|
||||
(render-html
|
||||
#:sxml (general-not-found
|
||||
"README not found"
|
||||
"The README.html file does not exist")
|
||||
#:code 404))))
|
||||
(_
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(controller-with-database-connection request
|
||||
method-and-path-components
|
||||
mime-types
|
||||
body
|
||||
conn
|
||||
secret-key-base))))))
|
||||
(actual-controller request
|
||||
method-and-path-components
|
||||
mime-types
|
||||
body
|
||||
secret-key-base))
|
||||
|
||||
(call-with-error-handling
|
||||
controller-thunk
|
||||
#:on-error 'backtrace
|
||||
|
|
@ -447,12 +508,11 @@
|
|||
#f))
|
||||
#:code 500))))
|
||||
|
||||
(define (controller-with-database-connection request
|
||||
method-and-path-components
|
||||
mime-types
|
||||
body
|
||||
conn
|
||||
secret-key-base)
|
||||
(define (actual-controller request
|
||||
method-and-path-components
|
||||
mime-types
|
||||
body
|
||||
secret-key-base)
|
||||
(define path
|
||||
(uri-path (request-uri request)))
|
||||
|
||||
|
|
@ -460,8 +520,7 @@
|
|||
(or (f request
|
||||
method-and-path-components
|
||||
mime-types
|
||||
body
|
||||
conn)
|
||||
body)
|
||||
(render-html
|
||||
#:sxml (general-not-found
|
||||
"Page not found"
|
||||
|
|
@ -473,7 +532,6 @@
|
|||
method-and-path-components
|
||||
mime-types
|
||||
body
|
||||
conn
|
||||
secret-key-base)
|
||||
(render-html
|
||||
#:sxml (general-not-found
|
||||
|
|
@ -485,21 +543,63 @@
|
|||
(('GET)
|
||||
(render-html
|
||||
#:sxml (index
|
||||
(map
|
||||
(lambda (git-repository-details)
|
||||
(cons
|
||||
git-repository-details
|
||||
(all-branches-with-most-recent-commit
|
||||
conn (first git-repository-details))))
|
||||
(all-git-repositories conn)))))
|
||||
(parallel-via-thread-pool-channel
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(map
|
||||
(lambda (git-repository-details)
|
||||
(cons
|
||||
git-repository-details
|
||||
(all-branches-with-most-recent-commit
|
||||
conn (first git-repository-details))))
|
||||
(all-git-repositories conn))))))))
|
||||
(('GET "assets" rest ...)
|
||||
(or (handle-static-assets (string-join rest "/")
|
||||
(request-headers request))
|
||||
(not-found (request-uri request))))
|
||||
(('GET "healthcheck")
|
||||
(let ((database-status
|
||||
(catch
|
||||
#t
|
||||
(lambda ()
|
||||
(with-postgresql-connection
|
||||
"web healthcheck"
|
||||
(lambda (conn)
|
||||
(number? (count-guix-revisions conn)))))
|
||||
(lambda (key . args)
|
||||
#f))))
|
||||
(render-json
|
||||
`((status . ,(if database-status
|
||||
"ok"
|
||||
"not ok")))
|
||||
#:code (if (eq? database-status
|
||||
#t)
|
||||
200
|
||||
500))))
|
||||
(('GET "README")
|
||||
(let ((filename (string-append (%config 'doc-dir) "/README.html")))
|
||||
(if (file-exists? filename)
|
||||
(render-html
|
||||
#:sxml (readme (call-with-input-file filename
|
||||
get-string-all)))
|
||||
(render-html
|
||||
#:sxml (general-not-found
|
||||
"README not found"
|
||||
"The README.html file does not exist")
|
||||
#:code 404))))
|
||||
(('GET "builds")
|
||||
(delegate-to build-controller))
|
||||
(('GET "statistics")
|
||||
(render-html
|
||||
#:sxml (view-statistics (count-guix-revisions conn)
|
||||
(count-derivations conn))))
|
||||
(letpar& ((guix-revisions-count
|
||||
(with-thread-postgresql-connection count-guix-revisions))
|
||||
(count-derivations
|
||||
(with-thread-postgresql-connection count-derivations)))
|
||||
|
||||
(render-html
|
||||
#:sxml (view-statistics guix-revisions-count
|
||||
count-derivations))))
|
||||
(('GET "metrics")
|
||||
(render-metrics conn))
|
||||
(render-metrics))
|
||||
(('GET "revision" args ...)
|
||||
(delegate-to revision-controller))
|
||||
(('GET "repositories")
|
||||
|
|
@ -511,12 +611,11 @@
|
|||
;; content negotiation, so just use the path from the request
|
||||
(let ((path (uri-path (request-uri request))))
|
||||
(if (string-suffix? ".drv" path)
|
||||
(render-derivation conn path)
|
||||
(render-store-item conn path))))
|
||||
(render-derivation path)
|
||||
(render-store-item path))))
|
||||
(('GET "gnu" "store" filename "formatted")
|
||||
(if (string-suffix? ".drv" filename)
|
||||
(render-formatted-derivation conn
|
||||
(string-append "/gnu/store/" filename))
|
||||
(render-formatted-derivation (string-append "/gnu/store/" filename))
|
||||
(render-html
|
||||
#:sxml (general-not-found
|
||||
"Not a derivation"
|
||||
|
|
@ -525,20 +624,22 @@
|
|||
(('GET "gnu" "store" filename "plain")
|
||||
(if (string-suffix? ".drv" filename)
|
||||
(let ((raw-drv
|
||||
(select-serialized-derivation-by-file-name
|
||||
conn
|
||||
(string-append "/gnu/store/" filename))))
|
||||
(parallel-via-thread-pool-channel
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(select-serialized-derivation-by-file-name
|
||||
conn
|
||||
(string-append "/gnu/store/" filename)))))))
|
||||
(if raw-drv
|
||||
(render-text raw-drv)
|
||||
(not-found (request-uri request))))
|
||||
(not-found (request-uri request))))
|
||||
(('GET "gnu" "store" filename "narinfos")
|
||||
(render-narinfos conn filename))
|
||||
(render-narinfos filename))
|
||||
(('GET "gnu" "store" filename "json")
|
||||
(if (string-suffix? ".drv" filename)
|
||||
(render-json-derivation conn
|
||||
(string-append "/gnu/store/" filename))
|
||||
(render-json-store-item conn (string-append "/gnu/store/" filename))))
|
||||
(render-json-derivation (string-append "/gnu/store/" filename))
|
||||
(render-json-store-item (string-append "/gnu/store/" filename))))
|
||||
(('GET "build-servers")
|
||||
(delegate-to-with-secret-key-base build-server-controller))
|
||||
(('GET "dumps" _ ...)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -17,6 +17,8 @@
|
|||
|
||||
(define-module (guix-data-service web jobs controller)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (guix-data-service utils)
|
||||
#:use-module (guix-data-service database)
|
||||
#:use-module (guix-data-service web render)
|
||||
#:use-module (guix-data-service web query-parameters)
|
||||
#:use-module (guix-data-service web util)
|
||||
|
|
@ -27,8 +29,7 @@
|
|||
(define (jobs-controller request
|
||||
method-and-path-components
|
||||
mime-types
|
||||
body
|
||||
conn)
|
||||
body)
|
||||
(match method-and-path-components
|
||||
(('GET "jobs")
|
||||
(let ((parsed-query-parameters
|
||||
|
|
@ -42,7 +43,6 @@
|
|||
(all_results ,parse-checkbox-value)))
|
||||
'((limit_results all_results)))))
|
||||
(render-jobs mime-types
|
||||
conn
|
||||
parsed-query-parameters)))
|
||||
(('GET "jobs" "events")
|
||||
(let ((parsed-query-parameters
|
||||
|
|
@ -55,11 +55,9 @@
|
|||
(all_results ,parse-checkbox-value)))
|
||||
'((limit_results all_results)))))
|
||||
(render-job-events mime-types
|
||||
conn
|
||||
parsed-query-parameters)))
|
||||
(('GET "jobs" "queue")
|
||||
(render-job-queue mime-types
|
||||
conn))
|
||||
(render-job-queue mime-types))
|
||||
(('GET "job" job-id)
|
||||
(let ((parsed-query-parameters
|
||||
(parse-query-parameters
|
||||
|
|
@ -67,19 +65,23 @@
|
|||
`((start_character ,parse-number)
|
||||
(characters ,parse-number #:default 10000000)))))
|
||||
(render-job mime-types
|
||||
conn
|
||||
job-id
|
||||
parsed-query-parameters)))
|
||||
(_ #f)))
|
||||
|
||||
(define (render-jobs mime-types conn query-parameters)
|
||||
(let* ((limit-results
|
||||
(assq-ref query-parameters 'limit_results))
|
||||
(jobs (select-jobs-and-events
|
||||
conn
|
||||
(assq-ref query-parameters 'before_id)
|
||||
limit-results))
|
||||
(recent-events (select-recent-job-events conn)))
|
||||
(define (render-jobs mime-types query-parameters)
|
||||
(define limit-results (assq-ref query-parameters 'limit_results))
|
||||
|
||||
(letpar& ((jobs
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(select-jobs-and-events
|
||||
conn
|
||||
(assq-ref query-parameters 'before_id)
|
||||
limit-results))))
|
||||
(recent-events
|
||||
(with-thread-postgresql-connection
|
||||
select-recent-job-events)))
|
||||
(case (most-appropriate-mime-type
|
||||
'(application/json text/html)
|
||||
mime-types)
|
||||
|
|
@ -113,29 +115,36 @@
|
|||
(>= (length jobs)
|
||||
limit-results))))))))
|
||||
|
||||
(define (render-job-events mime-types conn query-parameters)
|
||||
(let* ((limit-results
|
||||
(assq-ref query-parameters 'limit_results))
|
||||
(recent-events (select-recent-job-events
|
||||
conn
|
||||
;; TODO Ideally there wouldn't be a limit
|
||||
#:limit (or limit-results 1000000))))
|
||||
(define (render-job-events mime-types query-parameters)
|
||||
(letpar& ((recent-events
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(select-recent-job-events
|
||||
conn
|
||||
;; TODO Ideally there wouldn't be a limit
|
||||
#:limit (or (assq-ref query-parameters 'limit_results)
|
||||
1000000))))))
|
||||
(render-html
|
||||
#:sxml (view-job-events
|
||||
query-parameters
|
||||
recent-events))))
|
||||
|
||||
(define (render-job-queue mime-types conn)
|
||||
(define (render-job-queue mime-types)
|
||||
(render-html
|
||||
#:sxml (view-job-queue
|
||||
(select-unprocessed-jobs-and-events conn))))
|
||||
(parallel-via-thread-pool-channel
|
||||
(with-thread-postgresql-connection
|
||||
select-unprocessed-jobs-and-events)))))
|
||||
|
||||
(define (render-job mime-types conn job-id query-parameters)
|
||||
(let ((log-text (log-for-job conn job-id
|
||||
#:character-limit
|
||||
(assq-ref query-parameters 'characters)
|
||||
#:start-character
|
||||
(assq-ref query-parameters 'start_character))))
|
||||
(define (render-job mime-types job-id query-parameters)
|
||||
(letpar& ((log-text
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(log-for-job conn job-id
|
||||
#:character-limit
|
||||
(assq-ref query-parameters 'characters)
|
||||
#:start-character
|
||||
(assq-ref query-parameters 'start_character))))))
|
||||
(case (most-appropriate-mime-type
|
||||
'(text/plain text/html)
|
||||
mime-types)
|
||||
|
|
|
|||
|
|
@ -31,6 +31,8 @@
|
|||
#:use-module (guix base32)
|
||||
#:use-module (guix base64)
|
||||
#:use-module (guix serialization)
|
||||
#:use-module (guix-data-service utils)
|
||||
#:use-module (guix-data-service database)
|
||||
#:use-module (guix-data-service web render)
|
||||
#:use-module (guix-data-service web nar html)
|
||||
#:use-module (guix-data-service model derivation)
|
||||
|
|
@ -54,8 +56,7 @@
|
|||
(define (nar-controller request
|
||||
method-and-path-components
|
||||
mime-types
|
||||
body
|
||||
conn)
|
||||
body)
|
||||
(define (.narinfo-suffix s)
|
||||
(string-suffix? ".narinfo" s))
|
||||
|
||||
|
|
@ -78,7 +79,6 @@
|
|||
(uri-decode (last (string-split path #\/)))))
|
||||
(render-nar request
|
||||
mime-types
|
||||
conn
|
||||
(string-append "/gnu/store/" file-name))))
|
||||
(('GET "nar" "lzip" _)
|
||||
;; These routes are a little special, as the extensions aren't used for
|
||||
|
|
@ -88,22 +88,22 @@
|
|||
(uri-decode (last (string-split path #\/)))))
|
||||
(render-lzip-nar request
|
||||
mime-types
|
||||
conn
|
||||
(string-append "/gnu/store/" file-name))))
|
||||
(('GET (? .narinfo-suffix path))
|
||||
(render-narinfo request
|
||||
conn
|
||||
(string-drop-right path
|
||||
(string-length ".narinfo"))))
|
||||
(_ #f)))
|
||||
|
||||
(define (render-nar request
|
||||
mime-types
|
||||
conn
|
||||
file-name)
|
||||
(or
|
||||
(and=> (select-serialized-derivation-by-file-name conn
|
||||
file-name)
|
||||
(and=> (parallel-via-thread-pool-channel
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(select-serialized-derivation-by-file-name conn
|
||||
file-name))))
|
||||
(lambda (derivation-text)
|
||||
(let ((derivation-bytevector
|
||||
(string->bytevector derivation-text
|
||||
|
|
@ -127,10 +127,13 @@
|
|||
|
||||
(define (render-lzip-nar request
|
||||
mime-types
|
||||
conn
|
||||
file-name)
|
||||
(or
|
||||
(and=> (select-derivation-source-file-nar-data-by-file-name conn file-name)
|
||||
(and=> (parallel-via-thread-pool-channel
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(select-derivation-source-file-nar-data-by-file-name conn
|
||||
file-name))))
|
||||
(lambda (data)
|
||||
(list (build-response
|
||||
#:code 200
|
||||
|
|
@ -141,51 +144,60 @@
|
|||
(not-found (request-uri request))))
|
||||
|
||||
(define (render-narinfo request
|
||||
conn
|
||||
hash)
|
||||
(or
|
||||
(and=> (select-derivation-by-file-name-hash conn
|
||||
hash)
|
||||
(and=> (parallel-via-thread-pool-channel
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(select-derivation-by-file-name-hash conn
|
||||
hash))))
|
||||
(lambda (derivation)
|
||||
(list (build-response
|
||||
#:code 200
|
||||
#:headers '((content-type . (application/x-narinfo))))
|
||||
(let* ((derivation-file-name
|
||||
(second derivation))
|
||||
(derivation-text
|
||||
(select-serialized-derivation-by-file-name
|
||||
conn
|
||||
derivation-file-name))
|
||||
(derivation-bytevector
|
||||
(string->bytevector derivation-text
|
||||
"ISO-8859-1"))
|
||||
(let ((derivation-file-name (second derivation)))
|
||||
(letpar&
|
||||
((derivation-text
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(select-serialized-derivation-by-file-name
|
||||
conn
|
||||
derivation-file-name))))
|
||||
(derivation-references
|
||||
(select-derivation-references-by-derivation-id
|
||||
conn
|
||||
(first derivation)))
|
||||
(nar-bytevector
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(open-bytevector-output-port))
|
||||
(lambda (port get-bytevector)
|
||||
(write-file-tree
|
||||
derivation-file-name
|
||||
port
|
||||
#:file-type+size
|
||||
(lambda (file)
|
||||
(values 'regular
|
||||
(bytevector-length derivation-bytevector)))
|
||||
#:file-port
|
||||
(lambda (file)
|
||||
(open-bytevector-input-port derivation-bytevector)))
|
||||
(get-bytevector)))))
|
||||
(lambda (port)
|
||||
(display (narinfo-string derivation-file-name
|
||||
nar-bytevector
|
||||
derivation-references)
|
||||
port))))))
|
||||
(and=> (select-derivation-source-file-data-by-file-name-hash conn
|
||||
hash)
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(select-derivation-references-by-derivation-id
|
||||
conn
|
||||
(first derivation))))))
|
||||
(let* ((derivation-bytevector
|
||||
(string->bytevector derivation-text
|
||||
"ISO-8859-1"))
|
||||
(nar-bytevector
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(open-bytevector-output-port))
|
||||
(lambda (port get-bytevector)
|
||||
(write-file-tree
|
||||
derivation-file-name
|
||||
port
|
||||
#:file-type+size
|
||||
(lambda (file)
|
||||
(values 'regular
|
||||
(bytevector-length derivation-bytevector)))
|
||||
#:file-port
|
||||
(lambda (file)
|
||||
(open-bytevector-input-port derivation-bytevector)))
|
||||
(get-bytevector)))))
|
||||
(lambda (port)
|
||||
(display (narinfo-string derivation-file-name
|
||||
nar-bytevector
|
||||
derivation-references)
|
||||
port))))))))
|
||||
(and=> (parallel-via-thread-pool-channel
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(select-derivation-source-file-data-by-file-name-hash conn
|
||||
hash))))
|
||||
(match-lambda
|
||||
((store-path compression compressed-size
|
||||
hash-algorithm hash uncompressed-size)
|
||||
|
|
|
|||
|
|
@ -19,6 +19,8 @@
|
|||
#:use-module (ice-9 match)
|
||||
#:use-module (web uri)
|
||||
#:use-module (web request)
|
||||
#:use-module (guix-data-service utils)
|
||||
#:use-module (guix-data-service database)
|
||||
#:use-module (guix-data-service web render)
|
||||
#:use-module (guix-data-service web query-parameters)
|
||||
#:use-module (guix-data-service web util)
|
||||
|
|
@ -36,14 +38,15 @@
|
|||
(define (repository-controller request
|
||||
method-and-path-components
|
||||
mime-types
|
||||
body
|
||||
conn)
|
||||
body)
|
||||
(define path
|
||||
(uri-path (request-uri request)))
|
||||
|
||||
(match method-and-path-components
|
||||
(('GET "repositories")
|
||||
(let ((git-repositories (all-git-repositories conn)))
|
||||
(letpar& ((git-repositories
|
||||
(with-thread-postgresql-connection
|
||||
all-git-repositories)))
|
||||
(case (most-appropriate-mime-type
|
||||
'(application/json text/html)
|
||||
mime-types)
|
||||
|
|
@ -62,11 +65,17 @@
|
|||
#:sxml
|
||||
(view-git-repositories git-repositories))))))
|
||||
(('GET "repository" id)
|
||||
(match (select-git-repository conn id)
|
||||
(match (parallel-via-thread-pool-channel
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(select-git-repository conn id))))
|
||||
((label url cgit-url-base)
|
||||
(let ((branches
|
||||
(all-branches-with-most-recent-commit conn
|
||||
(string->number id))))
|
||||
(letpar& ((branches
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(all-branches-with-most-recent-commit
|
||||
conn
|
||||
(string->number id))))))
|
||||
(case (most-appropriate-mime-type
|
||||
'(application/json text/html)
|
||||
mime-types)
|
||||
|
|
@ -110,16 +119,18 @@
|
|||
`((after_date ,parse-datetime)
|
||||
(before_date ,parse-datetime)
|
||||
(limit_results ,parse-result-limit #:default 100)))))
|
||||
(let ((revisions
|
||||
(most-recent-commits-for-branch
|
||||
conn
|
||||
(string->number repository-id)
|
||||
branch-name
|
||||
#:limit (assq-ref parsed-query-parameters 'limit_results)
|
||||
#:after-date (assq-ref parsed-query-parameters
|
||||
'after_date)
|
||||
#:before-date (assq-ref parsed-query-parameters
|
||||
'before_date))))
|
||||
(letpar& ((revisions
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(most-recent-commits-for-branch
|
||||
conn
|
||||
(string->number repository-id)
|
||||
branch-name
|
||||
#:limit (assq-ref parsed-query-parameters 'limit_results)
|
||||
#:after-date (assq-ref parsed-query-parameters
|
||||
'after_date)
|
||||
#:before-date (assq-ref parsed-query-parameters
|
||||
'before_date))))))
|
||||
(case (most-appropriate-mime-type
|
||||
'(application/json text/html)
|
||||
mime-types)
|
||||
|
|
@ -144,11 +155,13 @@
|
|||
parsed-query-parameters
|
||||
revisions))))))))
|
||||
(('GET "repository" repository-id "branch" branch-name "package" package-name)
|
||||
(let ((package-versions
|
||||
(package-versions-for-branch conn
|
||||
(string->number repository-id)
|
||||
branch-name
|
||||
package-name)))
|
||||
(letpar& ((package-versions
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(package-versions-for-branch conn
|
||||
(string->number repository-id)
|
||||
branch-name
|
||||
package-name)))))
|
||||
(case (most-appropriate-mime-type
|
||||
'(application/json text/html)
|
||||
mime-types)
|
||||
|
|
@ -178,7 +191,6 @@
|
|||
(('GET "repository" repository-id "branch" branch-name "package" package-name "derivation-history")
|
||||
(render-branch-package-derivation-history request
|
||||
mime-types
|
||||
conn
|
||||
repository-id
|
||||
branch-name
|
||||
package-name))
|
||||
|
|
@ -186,27 +198,32 @@
|
|||
"package" package-name "output-history")
|
||||
(render-branch-package-output-history request
|
||||
mime-types
|
||||
conn
|
||||
repository-id
|
||||
branch-name
|
||||
package-name))
|
||||
(('GET "repository" repository-id "branch" branch-name "latest-processed-revision")
|
||||
(let ((commit-hash
|
||||
(latest-processed-commit-for-branch conn repository-id branch-name)))
|
||||
(letpar& ((commit-hash
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(latest-processed-commit-for-branch conn
|
||||
repository-id
|
||||
branch-name)))))
|
||||
(if commit-hash
|
||||
(render-view-revision mime-types
|
||||
conn
|
||||
commit-hash
|
||||
#:path-base path
|
||||
#:header-text
|
||||
`("Latest processed revision for branch "
|
||||
(samp ,branch-name)))
|
||||
(render-unknown-revision mime-types
|
||||
conn
|
||||
commit-hash))))
|
||||
(('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "packages")
|
||||
(let ((commit-hash
|
||||
(latest-processed-commit-for-branch conn repository-id branch-name)))
|
||||
(letpar& ((commit-hash
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(latest-processed-commit-for-branch conn
|
||||
repository-id
|
||||
branch-name)))))
|
||||
(if commit-hash
|
||||
(let ((parsed-query-parameters
|
||||
(guard-against-mutually-exclusive-query-parameters
|
||||
|
|
@ -227,7 +244,6 @@
|
|||
(limit_results all_results)))))
|
||||
|
||||
(render-revision-packages mime-types
|
||||
conn
|
||||
commit-hash
|
||||
parsed-query-parameters
|
||||
#:path-base path
|
||||
|
|
@ -240,11 +256,14 @@
|
|||
"/branch/" branch-name
|
||||
"/latest-processed-revision")))
|
||||
(render-unknown-revision mime-types
|
||||
conn
|
||||
commit-hash))))
|
||||
(('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "package-derivations")
|
||||
(let ((commit-hash
|
||||
(latest-processed-commit-for-branch conn repository-id branch-name)))
|
||||
(letpar& ((commit-hash
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(latest-processed-commit-for-branch conn
|
||||
repository-id
|
||||
branch-name)))))
|
||||
(if commit-hash
|
||||
(let ((parsed-query-parameters
|
||||
(guard-against-mutually-exclusive-query-parameters
|
||||
|
|
@ -265,39 +284,45 @@
|
|||
'((limit_results all_results)))))
|
||||
|
||||
(render-revision-package-derivations mime-types
|
||||
conn
|
||||
commit-hash
|
||||
parsed-query-parameters
|
||||
#:path-base path))
|
||||
(render-unknown-revision mime-types
|
||||
conn
|
||||
commit-hash))))
|
||||
(('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "package-reproducibility")
|
||||
(let ((commit-hash
|
||||
(latest-processed-commit-for-branch conn repository-id branch-name)))
|
||||
(letpar& ((commit-hash
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(latest-processed-commit-for-branch conn
|
||||
repository-id
|
||||
branch-name)))))
|
||||
(if commit-hash
|
||||
(render-revision-package-reproduciblity mime-types
|
||||
conn
|
||||
commit-hash
|
||||
#:path-base path)
|
||||
(render-unknown-revision mime-types
|
||||
conn
|
||||
commit-hash))))
|
||||
(('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "package-substitute-availability")
|
||||
(let ((commit-hash
|
||||
(latest-processed-commit-for-branch conn repository-id branch-name)))
|
||||
(letpar& ((commit-hash
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(latest-processed-commit-for-branch conn
|
||||
repository-id
|
||||
branch-name)))))
|
||||
(if commit-hash
|
||||
(render-revision-package-substitute-availability mime-types
|
||||
conn
|
||||
commit-hash
|
||||
#:path-base path)
|
||||
(render-unknown-revision mime-types
|
||||
conn
|
||||
commit-hash))))
|
||||
(('GET "repository" repository-id "branch" branch-name "latest-processed-revision"
|
||||
"lint-warnings")
|
||||
(let ((commit-hash
|
||||
(latest-processed-commit-for-branch conn repository-id branch-name)))
|
||||
(letpar& ((commit-hash
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(latest-processed-commit-for-branch conn
|
||||
repository-id
|
||||
branch-name)))))
|
||||
(if commit-hash
|
||||
(let ((parsed-query-parameters
|
||||
(parse-query-parameters
|
||||
|
|
@ -312,7 +337,6 @@
|
|||
"location"))))))
|
||||
|
||||
(render-revision-lint-warnings mime-types
|
||||
conn
|
||||
commit-hash
|
||||
parsed-query-parameters
|
||||
#:path-base path
|
||||
|
|
@ -325,43 +349,46 @@
|
|||
"/branch/" branch-name
|
||||
"/latest-processed-revision")))
|
||||
(render-unknown-revision mime-types
|
||||
conn
|
||||
commit-hash))))
|
||||
(('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "package" name version)
|
||||
(let ((commit-hash
|
||||
(latest-processed-commit-for-branch conn repository-id branch-name))
|
||||
(parsed-query-parameters
|
||||
(parse-query-parameters
|
||||
request
|
||||
`((locale ,identity #:default "en_US.UTF-8")))))
|
||||
(if commit-hash
|
||||
(render-revision-package-version mime-types
|
||||
conn
|
||||
commit-hash
|
||||
name
|
||||
version
|
||||
parsed-query-parameters
|
||||
#:header-text
|
||||
`("Latest processed revision for branch "
|
||||
(samp ,branch-name))
|
||||
#:header-link
|
||||
(string-append
|
||||
"/repository/" repository-id
|
||||
"/branch/" branch-name
|
||||
"/latest-processed-revision")
|
||||
#:version-history-link
|
||||
(string-append
|
||||
"/repository/" repository-id
|
||||
"/branch/" branch-name
|
||||
"/package/" name))
|
||||
(render-unknown-revision mime-types
|
||||
conn
|
||||
commit-hash))))
|
||||
(_ #f)))
|
||||
(letpar& ((commit-hash
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(latest-processed-commit-for-branch conn
|
||||
repository-id
|
||||
branch-name)))))
|
||||
(let ((parsed-query-parameters
|
||||
(parse-query-parameters
|
||||
request
|
||||
`((locale ,identity #:default "en_US.UTF-8")))))
|
||||
(if commit-hash
|
||||
(render-revision-package-version mime-types
|
||||
commit-hash
|
||||
name
|
||||
version
|
||||
parsed-query-parameters
|
||||
#:header-text
|
||||
`("Latest processed revision for branch "
|
||||
(samp ,branch-name))
|
||||
#:header-link
|
||||
(string-append
|
||||
"/repository/" repository-id
|
||||
"/branch/" branch-name
|
||||
"/latest-processed-revision")
|
||||
#:version-history-link
|
||||
(string-append
|
||||
"/repository/" repository-id
|
||||
"/branch/" branch-name
|
||||
"/package/" name))
|
||||
(render-unknown-revision mime-types
|
||||
commit-hash)))))
|
||||
(_ #f)))
|
||||
|
||||
(define (parse-build-system conn)
|
||||
(define (parse-build-system)
|
||||
(let ((systems
|
||||
(valid-systems conn)))
|
||||
(parallel-via-thread-pool-channel
|
||||
(with-thread-postgresql-connection
|
||||
valid-systems))))
|
||||
(lambda (s)
|
||||
(if (member s systems)
|
||||
s
|
||||
|
|
@ -370,70 +397,77 @@
|
|||
|
||||
(define (render-branch-package-derivation-history request
|
||||
mime-types
|
||||
conn
|
||||
repository-id
|
||||
branch-name
|
||||
package-name)
|
||||
(let ((parsed-query-parameters
|
||||
(parse-query-parameters
|
||||
request
|
||||
`((system ,(parse-build-system conn)
|
||||
`((system ,(parse-build-system)
|
||||
#:default "x86_64-linux")
|
||||
(target ,parse-target
|
||||
#:default "")))))
|
||||
(let* ((system
|
||||
(assq-ref parsed-query-parameters 'system))
|
||||
(target
|
||||
(assq-ref parsed-query-parameters 'target))
|
||||
(package-derivations
|
||||
(package-derivations-for-branch conn
|
||||
(string->number repository-id)
|
||||
branch-name
|
||||
system
|
||||
target
|
||||
package-name))
|
||||
(let ((system
|
||||
(assq-ref parsed-query-parameters 'system))
|
||||
(target
|
||||
(assq-ref parsed-query-parameters 'target)))
|
||||
(letpar&
|
||||
((package-derivations
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(package-derivations-for-branch conn
|
||||
(string->number repository-id)
|
||||
branch-name
|
||||
system
|
||||
target
|
||||
package-name))))
|
||||
(build-server-urls
|
||||
(select-build-server-urls-by-id conn)))
|
||||
(case (most-appropriate-mime-type
|
||||
'(application/json text/html)
|
||||
mime-types)
|
||||
((application/json)
|
||||
(render-json
|
||||
`((derivations . ,(list->vector
|
||||
(map (match-lambda
|
||||
((package-version derivation-file-name
|
||||
first-guix-revision-commit
|
||||
first-datetime
|
||||
last-guix-revision-commit
|
||||
last-datetime
|
||||
builds)
|
||||
`((version . ,package-version)
|
||||
(derivation . ,derivation-file-name)
|
||||
(first_revision
|
||||
. ((commit . ,first-guix-revision-commit)
|
||||
(datetime . ,first-datetime)))
|
||||
(last_revision
|
||||
. ((commit . ,last-guix-revision-commit)
|
||||
(datetime . ,last-datetime)))
|
||||
(builds
|
||||
. ,(list->vector builds)))))
|
||||
package-derivations))))))
|
||||
(else
|
||||
(render-html
|
||||
#:sxml (view-branch-package-derivations
|
||||
parsed-query-parameters
|
||||
repository-id
|
||||
branch-name
|
||||
package-name
|
||||
(valid-systems conn)
|
||||
(valid-targets->options
|
||||
(valid-targets conn))
|
||||
build-server-urls
|
||||
package-derivations)))))))
|
||||
(with-thread-postgresql-connection
|
||||
select-build-server-urls-by-id)))
|
||||
(case (most-appropriate-mime-type
|
||||
'(application/json text/html)
|
||||
mime-types)
|
||||
((application/json)
|
||||
(render-json
|
||||
`((derivations . ,(list->vector
|
||||
(map (match-lambda
|
||||
((package-version derivation-file-name
|
||||
first-guix-revision-commit
|
||||
first-datetime
|
||||
last-guix-revision-commit
|
||||
last-datetime
|
||||
builds)
|
||||
`((version . ,package-version)
|
||||
(derivation . ,derivation-file-name)
|
||||
(first_revision
|
||||
. ((commit . ,first-guix-revision-commit)
|
||||
(datetime . ,first-datetime)))
|
||||
(last_revision
|
||||
. ((commit . ,last-guix-revision-commit)
|
||||
(datetime . ,last-datetime)))
|
||||
(builds
|
||||
. ,(list->vector builds)))))
|
||||
package-derivations))))))
|
||||
(else
|
||||
(letpar& ((systems
|
||||
(with-thread-postgresql-connection
|
||||
valid-systems))
|
||||
(targets
|
||||
(with-thread-postgresql-connection
|
||||
valid-targets)))
|
||||
(render-html
|
||||
#:sxml (view-branch-package-derivations
|
||||
parsed-query-parameters
|
||||
repository-id
|
||||
branch-name
|
||||
package-name
|
||||
systems
|
||||
(valid-targets->options targets)
|
||||
build-server-urls
|
||||
package-derivations)))))))))
|
||||
|
||||
(define (render-branch-package-output-history request
|
||||
mime-types
|
||||
conn
|
||||
repository-id
|
||||
branch-name
|
||||
package-name)
|
||||
|
|
@ -442,60 +476,69 @@
|
|||
request
|
||||
`((output ,identity
|
||||
#:default "out")
|
||||
(system ,(parse-build-system conn)
|
||||
(system ,(parse-build-system)
|
||||
#:default "x86_64-linux")
|
||||
(target ,parse-target
|
||||
#:default "")))))
|
||||
(let* ((system
|
||||
(assq-ref parsed-query-parameters 'system))
|
||||
(target
|
||||
(assq-ref parsed-query-parameters 'target))
|
||||
(output-name
|
||||
(assq-ref parsed-query-parameters 'output))
|
||||
(package-outputs
|
||||
(package-outputs-for-branch conn
|
||||
(string->number repository-id)
|
||||
branch-name
|
||||
system
|
||||
target
|
||||
package-name
|
||||
output-name))
|
||||
(let ((system
|
||||
(assq-ref parsed-query-parameters 'system))
|
||||
(target
|
||||
(assq-ref parsed-query-parameters 'target))
|
||||
(output-name
|
||||
(assq-ref parsed-query-parameters 'output)))
|
||||
(letpar&
|
||||
((package-outputs
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(package-outputs-for-branch conn
|
||||
(string->number repository-id)
|
||||
branch-name
|
||||
system
|
||||
target
|
||||
package-name
|
||||
output-name))))
|
||||
(build-server-urls
|
||||
(select-build-server-urls-by-id conn)))
|
||||
(case (most-appropriate-mime-type
|
||||
'(application/json text/html)
|
||||
mime-types)
|
||||
((application/json)
|
||||
(render-json
|
||||
`((derivations . ,(list->vector
|
||||
(map (match-lambda
|
||||
((package-version derivation-file-name
|
||||
first-guix-revision-commit
|
||||
first-datetime
|
||||
last-guix-revision-commit
|
||||
last-datetime
|
||||
builds)
|
||||
`((version . ,package-version)
|
||||
(derivation . ,derivation-file-name)
|
||||
(first_revision
|
||||
. ((commit . ,first-guix-revision-commit)
|
||||
(datetime . ,first-datetime)))
|
||||
(last_revision
|
||||
. ((commit . ,last-guix-revision-commit)
|
||||
(datetime . ,last-datetime)))
|
||||
(builds
|
||||
. ,(list->vector builds)))))
|
||||
package-outputs))))))
|
||||
(else
|
||||
(render-html
|
||||
#:sxml (view-branch-package-outputs
|
||||
parsed-query-parameters
|
||||
repository-id
|
||||
branch-name
|
||||
package-name
|
||||
output-name
|
||||
(valid-systems conn)
|
||||
(valid-targets->options
|
||||
(valid-targets conn))
|
||||
build-server-urls
|
||||
package-outputs)))))))
|
||||
(with-thread-postgresql-connection
|
||||
select-build-server-urls-by-id)))
|
||||
(case (most-appropriate-mime-type
|
||||
'(application/json text/html)
|
||||
mime-types)
|
||||
((application/json)
|
||||
(render-json
|
||||
`((derivations . ,(list->vector
|
||||
(map (match-lambda
|
||||
((package-version derivation-file-name
|
||||
first-guix-revision-commit
|
||||
first-datetime
|
||||
last-guix-revision-commit
|
||||
last-datetime
|
||||
builds)
|
||||
`((version . ,package-version)
|
||||
(derivation . ,derivation-file-name)
|
||||
(first_revision
|
||||
. ((commit . ,first-guix-revision-commit)
|
||||
(datetime . ,first-datetime)))
|
||||
(last_revision
|
||||
. ((commit . ,last-guix-revision-commit)
|
||||
(datetime . ,last-datetime)))
|
||||
(builds
|
||||
. ,(list->vector builds)))))
|
||||
package-outputs))))))
|
||||
(else
|
||||
(letpar& ((systems
|
||||
(with-thread-postgresql-connection
|
||||
valid-systems))
|
||||
(targets
|
||||
(with-thread-postgresql-connection
|
||||
valid-targets)))
|
||||
(render-html
|
||||
#:sxml (view-branch-package-outputs
|
||||
parsed-query-parameters
|
||||
repository-id
|
||||
branch-name
|
||||
package-name
|
||||
output-name
|
||||
systems
|
||||
(valid-targets->options targets)
|
||||
build-server-urls
|
||||
package-outputs)))))))))
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load diff
Loading…
Reference in a new issue