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:
Christopher Baines
parent
512a583fa7
commit
640fb8a2ad
|
|
@ -141,13 +141,7 @@
|
|||
|
||||
(define (render-compare/derivations content-type
|
||||
conn
|
||||
base-commit
|
||||
base-revision-id
|
||||
target-commit
|
||||
target-revision-id
|
||||
systems
|
||||
targets
|
||||
build-statuses)
|
||||
query-parameters)
|
||||
(define (derivations->alist derivations)
|
||||
(map (match-lambda
|
||||
((file-name system target buildstatus)
|
||||
|
|
@ -159,49 +153,64 @@
|
|||
buildstatus)))))
|
||||
derivations))
|
||||
|
||||
(let-values
|
||||
(((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)))
|
||||
(if (any-invalid-query-parameters? query-parameters)
|
||||
(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))))))))
|
||||
'((error . "invalid query"))))
|
||||
(else
|
||||
(apply render-html
|
||||
(compare/derivations
|
||||
query-parameters
|
||||
(valid-systems conn)
|
||||
build-status-strings
|
||||
base-commit
|
||||
target-commit
|
||||
base-derivations
|
||||
target-derivations
|
||||
systems
|
||||
targets
|
||||
build-statuses)))))))
|
||||
'()
|
||||
'()))))
|
||||
|
||||
(let ((base-commit (assq-ref query-parameters 'base_commit))
|
||||
(target-commit (assq-ref query-parameters 'target_commit))
|
||||
(systems (assq-ref query-parameters 'system))
|
||||
(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
|
||||
conn
|
||||
|
|
@ -280,6 +289,19 @@
|
|||
conn output-id))))
|
||||
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 query-parameters
|
||||
(-> request
|
||||
|
|
@ -408,51 +430,29 @@
|
|||
target-commit
|
||||
target-revision-id)))))
|
||||
((GET "compare" "derivations")
|
||||
(with-base-and-target-commits
|
||||
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
|
||||
conn
|
||||
base-commit
|
||||
base-revision-id
|
||||
target-commit
|
||||
target-revision-id)
|
||||
(render-compare/derivations 'html
|
||||
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"))))))
|
||||
(let* ((parsed-query-parameters
|
||||
(parse-query-parameters
|
||||
request
|
||||
`((base_commit ,(parse-commit conn) #:required)
|
||||
(target_commit ,(parse-commit conn) #:required)
|
||||
(system ,parse-system #:multi-value)
|
||||
(target ,parse-system #:multi-value)
|
||||
(build_status ,parse-build-status #:multi-value)))))
|
||||
(render-compare/derivations 'html
|
||||
conn
|
||||
parsed-query-parameters)))
|
||||
((GET "compare" "derivations.json")
|
||||
(with-base-and-target-commits
|
||||
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
|
||||
conn
|
||||
base-commit
|
||||
base-revision-id
|
||||
target-commit
|
||||
target-revision-id)
|
||||
(render-compare/derivations 'json
|
||||
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"))))))
|
||||
(let* ((parsed-query-parameters
|
||||
(parse-query-parameters
|
||||
request
|
||||
`((base_commit ,(parse-commit conn) #:required)
|
||||
(target_commit ,(parse-commit conn) #:required)
|
||||
(system ,parse-system #:multi-value)
|
||||
(target ,parse-system #:multi-value)
|
||||
(build_status ,parse-build-status #:multi-value)))))
|
||||
(render-compare/derivations 'json
|
||||
conn
|
||||
parsed-query-parameters)))
|
||||
((GET "compare" "packages")
|
||||
(with-base-and-target-commits
|
||||
query-parameters conn
|
||||
|
|
|
|||
|
|
@ -1005,35 +1005,11 @@
|
|||
(cdr data-columns))))))
|
||||
(vector->list derivation-changes)))))))))))
|
||||
|
||||
(define (compare/derivations valid-systems
|
||||
(define (compare/derivations query-parameters
|
||||
valid-systems
|
||||
valid-build-statuses
|
||||
base-commit
|
||||
target-commit
|
||||
base-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))
|
||||
"&")))
|
||||
|
||||
target-derivations)
|
||||
(layout
|
||||
#:extra-headers
|
||||
'((cache-control . ((max-age . 60))))
|
||||
|
|
@ -1043,10 +1019,14 @@
|
|||
(@ (class "container"))
|
||||
(div
|
||||
(@ (class "row"))
|
||||
(h1 "Comparing "
|
||||
(samp ,(string-take base-commit 8) "…")
|
||||
" and "
|
||||
(samp ,(string-take target-commit 8) "…")))
|
||||
(h1 ,@(let ((base-commit (assq-ref query-parameters 'base_commit))
|
||||
(target-commit (assq-ref query-parameters 'target_commit)))
|
||||
(if (every string? (list base-commit target-commit))
|
||||
`("Comparing "
|
||||
(samp ,(string-take base-commit 8) "…")
|
||||
" and "
|
||||
(samp ,(string-take target-commit 8) "…"))
|
||||
'("Comparing derivations")))))
|
||||
(div
|
||||
(@ (class "row"))
|
||||
(div
|
||||
|
|
@ -1057,114 +1037,49 @@
|
|||
(@ (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-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.")))
|
||||
,(form-horizontal-control
|
||||
"Base commit" query-parameters
|
||||
#:required? #t
|
||||
#:help-text "The commit to use as the basis for the comparison.")
|
||||
,(form-horizontal-control
|
||||
"Target commit" query-parameters
|
||||
#:required? #t
|
||||
#:help-text "The commit to compare against the base commit.")
|
||||
,(form-horizontal-control
|
||||
"System" query-parameters
|
||||
#:options valid-systems
|
||||
#:help-text "Only include derivations for this system.")
|
||||
,(form-horizontal-control
|
||||
"Target" query-parameters
|
||||
#:options valid-systems
|
||||
#:help-text "Only include derivations that are build for this system.")
|
||||
,(form-horizontal-control
|
||||
"Build status" query-parameters
|
||||
#:options valid-build-statuses
|
||||
#:help-text "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)))
|
||||
(href ,(let ((query-parameter-string
|
||||
(query-parameters->string query-parameters)))
|
||||
(string-append
|
||||
"/compare/derivations.json"
|
||||
(if (string-null? query-parameter-string)
|
||||
""
|
||||
(string-append "?" query-parameter-string))))))
|
||||
"View JSON")))))
|
||||
(div
|
||||
(@ (class "row"))
|
||||
(div
|
||||
(@ (class "col-sm-12"))
|
||||
(h3 "Base ("
|
||||
(samp ,base-commit)
|
||||
")")
|
||||
(h3 "Base"
|
||||
,@(let ((base-commit (assq-ref query-parameters 'base_commit)))
|
||||
(if (string? base-commit)
|
||||
`(" (" (samp ,base-commit) ")")
|
||||
'())))
|
||||
(p "Derivations found only in the base revision.")
|
||||
(table
|
||||
(@ (class "table"))
|
||||
|
|
@ -1189,9 +1104,11 @@
|
|||
(@ (class "row"))
|
||||
(div
|
||||
(@ (class "col-sm-12"))
|
||||
(h3 "Target ("
|
||||
(samp ,target-commit)
|
||||
")")
|
||||
(h3 "Target"
|
||||
,@(let ((target-commit (assq-ref query-parameters 'target_commit)))
|
||||
(if (string? target-commit)
|
||||
`(" (" (samp ,target-commit) ")")
|
||||
'())))
|
||||
(p "Derivations found only in the target revision.")
|
||||
(table
|
||||
(@ (class "table"))
|
||||
|
|
|
|||
Loading…
Reference in New Issue