Update the derivation comparison implementation
This adds more query parameter validation, and uses form-horizontal-control to neaten up the view code.
This commit is contained in:
parent
512a583fa7
commit
640fb8a2ad
2 changed files with 134 additions and 217 deletions
|
|
@ -141,13 +141,7 @@
|
||||||
|
|
||||||
(define (render-compare/derivations content-type
|
(define (render-compare/derivations content-type
|
||||||
conn
|
conn
|
||||||
base-commit
|
query-parameters)
|
||||||
base-revision-id
|
|
||||||
target-commit
|
|
||||||
target-revision-id
|
|
||||||
systems
|
|
||||||
targets
|
|
||||||
build-statuses)
|
|
||||||
(define (derivations->alist derivations)
|
(define (derivations->alist derivations)
|
||||||
(map (match-lambda
|
(map (match-lambda
|
||||||
((file-name system target buildstatus)
|
((file-name system target buildstatus)
|
||||||
|
|
@ -159,49 +153,64 @@
|
||||||
buildstatus)))))
|
buildstatus)))))
|
||||||
derivations))
|
derivations))
|
||||||
|
|
||||||
(let-values
|
(if (any-invalid-query-parameters? query-parameters)
|
||||||
(((base-packages-vhash target-packages-vhash)
|
|
||||||
(package-data->package-data-vhashes
|
|
||||||
(package-differences-data conn
|
|
||||||
base-revision-id
|
|
||||||
target-revision-id))))
|
|
||||||
(let ((base-derivations
|
|
||||||
(package-data-vhash->derivations-and-build-status
|
|
||||||
conn
|
|
||||||
base-packages-vhash
|
|
||||||
systems
|
|
||||||
targets
|
|
||||||
build-statuses))
|
|
||||||
(target-derivations
|
|
||||||
(package-data-vhash->derivations-and-build-status
|
|
||||||
conn
|
|
||||||
target-packages-vhash
|
|
||||||
systems
|
|
||||||
targets
|
|
||||||
build-statuses)))
|
|
||||||
(cond
|
(cond
|
||||||
((eq? content-type 'json)
|
((eq? content-type 'json)
|
||||||
(render-json
|
(render-json
|
||||||
`((base . ((commit . ,base-commit)
|
'((error . "invalid query"))))
|
||||||
(derivations . ,(list->vector
|
|
||||||
(derivations->alist
|
|
||||||
base-derivations)))))
|
|
||||||
(target . ((commit . ,target-commit)
|
|
||||||
(derivations . ,(list->vector
|
|
||||||
(derivations->alist
|
|
||||||
target-derivations))))))))
|
|
||||||
(else
|
(else
|
||||||
(apply render-html
|
(apply render-html
|
||||||
(compare/derivations
|
(compare/derivations
|
||||||
|
query-parameters
|
||||||
(valid-systems conn)
|
(valid-systems conn)
|
||||||
build-status-strings
|
build-status-strings
|
||||||
base-commit
|
'()
|
||||||
target-commit
|
'()))))
|
||||||
base-derivations
|
|
||||||
target-derivations
|
(let ((base-commit (assq-ref query-parameters 'base_commit))
|
||||||
systems
|
(target-commit (assq-ref query-parameters 'target_commit))
|
||||||
targets
|
(systems (assq-ref query-parameters 'system))
|
||||||
build-statuses)))))))
|
(targets (assq-ref query-parameters 'target))
|
||||||
|
(build-statuses (assq-ref query-parameters 'build_status)))
|
||||||
|
(let-values
|
||||||
|
(((base-packages-vhash target-packages-vhash)
|
||||||
|
(package-data->package-data-vhashes
|
||||||
|
(package-differences-data conn
|
||||||
|
(commit->revision-id conn base-commit)
|
||||||
|
(commit->revision-id conn target-commit)))))
|
||||||
|
(let ((base-derivations
|
||||||
|
(package-data-vhash->derivations-and-build-status
|
||||||
|
conn
|
||||||
|
base-packages-vhash
|
||||||
|
systems
|
||||||
|
targets
|
||||||
|
build-statuses))
|
||||||
|
(target-derivations
|
||||||
|
(package-data-vhash->derivations-and-build-status
|
||||||
|
conn
|
||||||
|
target-packages-vhash
|
||||||
|
systems
|
||||||
|
targets
|
||||||
|
build-statuses)))
|
||||||
|
(cond
|
||||||
|
((eq? content-type 'json)
|
||||||
|
(render-json
|
||||||
|
`((base . ((commit . ,base-commit)
|
||||||
|
(derivations . ,(list->vector
|
||||||
|
(derivations->alist
|
||||||
|
base-derivations)))))
|
||||||
|
(target . ((commit . ,target-commit)
|
||||||
|
(derivations . ,(list->vector
|
||||||
|
(derivations->alist
|
||||||
|
target-derivations))))))))
|
||||||
|
(else
|
||||||
|
(apply render-html
|
||||||
|
(compare/derivations
|
||||||
|
query-parameters
|
||||||
|
(valid-systems conn)
|
||||||
|
build-status-strings
|
||||||
|
base-derivations
|
||||||
|
target-derivations)))))))))
|
||||||
|
|
||||||
(define (render-compare/packages content-type
|
(define (render-compare/packages content-type
|
||||||
conn
|
conn
|
||||||
|
|
@ -280,6 +289,19 @@
|
||||||
conn output-id))))
|
conn output-id))))
|
||||||
derivations)))))))
|
derivations)))))))
|
||||||
|
|
||||||
|
(define (parse-commit conn)
|
||||||
|
(lambda (s)
|
||||||
|
(if (guix-commit-exists? conn s)
|
||||||
|
s
|
||||||
|
(make-invalid-query-parameter
|
||||||
|
s "unknown commit"))))
|
||||||
|
|
||||||
|
(define (parse-system s)
|
||||||
|
s)
|
||||||
|
|
||||||
|
(define (parse-build-status s)
|
||||||
|
s)
|
||||||
|
|
||||||
(define (controller request body conn)
|
(define (controller request body conn)
|
||||||
(define query-parameters
|
(define query-parameters
|
||||||
(-> request
|
(-> request
|
||||||
|
|
@ -408,51 +430,29 @@
|
||||||
target-commit
|
target-commit
|
||||||
target-revision-id)))))
|
target-revision-id)))))
|
||||||
((GET "compare" "derivations")
|
((GET "compare" "derivations")
|
||||||
(with-base-and-target-commits
|
(let* ((parsed-query-parameters
|
||||||
query-parameters conn
|
(parse-query-parameters
|
||||||
(lambda (base-commit base-revision-id target-commit target-revision-id)
|
request
|
||||||
(if (not (and base-revision-id target-revision-id))
|
`((base_commit ,(parse-commit conn) #:required)
|
||||||
(render-compare-unknown-commit 'html
|
(target_commit ,(parse-commit conn) #:required)
|
||||||
conn
|
(system ,parse-system #:multi-value)
|
||||||
base-commit
|
(target ,parse-system #:multi-value)
|
||||||
base-revision-id
|
(build_status ,parse-build-status #:multi-value)))))
|
||||||
target-commit
|
(render-compare/derivations 'html
|
||||||
target-revision-id)
|
conn
|
||||||
(render-compare/derivations 'html
|
parsed-query-parameters)))
|
||||||
conn
|
|
||||||
base-commit
|
|
||||||
base-revision-id
|
|
||||||
target-commit
|
|
||||||
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")
|
((GET "compare" "derivations.json")
|
||||||
(with-base-and-target-commits
|
(let* ((parsed-query-parameters
|
||||||
query-parameters conn
|
(parse-query-parameters
|
||||||
(lambda (base-commit base-revision-id target-commit target-revision-id)
|
request
|
||||||
(if (not (and base-revision-id target-revision-id))
|
`((base_commit ,(parse-commit conn) #:required)
|
||||||
(render-compare-unknown-commit 'json
|
(target_commit ,(parse-commit conn) #:required)
|
||||||
conn
|
(system ,parse-system #:multi-value)
|
||||||
base-commit
|
(target ,parse-system #:multi-value)
|
||||||
base-revision-id
|
(build_status ,parse-build-status #:multi-value)))))
|
||||||
target-commit
|
(render-compare/derivations 'json
|
||||||
target-revision-id)
|
conn
|
||||||
(render-compare/derivations 'json
|
parsed-query-parameters)))
|
||||||
conn
|
|
||||||
base-commit
|
|
||||||
base-revision-id
|
|
||||||
target-commit
|
|
||||||
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")
|
((GET "compare" "packages")
|
||||||
(with-base-and-target-commits
|
(with-base-and-target-commits
|
||||||
query-parameters conn
|
query-parameters conn
|
||||||
|
|
|
||||||
|
|
@ -1005,35 +1005,11 @@
|
||||||
(cdr data-columns))))))
|
(cdr data-columns))))))
|
||||||
(vector->list derivation-changes)))))))))))
|
(vector->list derivation-changes)))))))))))
|
||||||
|
|
||||||
(define (compare/derivations valid-systems
|
(define (compare/derivations query-parameters
|
||||||
|
valid-systems
|
||||||
valid-build-statuses
|
valid-build-statuses
|
||||||
base-commit
|
|
||||||
target-commit
|
|
||||||
base-derivations
|
base-derivations
|
||||||
target-derivations
|
target-derivations)
|
||||||
systems
|
|
||||||
targets
|
|
||||||
build-statuses)
|
|
||||||
(define query-params
|
|
||||||
(string-append
|
|
||||||
"?"
|
|
||||||
(string-join
|
|
||||||
`(,(string-append "base_commit=" base-commit)
|
|
||||||
,(string-append "target_commit=" target-commit)
|
|
||||||
,@(map (lambda (system)
|
|
||||||
(string-append
|
|
||||||
"system=" system))
|
|
||||||
systems)
|
|
||||||
,@(map (lambda (target)
|
|
||||||
(string-append
|
|
||||||
"target=" target))
|
|
||||||
targets)
|
|
||||||
,@(map (lambda (build_status)
|
|
||||||
(string-append
|
|
||||||
"build_status=" build_status))
|
|
||||||
build-statuses))
|
|
||||||
"&")))
|
|
||||||
|
|
||||||
(layout
|
(layout
|
||||||
#:extra-headers
|
#:extra-headers
|
||||||
'((cache-control . ((max-age . 60))))
|
'((cache-control . ((max-age . 60))))
|
||||||
|
|
@ -1043,10 +1019,14 @@
|
||||||
(@ (class "container"))
|
(@ (class "container"))
|
||||||
(div
|
(div
|
||||||
(@ (class "row"))
|
(@ (class "row"))
|
||||||
(h1 "Comparing "
|
(h1 ,@(let ((base-commit (assq-ref query-parameters 'base_commit))
|
||||||
(samp ,(string-take base-commit 8) "…")
|
(target-commit (assq-ref query-parameters 'target_commit)))
|
||||||
" and "
|
(if (every string? (list base-commit target-commit))
|
||||||
(samp ,(string-take target-commit 8) "…")))
|
`("Comparing "
|
||||||
|
(samp ,(string-take base-commit 8) "…")
|
||||||
|
" and "
|
||||||
|
(samp ,(string-take target-commit 8) "…"))
|
||||||
|
'("Comparing derivations")))))
|
||||||
(div
|
(div
|
||||||
(@ (class "row"))
|
(@ (class "row"))
|
||||||
(div
|
(div
|
||||||
|
|
@ -1057,114 +1037,49 @@
|
||||||
(@ (method "get")
|
(@ (method "get")
|
||||||
(action "")
|
(action "")
|
||||||
(class "form-horizontal"))
|
(class "form-horizontal"))
|
||||||
(div (@ (class "form-group form-group-lg"))
|
,(form-horizontal-control
|
||||||
(label (@ (for "inputBaseCommit")
|
"Base commit" query-parameters
|
||||||
(class "col-sm-2 control-label"))
|
#:required? #t
|
||||||
"Base commit")
|
#:help-text "The commit to use as the basis for the comparison.")
|
||||||
(div (@ (class "col-sm-9"))
|
,(form-horizontal-control
|
||||||
(input (@ (class "form-control")
|
"Target commit" query-parameters
|
||||||
(style "font-family: monospace;")
|
#:required? #t
|
||||||
(id "inputBaseCommit")
|
#:help-text "The commit to compare against the base commit.")
|
||||||
(required #t)
|
,(form-horizontal-control
|
||||||
(aria-describedby "baseCommitHelp")
|
"System" query-parameters
|
||||||
(name "base_commit")
|
#:options valid-systems
|
||||||
(value ,base-commit)))
|
#:help-text "Only include derivations for this system.")
|
||||||
(span (@ (id "baseCommitHelp")
|
,(form-horizontal-control
|
||||||
(class "help-block"))
|
"Target" query-parameters
|
||||||
(strong "Required.")
|
#:options valid-systems
|
||||||
" The commit to use as the basis for the comparison.")))
|
#:help-text "Only include derivations that are build for this system.")
|
||||||
(div (@ (class "form-group form-group-lg"))
|
,(form-horizontal-control
|
||||||
(label (@ (for "inputTargetCommit")
|
"Build status" query-parameters
|
||||||
(class "col-sm-2 control-label"))
|
#:options valid-build-statuses
|
||||||
"Target commit")
|
#:help-text "Only include derivations which have this build status.")
|
||||||
(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-statuses)
|
|
||||||
'((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 "form-group form-group-lg"))
|
||||||
(div (@ (class "col-sm-offset-2 col-sm-10"))
|
(div (@ (class "col-sm-offset-2 col-sm-10"))
|
||||||
(button (@ (type "submit")
|
(button (@ (type "submit")
|
||||||
(class "btn btn-lg btn-primary"))
|
(class "btn btn-lg btn-primary"))
|
||||||
"Update results")))
|
"Update results")))
|
||||||
(a (@ (class "btn btn-default btn-lg pull-right")
|
(a (@ (class "btn btn-default btn-lg pull-right")
|
||||||
(href ,(string-append
|
(href ,(let ((query-parameter-string
|
||||||
"/compare/derivations.json" query-params)))
|
(query-parameters->string query-parameters)))
|
||||||
|
(string-append
|
||||||
|
"/compare/derivations.json"
|
||||||
|
(if (string-null? query-parameter-string)
|
||||||
|
""
|
||||||
|
(string-append "?" query-parameter-string))))))
|
||||||
"View JSON")))))
|
"View JSON")))))
|
||||||
(div
|
(div
|
||||||
(@ (class "row"))
|
(@ (class "row"))
|
||||||
(div
|
(div
|
||||||
(@ (class "col-sm-12"))
|
(@ (class "col-sm-12"))
|
||||||
(h3 "Base ("
|
(h3 "Base"
|
||||||
(samp ,base-commit)
|
,@(let ((base-commit (assq-ref query-parameters 'base_commit)))
|
||||||
")")
|
(if (string? base-commit)
|
||||||
|
`(" (" (samp ,base-commit) ")")
|
||||||
|
'())))
|
||||||
(p "Derivations found only in the base revision.")
|
(p "Derivations found only in the base revision.")
|
||||||
(table
|
(table
|
||||||
(@ (class "table"))
|
(@ (class "table"))
|
||||||
|
|
@ -1189,9 +1104,11 @@
|
||||||
(@ (class "row"))
|
(@ (class "row"))
|
||||||
(div
|
(div
|
||||||
(@ (class "col-sm-12"))
|
(@ (class "col-sm-12"))
|
||||||
(h3 "Target ("
|
(h3 "Target"
|
||||||
(samp ,target-commit)
|
,@(let ((target-commit (assq-ref query-parameters 'target_commit)))
|
||||||
")")
|
(if (string? target-commit)
|
||||||
|
`(" (" (samp ,target-commit) ")")
|
||||||
|
'())))
|
||||||
(p "Derivations found only in the target revision.")
|
(p "Derivations found only in the target revision.")
|
||||||
(table
|
(table
|
||||||
(@ (class "table"))
|
(@ (class "table"))
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue