cbaines/guix-data-service
1
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Improve the comparison page interface

Browse source 
Try to unify the code for the different comparison modes, so that there's less
of it.
This commit is contained in:
Christopher Baines 2020-11-21 18:37:19 +00:00
parent 8cafd93f22
commit 7321ce4408
2 changed files with 318 additions and 313 deletions
Download patch file Download diff file Expand all files Collapse all files

28
guix-data-service/web/compare/controller.scm
View file

@ -203,10 +203,15 @@
(target_job . ,target-job))))
(else
(render-html
#:sxml (compare-invalid-parameters
query-parameters
base-job
target-job)))))
#:sxml (compare query-parameters
'revision
#f
#f
#f
#f
#f
#f
#f)))))
(letpar& ((base-revision-id
(with-thread-postgresql-connection
(lambda (conn)
@ -319,6 +324,7 @@
target-revision-id))))))
(render-html
#:sxml (compare query-parameters
'revision
cgit-url-bases
new-packages
removed-packages
@ -353,10 +359,15 @@
(select-job-for-commit conn value))))
(_ #f))))
(render-html
#:sxml (compare-invalid-parameters
query-parameters
base-job
target-job)))))
#:sxml (compare query-parameters
'datetime
#f
#f
#f
#f
#f
#f
#f)))))
(let ((base-branch (assq-ref query-parameters 'base_branch))
(base-datetime (assq-ref query-parameters 'base_datetime))
@ -471,6 +482,7 @@
#:sxml (compare `(,@query-parameters
(base_commit . ,(second base-revision-details))
(target_commit . ,(second target-revision-details)))
'datetime
(parallel-via-thread-pool-channel
(with-thread-postgresql-connection
(lambda (conn)

175
guix-data-service/web/compare/html.scm
View file

@ -32,6 +32,7 @@
compare-invalid-parameters))
(define (compare query-parameters
mode
cgit-url-bases
new-packages
removed-packages
@ -39,6 +40,9 @@
lint-warnings-data
lint-warnings-locale-options
channel-news-data)
(define invalid-query?
(any-invalid-query-parameters? query-parameters))
(define base-commit
(assq-ref query-parameters 'base_commit))
@ -49,9 +53,10 @@
(assq-ref query-parameters 'locale))
(define query-params
(unless invalid-query?
(string-append "?base_commit=" base-commit
"&target_commit=" target-commit
"&locale=" locale))
"&locale=" locale)))
(layout
#:body
@ -61,8 +66,10 @@
(div
(@ (class "row"))
(div
(@ (class "col-sm-8"))
(h1 "Comparing "
(@ (class "col-sm-7"))
,@(if invalid-query?
`((h1 "Compare"))
`((h1 "Comparing "
(a (@ (href ,(string-append "/revision/" base-commit)))
(samp ,(string-take base-commit 8) "…"))
" and "
@ -74,19 +81,27 @@
"log/?qt=range&q="
base-commit ".." target-commit)))
"(View cgit)"))
'()))
'()))))
(div
(@ (class "col-sm-4"))
(@ (class "col-sm-5"))
(div
(@ (class "btn-group-vertical btn-group-lg pull-right")
(style "margin-top: 2em;")
(@ (class "btn-group btn-group-lg")
(style "margin-top: 1.3rem; margin-bottom: 0.5rem;")
(role "group"))
(a (@ (class "btn btn-default")
(href ,(string-append "/compare/packages" query-params)))
"Compare packages")
(a (@ (class "btn btn-default")
(href ,(string-append "/compare/package-derivations" query-params)))
"Compare package derivations"))))
(a (@ (class ,(string-append
"btn btn-default btn-lg"
(if (eq? mode 'revision)
" disabled"
"")))
(href "/compare"))
"Compare revisions")
(a (@ (class ,(string-append
"btn btn-default btn-lg"
(if (eq? mode 'datetime)
" disabled"
"")))
(href "/compare-by-datetime"))
"Compare by datetime"))))
(div
(@ (class "row"))
@ -99,30 +114,43 @@
(action "")
(style "padding-bottom: 0")
(class "form-horizontal"))
,(form-horizontal-control
"" query-parameters
#:name "base_commit"
#:type "hidden")
,(form-horizontal-control
"" query-parameters
#:name "target_commit"
#:type "hidden")
,(form-horizontal-control
"" query-parameters
#:name "base_branch"
#:type "hidden")
,(form-horizontal-control
"" query-parameters
#:name "base_datetime"
#:type "hidden")
,(form-horizontal-control
"" query-parameters
#:name "target_branch"
#:type "hidden")
,(form-horizontal-control
"" query-parameters
#:name "target_datetime"
#:type "hidden")
,@(cond
((eq? mode 'revision)
(list
(form-horizontal-control
"Base commit" query-parameters
#:required? #t
#:help-text "The commit to use as the basis for the comparison."
#:font-family "monospace")
(form-horizontal-control
"Target commit" query-parameters
#:required? #t
#:help-text "The commit to compare against the base commit."
#:font-family "monospace")))
((eq? mode 'datetime)
(list
(form-horizontal-control
"Base branch" query-parameters
#:required? #t
#:help-text "The branch to compare from."
#:font-family "monospace")
(form-horizontal-control
"Base datetime" query-parameters
#:required? #t
#:help-text "The date and time to compare from."
#:font-family "monospace")
(form-horizontal-control
"Target branch" query-parameters
#:required? #t
#:help-text "The branch to compare to."
#:font-family "monospace")
(form-horizontal-control
"Target datetime" query-parameters
#:required? #t
#:help-text "The date and time to compare to."
#:font-family "monospace")))
(else
'()))
,(form-horizontal-control
"Locale" query-parameters
#:name "locale"
@ -134,15 +162,30 @@
(button (@ (type "submit")
(class "btn btn-lg btn-primary"))
"Update results")))))))
(div
,@(if
invalid-query?
'()
`((div
(@ (class "row") (style "clear: left;"))
(div
(@ (class "col-sm-12"))
(@ (class "col-sm-6"))
(div
(@ (class "btn-group btn-group-lg")
(role "group"))
(a (@ (class "btn btn-default")
(href ,(string-append "/compare/packages" query-params)))
"Compare packages")
(a (@ (class "btn btn-default")
(href ,(string-append "/compare/package-derivations"
query-params)))
"Compare package derivations")))
(div
(@ (class "col-sm-6"))
(a (@ (class "btn btn-default btn-lg pull-right")
(href ,(string-append
"/compare.json" query-params)))
"View JSON")))
(div
(@ (class "row"))
(div
@ -343,7 +386,7 @@
,lint-checker-description))
(td ,message))))
warnings))))))
lint-warnings-data))))))))
lint-warnings-data))))))))))
(define (compare/derivation query-parameters data)
(define base
@ -1077,53 +1120,3 @@ enough builds to determine a change")))
(map (lambda (data)
(take data 2))
(vlist->list target-packages-vhash))))))))))))
(define (compare-invalid-parameters query-parameters
base-job
target-job)
(define base-commit
(assq-ref query-parameters 'base_commit))
(define target-commit
(assq-ref query-parameters 'target_commit))
(define (description-for-state state)
(cond
((string=? state "queued")
" is queued for processing.")
((string=? state "failed")
" has failed.")
((string=? state "succeeded")
" has succeeded.")))
(layout
#:body
`(,(header)
(div (@ (class "container"))
(h1 "Unknown commit")
,(if base-job
`(p "Revision "
(a (@ (href
,(string-append
"/revision/"
(invalid-query-parameter-value base-commit))))
(strong (samp ,(invalid-query-parameter-value
base-commit))))
,(description-for-state
(assq-ref base-job 'state)))
`(p "No known revision with commit "
(strong (samp ,base-commit))
"."))
,(if target-job
`(p "Revision "
(a (@ (href
,(string-append
"/revision/"
(invalid-query-parameter-value target-commit))))
(strong (samp ,(invalid-query-parameter-value
target-commit))))
,(description-for-state
(assq-ref target-job 'state)))
`(p "No known revision with commit "
(strong (samp ,target-commit))
"."))))))