mirror of
git://git.savannah.gnu.org/guix/data-service.git
synced 2023-12-14 03:23:03 +01:00
Add a page to show system tests for a revision
This commit is contained in:
Christopher Baines
parent
00d9664714
commit
19630014a3
|
|
@ -19,11 +19,13 @@
|
|||
#:use-module (srfi srfi-1)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (squee)
|
||||
#:use-module (json)
|
||||
#:use-module (guix utils)
|
||||
#:use-module (guix-data-service model utils)
|
||||
#:use-module (guix-data-service model location)
|
||||
#:use-module (guix-data-service model derivation)
|
||||
#:export (insert-system-tests-for-guix-revision))
|
||||
#:export (insert-system-tests-for-guix-revision
|
||||
select-system-tests-for-guix-revision))
|
||||
|
||||
(define (insert-system-tests-for-guix-revision conn
|
||||
guix-revision-id
|
||||
|
|
@ -63,3 +65,64 @@ VALUES "
|
|||
derivation-ids)
|
||||
", "))))
|
||||
#t)
|
||||
|
||||
(define (select-system-tests-for-guix-revision conn
|
||||
commit-hash)
|
||||
(define query
|
||||
"
|
||||
SELECT system_tests.name, system_tests.description,
|
||||
locations.file, locations.line, locations.column_number,
|
||||
derivations.file_name,
|
||||
JSON_AGG(
|
||||
json_build_object(
|
||||
'build_server_id', builds.build_server_id,
|
||||
'status', latest_build_status.status,
|
||||
'timestamp', latest_build_status.timestamp,
|
||||
'build_for_equivalent_derivation',
|
||||
builds.derivation_file_name != derivations.file_name
|
||||
)
|
||||
ORDER BY latest_build_status.timestamp
|
||||
) AS builds
|
||||
FROM system_tests
|
||||
INNER JOIN guix_revision_system_test_derivations
|
||||
ON system_tests.id = guix_revision_system_test_derivations.system_test_id
|
||||
INNER JOIN locations
|
||||
ON locations.id = system_tests.location_id
|
||||
INNER JOIN derivations
|
||||
ON guix_revision_system_test_derivations.derivation_id = derivations.id
|
||||
INNER JOIN derivations_by_output_details_set
|
||||
ON derivations.id = derivations_by_output_details_set.derivation_id
|
||||
LEFT OUTER JOIN builds
|
||||
ON derivations_by_output_details_set.derivation_output_details_set_id =
|
||||
builds.derivation_output_details_set_id
|
||||
LEFT OUTER JOIN (
|
||||
SELECT DISTINCT ON (build_id) *
|
||||
FROM build_status
|
||||
ORDER BY build_id, timestamp DESC
|
||||
) AS latest_build_status
|
||||
ON builds.id = latest_build_status.build_id
|
||||
INNER JOIN guix_revisions
|
||||
ON guix_revisions.id = guix_revision_system_test_derivations.guix_revision_id
|
||||
WHERE guix_revisions.commit = $1
|
||||
GROUP BY system_tests.name, system_tests.description,
|
||||
locations.file, locations.line, locations.column_number,
|
||||
derivations.file_name
|
||||
ORDER BY name ASC")
|
||||
|
||||
(map
|
||||
(match-lambda
|
||||
((name description
|
||||
file line column_number
|
||||
derivation_file_name
|
||||
builds-json)
|
||||
(list name
|
||||
description
|
||||
file
|
||||
(string->number line)
|
||||
(string->number column_number)
|
||||
derivation_file_name
|
||||
(filter (lambda (build)
|
||||
(assoc-ref build "status"))
|
||||
(vector->list
|
||||
(json-string->scm builds-json))))))
|
||||
(exec-query conn query (list commit-hash))))
|
||||
|
|
|
|||
|
|
@ -43,6 +43,7 @@
|
|||
#:use-module (guix-data-service model lint-checker)
|
||||
#:use-module (guix-data-service model lint-warning)
|
||||
#:use-module (guix-data-service model guix-revision)
|
||||
#:use-module (guix-data-service model system-test)
|
||||
#:use-module (guix-data-service model nar)
|
||||
#:use-module (guix-data-service web revision html)
|
||||
#:export (revision-controller
|
||||
|
|
@ -215,6 +216,15 @@
|
|||
(render-unknown-revision mime-types
|
||||
conn
|
||||
commit-hash)))
|
||||
(('GET "revision" commit-hash "system-tests")
|
||||
(if (guix-commit-exists? conn commit-hash)
|
||||
(render-revision-system-tests mime-types
|
||||
conn
|
||||
commit-hash
|
||||
#:path-base path)
|
||||
(render-unknown-revision mime-types
|
||||
conn
|
||||
commit-hash)))
|
||||
(('GET "revision" commit-hash "package-reproducibility")
|
||||
(if (guix-commit-exists? conn commit-hash)
|
||||
(render-revision-package-reproduciblity mime-types
|
||||
|
|
@ -340,6 +350,34 @@
|
|||
#:header-text header-text)
|
||||
#:extra-headers http-headers-for-unchanging-content)))))
|
||||
|
||||
(define* (render-revision-system-tests mime-types
|
||||
conn
|
||||
commit-hash
|
||||
#:key
|
||||
(path-base "/revision/")
|
||||
(header-text
|
||||
`("Revision " (samp ,commit-hash)))
|
||||
(header-link
|
||||
(string-append "/revision/" commit-hash)))
|
||||
(let ((system-tests
|
||||
(select-system-tests-for-guix-revision conn commit-hash)))
|
||||
(case (most-appropriate-mime-type
|
||||
'(application/json text/html)
|
||||
mime-types)
|
||||
((application/json)
|
||||
(render-json
|
||||
'())) ; TODO
|
||||
(else
|
||||
(render-html
|
||||
#:sxml (view-revision-system-tests
|
||||
commit-hash
|
||||
system-tests
|
||||
(git-repositories-containing-commit conn
|
||||
commit-hash)
|
||||
#:path-base path-base
|
||||
#:header-text header-text
|
||||
#:header-link header-link))))))
|
||||
|
||||
(define* (render-revision-package-reproduciblity mime-types
|
||||
conn
|
||||
commit-hash
|
||||
|
|
|
|||
|
|
@ -35,6 +35,7 @@
|
|||
view-revision-packages
|
||||
view-revision-derivations
|
||||
view-revision-derivation-outputs
|
||||
view-revision-system-tests
|
||||
view-revision-builds
|
||||
view-revision-lint-warnings
|
||||
unknown-revision))
|
||||
|
|
@ -648,6 +649,80 @@
|
|||
"Next page")))
|
||||
'())))))
|
||||
|
||||
(define* (view-revision-system-tests commit-hash
|
||||
system-tests
|
||||
git-repositories
|
||||
#:key (path-base "/revision/")
|
||||
header-text header-link)
|
||||
(layout
|
||||
#:body
|
||||
`(,(header)
|
||||
(div
|
||||
(@ (class "container"))
|
||||
(div
|
||||
(@ (class "row"))
|
||||
(div
|
||||
(@ (class "col-sm-12"))
|
||||
(h3 (a (@ (style "white-space: nowrap;")
|
||||
(href ,header-link))
|
||||
,@header-text))))
|
||||
(div
|
||||
(@ (class "row"))
|
||||
(div
|
||||
(@ (class "col-md-12"))
|
||||
(h1 "System tests")
|
||||
(table
|
||||
(@ (class "table"))
|
||||
(thead
|
||||
(tr
|
||||
(th "Name")
|
||||
(th "Description")
|
||||
(th "Location")
|
||||
(th "Derivation")
|
||||
(th "Build status")))
|
||||
(tbody
|
||||
,@(map
|
||||
(match-lambda
|
||||
((name description
|
||||
file line column-number
|
||||
derivation-file-name
|
||||
builds)
|
||||
`(tr
|
||||
(td ,name)
|
||||
(td
|
||||
,(stexi->shtml
|
||||
(texi-fragment->stexi description)))
|
||||
(td ,@(map
|
||||
(match-lambda
|
||||
((id label url cgit-url-base)
|
||||
(if
|
||||
(and cgit-url-base
|
||||
(not (string-null? cgit-url-base)))
|
||||
`(a (@ (href
|
||||
,(string-append
|
||||
cgit-url-base "tree/"
|
||||
file "?id=" commit-hash
|
||||
"#n" (number->string line))))
|
||||
,file
|
||||
" (line: " ,line
|
||||
", column: " ,column-number ")")
|
||||
'())))
|
||||
git-repositories))
|
||||
(td (a (@ (href ,derivation-file-name))
|
||||
,(display-store-item-short derivation-file-name)))
|
||||
(td ,@(map
|
||||
(lambda (build)
|
||||
(let ((build-server-id
|
||||
(assoc-ref build "build_server_id")))
|
||||
`(a (@ (href
|
||||
,(simple-format
|
||||
#f "/build-server/~A/build?derivation_file_name=~A"
|
||||
build-server-id
|
||||
derivation-file-name)))
|
||||
,(build-status-alist->build-icon build))))
|
||||
(peek builds))))))
|
||||
system-tests)))))))))
|
||||
|
||||
(define* (view-revision-package-reproducibility revision-commit-hash
|
||||
output-consistency)
|
||||
(layout
|
||||
|
|
|
|||
Loading…
Reference in a new issue