mirror of
git://git.savannah.gnu.org/guix/data-service.git
synced 2023-12-14 03:23:03 +01:00
Improve the compare derivations page
Add support for filtering the results, and add the system and target to the output.
This commit is contained in:
Christopher Baines
parent
0d16c87da8
commit
189014f3bc
5 changed files with 254 additions and 51 deletions
|
|
@ -98,7 +98,9 @@ ORDER BY base_packages.name DESC, base_packages.version, target_packages.name, t
|
|||
(select-derivations-by-id conn derivation-ids)))
|
||||
derivation-data))
|
||||
|
||||
(define (package-data-vhash->derivations-and-build-status conn packages-vhash)
|
||||
(define (package-data-vhash->derivations-and-build-status conn packages-vhash
|
||||
systems targets
|
||||
build-statuses)
|
||||
(define (vhash->derivation-file-names vhash)
|
||||
(vhash-fold (lambda (key value result)
|
||||
(cons (third value)
|
||||
|
|
@ -109,9 +111,12 @@ ORDER BY base_packages.name DESC, base_packages.version, target_packages.name, t
|
|||
(let* ((derivation-file-names
|
||||
(vhash->derivation-file-names packages-vhash))
|
||||
(derivation-data
|
||||
(select-derivations-and-build-status-by-file-name
|
||||
(select-derivations-and-build-status
|
||||
conn
|
||||
derivation-file-names)))
|
||||
#:file-names derivation-file-names
|
||||
#:systems systems
|
||||
#:targets targets
|
||||
#:build-statuses build-statuses)))
|
||||
derivation-data))
|
||||
|
||||
(define (package-data-vhash->package-name-and-version-vhash vhash)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
(define-module (guix-data-service model build-status)
|
||||
#:use-module (squee)
|
||||
#:export (build-statuses
|
||||
build-status-strings
|
||||
insert-build-status))
|
||||
|
||||
(define build-statuses
|
||||
|
|
@ -12,6 +13,9 @@
|
|||
(3 . "failed-other")
|
||||
(4 . "canceled")))
|
||||
|
||||
(define build-status-strings
|
||||
(map cdr build-statuses))
|
||||
|
||||
(define (insert-build-status conn internal-build-id
|
||||
starttime stoptime status)
|
||||
(exec-query conn
|
||||
|
|
|
|||
|
|
@ -8,7 +8,8 @@
|
|||
#:use-module (guix memoization)
|
||||
#:use-module (guix derivations)
|
||||
#:use-module (guix-data-service model utils)
|
||||
#:export (select-derivation-by-file-name
|
||||
#:export (valid-systems
|
||||
select-derivation-by-file-name
|
||||
select-derivation-outputs-by-derivation-id
|
||||
select-derivation-by-output-filename
|
||||
select-derivations-using-output
|
||||
|
|
@ -16,10 +17,16 @@
|
|||
select-derivation-inputs-by-derivation-id
|
||||
select-existing-derivations
|
||||
select-derivations-by-id
|
||||
select-derivations-and-build-status-by-file-name
|
||||
select-derivations-and-build-status
|
||||
insert-into-derivations
|
||||
derivation-file-names->derivation-ids))
|
||||
|
||||
(define (valid-systems conn)
|
||||
(map car
|
||||
(exec-query
|
||||
conn
|
||||
"SELECT DISTINCT system FROM derivations ORDER BY 1")))
|
||||
|
||||
(define (select-existing-derivations file-names)
|
||||
(string-append "SELECT id, file_name "
|
||||
"FROM derivations "
|
||||
|
|
@ -462,11 +469,45 @@ ORDER BY derivations.system DESC,
|
|||
|
||||
(exec-query conn query))
|
||||
|
||||
(define (select-derivations-and-build-status-by-file-name conn file-names)
|
||||
(define* (select-derivations-and-build-status conn #:key
|
||||
file-names
|
||||
systems
|
||||
targets
|
||||
build-statuses)
|
||||
(define criteria
|
||||
(string-join
|
||||
(filter-map
|
||||
(lambda (field values)
|
||||
(if (and values (not (null? values)))
|
||||
(string-append
|
||||
field " IN ("
|
||||
(string-join (map (lambda (value)
|
||||
(simple-format #f "'~A'" value))
|
||||
values)
|
||||
",")
|
||||
")")
|
||||
#f))
|
||||
'("derivations.file_name"
|
||||
"derivations.system"
|
||||
"target"
|
||||
"latest_build_status.status")
|
||||
(list file-names
|
||||
systems
|
||||
targets
|
||||
build-statuses))
|
||||
" AND "))
|
||||
|
||||
(define query
|
||||
(string-append
|
||||
"SELECT derivations.file_name, latest_build_status.status "
|
||||
"SELECT derivations.file_name, derivations.system, ("
|
||||
" SELECT DISTINCT package_derivations.target"
|
||||
" FROM package_derivations"
|
||||
" WHERE derivations.id = package_derivations.derivation_id"
|
||||
") AS target, "
|
||||
"latest_build_status.status "
|
||||
"FROM derivations "
|
||||
"INNER JOIN package_derivations"
|
||||
" ON derivations.id = package_derivations.derivation_id "
|
||||
"LEFT OUTER JOIN builds ON derivations.id = builds.derivation_id "
|
||||
"LEFT OUTER JOIN "
|
||||
"(SELECT DISTINCT ON (internal_build_id) * "
|
||||
|
|
@ -474,12 +515,7 @@ ORDER BY derivations.system DESC,
|
|||
"ORDER BY internal_build_id, status_fetched_at DESC"
|
||||
") AS latest_build_status "
|
||||
"ON builds.internal_id = latest_build_status.internal_build_id "
|
||||
"WHERE derivations.file_name IN "
|
||||
"(" (string-join (map (lambda (file-name)
|
||||
(simple-format #f "'~A'" file-name))
|
||||
file-names)
|
||||
",")
|
||||
");"))
|
||||
"WHERE " criteria ";"))
|
||||
|
||||
(exec-query conn query))
|
||||
|
||||
|
|
|
|||
|
|
@ -32,6 +32,7 @@
|
|||
#:use-module (guix-data-service model package-derivation)
|
||||
#:use-module (guix-data-service model package-metadata)
|
||||
#:use-module (guix-data-service model derivation)
|
||||
#:use-module (guix-data-service model build-status)
|
||||
#:use-module (guix-data-service model build)
|
||||
#:use-module (guix-data-service jobs load-new-guix-revision)
|
||||
#:use-module (guix-data-service web render)
|
||||
|
|
@ -57,17 +58,18 @@
|
|||
;; (render-html (error-page message))))
|
||||
)
|
||||
|
||||
(define (with-base-and-target-commits request conn f)
|
||||
(let ((base-commit (-> request
|
||||
request-uri
|
||||
uri-query
|
||||
parse-query-string
|
||||
(cut assoc-ref <> "base_commit")))
|
||||
(target-commit (-> request
|
||||
request-uri
|
||||
uri-query
|
||||
parse-query-string
|
||||
(cut assoc-ref <> "target_commit"))))
|
||||
(define (assoc-ref-multiple alist key)
|
||||
(filter-map
|
||||
(match-lambda
|
||||
((k . value)
|
||||
(and (string=? k key)
|
||||
value)))
|
||||
alist))
|
||||
|
||||
(define (with-base-and-target-commits query-parameters conn f)
|
||||
(let* ((base-commit (assoc-ref query-parameters "base_commit"))
|
||||
(target-commit (assoc-ref query-parameters "target_commit")))
|
||||
|
||||
(f base-commit
|
||||
(commit->revision-id conn base-commit)
|
||||
target-commit
|
||||
|
|
@ -139,11 +141,16 @@
|
|||
base-commit
|
||||
base-revision-id
|
||||
target-commit
|
||||
target-revision-id)
|
||||
target-revision-id
|
||||
systems
|
||||
targets
|
||||
build-statuses)
|
||||
(define (derivations->alist derivations)
|
||||
(map (match-lambda
|
||||
((file-name buildstatus)
|
||||
((file-name system target buildstatus)
|
||||
`((file_name . ,file-name)
|
||||
(system . ,system)
|
||||
(target . ,target)
|
||||
(build_status . ,(if (string=? "")
|
||||
"unknown"
|
||||
buildstatus)))))
|
||||
|
|
@ -158,11 +165,17 @@
|
|||
(let ((base-derivations
|
||||
(package-data-vhash->derivations-and-build-status
|
||||
conn
|
||||
base-packages-vhash))
|
||||
base-packages-vhash
|
||||
systems
|
||||
targets
|
||||
build-statuses))
|
||||
(target-derivations
|
||||
(package-data-vhash->derivations-and-build-status
|
||||
conn
|
||||
target-packages-vhash)))
|
||||
target-packages-vhash
|
||||
systems
|
||||
targets
|
||||
build-statuses)))
|
||||
(cond
|
||||
((eq? content-type 'json)
|
||||
(render-json
|
||||
|
|
@ -177,10 +190,15 @@
|
|||
(else
|
||||
(apply render-html
|
||||
(compare/derivations
|
||||
(valid-systems conn)
|
||||
build-status-strings
|
||||
base-commit
|
||||
target-commit
|
||||
base-derivations
|
||||
target-derivations)))))))
|
||||
target-derivations
|
||||
systems
|
||||
targets
|
||||
build-statuses)))))))
|
||||
|
||||
(define (render-compare/packages content-type
|
||||
conn
|
||||
|
|
@ -260,6 +278,12 @@
|
|||
derivations)))))))
|
||||
|
||||
(define (controller request body conn)
|
||||
(define query-parameters
|
||||
(-> request
|
||||
request-uri
|
||||
uri-query
|
||||
parse-query-string))
|
||||
|
||||
(match-lambda
|
||||
((GET)
|
||||
(apply render-html (index
|
||||
|
|
@ -303,7 +327,7 @@
|
|||
(render-store-item conn (string-append "/gnu/store/" filename))))
|
||||
((GET "compare")
|
||||
(with-base-and-target-commits
|
||||
request conn
|
||||
query-parameters conn
|
||||
(lambda (base-commit base-revision-id target-commit target-revision-id)
|
||||
(if (not (and base-revision-id target-revision-id))
|
||||
(render-compare-unknown-commit 'html
|
||||
|
|
@ -320,7 +344,7 @@
|
|||
target-revision-id)))))
|
||||
((GET "compare.json")
|
||||
(with-base-and-target-commits
|
||||
request conn
|
||||
query-parameters conn
|
||||
(lambda (base-commit base-revision-id target-commit target-revision-id)
|
||||
(if (not (and base-revision-id target-revision-id))
|
||||
(render-compare-unknown-commit 'json
|
||||
|
|
@ -337,7 +361,7 @@
|
|||
target-revision-id)))))
|
||||
((GET "compare" "derivations")
|
||||
(with-base-and-target-commits
|
||||
request conn
|
||||
query-parameters conn
|
||||
(lambda (base-commit base-revision-id target-commit target-revision-id)
|
||||
(if (not (and base-revision-id target-revision-id))
|
||||
(render-compare-unknown-commit 'html
|
||||
|
|
@ -351,10 +375,16 @@
|
|||
base-commit
|
||||
base-revision-id
|
||||
target-commit
|
||||
target-revision-id)))))
|
||||
target-revision-id
|
||||
(assoc-ref-multiple query-parameters
|
||||
"system")
|
||||
(assoc-ref-multiple query-parameters
|
||||
"target")
|
||||
(assoc-ref-multiple query-parameters
|
||||
"build_status"))))))
|
||||
((GET "compare" "derivations.json")
|
||||
(with-base-and-target-commits
|
||||
request conn
|
||||
query-parameters conn
|
||||
(lambda (base-commit base-revision-id target-commit target-revision-id)
|
||||
(if (not (and base-revision-id target-revision-id))
|
||||
(render-compare-unknown-commit 'json
|
||||
|
|
@ -368,10 +398,16 @@
|
|||
base-commit
|
||||
base-revision-id
|
||||
target-commit
|
||||
target-revision-id)))))
|
||||
target-revision-id
|
||||
(assoc-ref-multiple query-parameters
|
||||
"system")
|
||||
(assoc-ref-multiple query-parameters
|
||||
"target")
|
||||
(assoc-ref-multiple query-parameters
|
||||
"build_status"))))))
|
||||
((GET "compare" "packages")
|
||||
(with-base-and-target-commits
|
||||
request conn
|
||||
query-parameters conn
|
||||
(lambda (base-commit base-revision-id target-commit target-revision-id)
|
||||
(if (not (and base-revision-id target-revision-id))
|
||||
(render-compare-unknown-commit 'html
|
||||
|
|
@ -388,7 +424,7 @@
|
|||
target-revision-id)))))
|
||||
((GET "compare" "packages.json")
|
||||
(with-base-and-target-commits
|
||||
request conn
|
||||
query-parameters conn
|
||||
(lambda (base-commit base-revision-id target-commit target-revision-id)
|
||||
(if (not (and base-revision-id target-revision-id))
|
||||
(render-compare-unknown-commit 'json
|
||||
|
|
|
|||
|
|
@ -641,11 +641,13 @@
|
|||
(td ,name)
|
||||
(td (ul
|
||||
,@(map (match-lambda
|
||||
((type . #(version))
|
||||
((type . versions)
|
||||
`(li (@ (class ,(if (eq? type 'base)
|
||||
"text-danger"
|
||||
"text-success")))
|
||||
,version
|
||||
,(string-join
|
||||
(vector->list versions)
|
||||
", ")
|
||||
,(if (eq? type 'base)
|
||||
" (old)"
|
||||
" (new)"))))
|
||||
|
|
@ -726,10 +728,15 @@
|
|||
(cdr data-columns))))))
|
||||
(vector->list derivation-changes))))))))))
|
||||
|
||||
(define (compare/derivations base-commit
|
||||
(define (compare/derivations valid-systems
|
||||
valid-build-statuses
|
||||
base-commit
|
||||
target-commit
|
||||
base-derivations
|
||||
target-derivations)
|
||||
target-derivations
|
||||
systems
|
||||
targets
|
||||
build-statues)
|
||||
(define query-params
|
||||
(string-append "?base_commit=" base-commit
|
||||
"&target_commit=" target-commit))
|
||||
|
|
@ -746,11 +753,118 @@
|
|||
(h1 "Comparing "
|
||||
(samp ,(string-take base-commit 8) "…")
|
||||
" and "
|
||||
(samp ,(string-take target-commit 8) "…"))
|
||||
(a (@ (class "btn btn-default btn-lg")
|
||||
(href ,(string-append
|
||||
"/compare/derivations.json" query-params)))
|
||||
"View JSON"))
|
||||
(samp ,(string-take target-commit 8) "…")))
|
||||
(div
|
||||
(@ (class "row"))
|
||||
(div
|
||||
(@ (class "col-md-12"))
|
||||
(div
|
||||
(@ (class "well"))
|
||||
(form
|
||||
(@ (method "get")
|
||||
(action "")
|
||||
(class "form-horizontal"))
|
||||
(div (@ (class "form-group form-group-lg"))
|
||||
(label (@ (for "inputBaseCommit")
|
||||
(class "col-sm-2 control-label"))
|
||||
"Base commit")
|
||||
(div (@ (class "col-sm-9"))
|
||||
(input (@ (class "form-control")
|
||||
(style "font-family: monospace;")
|
||||
(id "inputBaseCommit")
|
||||
(required #t)
|
||||
(aria-describedby "baseCommitHelp")
|
||||
(name "base_commit")
|
||||
(value ,base-commit)))
|
||||
(span (@ (id "baseCommitHelp")
|
||||
(class "help-block"))
|
||||
(strong "Required.")
|
||||
" The commit to use as the basis for the comparison.")))
|
||||
(div (@ (class "form-group form-group-lg"))
|
||||
(label (@ (for "inputTargetCommit")
|
||||
(class "col-sm-2 control-label"))
|
||||
"Target commit")
|
||||
(div (@ (class "col-sm-9"))
|
||||
(input (@ (class "form-control")
|
||||
(style "font-family: monospace;")
|
||||
(id "inputTargetCommit")
|
||||
(required #t)
|
||||
(aria-describedby "targetCommitHelp")
|
||||
(name "target_commit")
|
||||
(value ,target-commit)))
|
||||
(span (@ (id "targetCommitHelp")
|
||||
(class "help-block"))
|
||||
(strong "Required.")
|
||||
" The commit to compare against the base commit.")))
|
||||
(div (@ (class "form-group form-group-lg"))
|
||||
(label (@ (for "inputSystem")
|
||||
(class "col-sm-2 control-label"))
|
||||
"System")
|
||||
(div (@ (class "col-sm-9"))
|
||||
(select (@ (class "form-control")
|
||||
(style "font-family: monospace;")
|
||||
(multiple #t)
|
||||
(id "inputSystem")
|
||||
(aria-describedby "systemHelp")
|
||||
(name "system"))
|
||||
,@(map (lambda (system)
|
||||
`(option (@ ,@(if (member system systems)
|
||||
'((selected ""))
|
||||
'()))
|
||||
,system))
|
||||
valid-systems))
|
||||
(span (@ (id "systemHelp")
|
||||
(class "help-block"))
|
||||
"Only include derivations for this system.")))
|
||||
(div (@ (class "form-group form-group-lg"))
|
||||
(label (@ (for "inputTarget")
|
||||
(class "col-sm-2 control-label"))
|
||||
"Target")
|
||||
(div (@ (class "col-sm-9"))
|
||||
(select (@ (class "form-control")
|
||||
(style "font-family: monospace;")
|
||||
(multiple #t)
|
||||
(id "inputTarget")
|
||||
(aria-describedby "targetHelp")
|
||||
(name "target"))
|
||||
,@(map (lambda (system)
|
||||
`(option (@ ,@(if (member system targets)
|
||||
'((selected ""))
|
||||
'()))
|
||||
,system))
|
||||
valid-systems))
|
||||
(span (@ (id "targetHelp")
|
||||
(class "help-block"))
|
||||
"Only include derivations that are build for this system.")))
|
||||
(div (@ (class "form-group form-group-lg"))
|
||||
(label (@ (for "inputBuildStatus")
|
||||
(class "col-sm-2 control-label"))
|
||||
"Build status")
|
||||
(div (@ (class "col-sm-9"))
|
||||
(select (@ (class "form-control")
|
||||
(id "inputBuildStatus")
|
||||
(aria-describedby "buildStatusHelp")
|
||||
(multiple #t)
|
||||
(name "build_status"))
|
||||
,@(map (lambda (build-status)
|
||||
`(option (@ ,@(if (member build-status build-statues)
|
||||
'((selected ""))
|
||||
'())
|
||||
(value ,build-status))
|
||||
,(build-status-value->display-string build-status)))
|
||||
valid-build-statuses))
|
||||
(span (@ (id "buildStatusHelp")
|
||||
(class "help-block"))
|
||||
"Only include derivations which have this build status.")))
|
||||
(div (@ (class "form-group form-group-lg"))
|
||||
(div (@ (class "col-sm-offset-2 col-sm-10"))
|
||||
(button (@ (type "submit")
|
||||
(class "btn btn-lg btn-primary"))
|
||||
"Update results")))
|
||||
(a (@ (class "btn btn-default btn-lg pull-right")
|
||||
(href ,(string-append
|
||||
"/compare/derivations.json" query-params)))
|
||||
"View JSON")))))
|
||||
(div
|
||||
(@ (class "row"))
|
||||
(h3 "Base ("
|
||||
|
|
@ -761,15 +875,19 @@
|
|||
(@ (class "table"))
|
||||
(thead
|
||||
(tr
|
||||
(th (@ (class "col-md-8")) "File Name")
|
||||
(th (@ (class "col-md-6")) "File Name")
|
||||
(th (@ (class "col-md-2")) "System")
|
||||
(th (@ (class "col-md-2")) "Target")
|
||||
(th (@ (class "col-md-4")) "Build status")))
|
||||
(tbody
|
||||
,@(map
|
||||
(match-lambda
|
||||
((file-name build-status)
|
||||
((file-name system target build-status)
|
||||
`(tr
|
||||
(td (a (@ (href ,file-name))
|
||||
,(display-store-item file-name)))
|
||||
,(display-store-item-short file-name)))
|
||||
(td (samp ,system))
|
||||
(td (samp ,target))
|
||||
(td ,(build-status-span build-status)))))
|
||||
base-derivations))))
|
||||
(div
|
||||
|
|
@ -783,14 +901,18 @@
|
|||
(thead
|
||||
(tr
|
||||
(th (@ (class "col-md-8")) "File Name")
|
||||
(th (@ (class "col-md-2")) "System")
|
||||
(th (@ (class "col-md-2")) "Target")
|
||||
(th (@ (class "col-md-4")) "Build status")))
|
||||
(tbody
|
||||
,@(map
|
||||
(match-lambda
|
||||
((file-name build-status)
|
||||
((file-name system target build-status)
|
||||
`(tr
|
||||
(td (a (@ (href ,file-name))
|
||||
,(display-store-item file-name)))
|
||||
,(display-store-item-short file-name)))
|
||||
(td (samp ,system))
|
||||
(td (samp ,target))
|
||||
(td ,(build-status-span build-status)))))
|
||||
target-derivations))))))))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue