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

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

@ -32,6 +32,7 @@
compare-invalid-parameters)) compare-invalid-parameters))
(define (compare query-parameters (define (compare query-parameters
mode
cgit-url-bases cgit-url-bases
new-packages new-packages
removed-packages removed-packages
@ -39,6 +40,9 @@
lint-warnings-data lint-warnings-data
lint-warnings-locale-options lint-warnings-locale-options
channel-news-data) channel-news-data)
(define invalid-query?
(any-invalid-query-parameters? query-parameters))
(define base-commit (define base-commit
(assq-ref query-parameters 'base_commit)) (assq-ref query-parameters 'base_commit))
@ -49,9 +53,10 @@
(assq-ref query-parameters 'locale)) (assq-ref query-parameters 'locale))
(define query-params (define query-params
(string-append "?base_commit=" base-commit (unless invalid-query?
"&target_commit=" target-commit (string-append "?base_commit=" base-commit
"&locale=" locale)) "&target_commit=" target-commit
"&locale=" locale)))
(layout (layout
#:body #:body
@ -61,32 +66,42 @@
(div (div
(@ (class "row")) (@ (class "row"))
(div (div
(@ (class "col-sm-8")) (@ (class "col-sm-7"))
(h1 "Comparing " ,@(if invalid-query?
(a (@ (href ,(string-append "/revision/" base-commit))) `((h1 "Compare"))
(samp ,(string-take base-commit 8) "…")) `((h1 "Comparing "
" and " (a (@ (href ,(string-append "/revision/" base-commit)))
(a (@ (href ,(string-append "/revision/" target-commit))) (samp ,(string-take base-commit 8) "…"))
(samp ,(string-take target-commit 8) "…"))) " and "
,@(if (apply string=? cgit-url-bases) (a (@ (href ,(string-append "/revision/" target-commit)))
`((a (@ (href ,(string-append (samp ,(string-take target-commit 8) "…")))
(first cgit-url-bases) ,@(if (apply string=? cgit-url-bases)
"log/?qt=range&q=" `((a (@ (href ,(string-append
base-commit ".." target-commit))) (first cgit-url-bases)
"(View cgit)")) "log/?qt=range&q="
'())) base-commit ".." target-commit)))
"(View cgit)"))
'()))))
(div (div
(@ (class "col-sm-4")) (@ (class "col-sm-5"))
(div (div
(@ (class "btn-group-vertical btn-group-lg pull-right") (@ (class "btn-group btn-group-lg")
(style "margin-top: 2em;") (style "margin-top: 1.3rem; margin-bottom: 0.5rem;")
(role "group")) (role "group"))
(a (@ (class "btn btn-default") (a (@ (class ,(string-append
(href ,(string-append "/compare/packages" query-params))) "btn btn-default btn-lg"
"Compare packages") (if (eq? mode 'revision)
(a (@ (class "btn btn-default") " disabled"
(href ,(string-append "/compare/package-derivations" query-params))) "")))
"Compare package derivations")))) (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 (div
(@ (class "row")) (@ (class "row"))
@ -99,30 +114,43 @@
(action "") (action "")
(style "padding-bottom: 0") (style "padding-bottom: 0")
(class "form-horizontal")) (class "form-horizontal"))
,(form-horizontal-control ,@(cond
"" query-parameters ((eq? mode 'revision)
#:name "base_commit" (list
#:type "hidden") (form-horizontal-control
,(form-horizontal-control "Base commit" query-parameters
"" query-parameters #:required? #t
#:name "target_commit" #:help-text "The commit to use as the basis for the comparison."
#:type "hidden") #:font-family "monospace")
,(form-horizontal-control (form-horizontal-control
"" query-parameters "Target commit" query-parameters
#:name "base_branch" #:required? #t
#:type "hidden") #:help-text "The commit to compare against the base commit."
,(form-horizontal-control #:font-family "monospace")))
"" query-parameters ((eq? mode 'datetime)
#:name "base_datetime" (list
#:type "hidden") (form-horizontal-control
,(form-horizontal-control "Base branch" query-parameters
"" query-parameters #:required? #t
#:name "target_branch" #:help-text "The branch to compare from."
#:type "hidden") #:font-family "monospace")
,(form-horizontal-control (form-horizontal-control
"" query-parameters "Base datetime" query-parameters
#:name "target_datetime" #:required? #t
#:type "hidden") #: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 ,(form-horizontal-control
"Locale" query-parameters "Locale" query-parameters
#:name "locale" #:name "locale"
@ -134,216 +162,231 @@
(button (@ (type "submit") (button (@ (type "submit")
(class "btn btn-lg btn-primary")) (class "btn btn-lg btn-primary"))
"Update results"))))))) "Update results")))))))
(div
(@ (class "row") (style "clear: left;"))
(div
(@ (class "col-sm-12"))
(a (@ (class "btn btn-default btn-lg pull-right")
(href ,(string-append
"/compare.json" query-params)))
"View JSON")))
(div ,@(if
(@ (class "row")) invalid-query?
(div '()
(@ (class "col-sm-12")) `((div
(h3 (@ (style "clear: both;")) (@ (class "row") (style "clear: left;"))
"News entries") (div
,(if (null? channel-news-data) (@ (class "col-sm-6"))
"No news entry changes" (div
(map (@ (class "btn-group btn-group-lg")
(match-lambda (role "group"))
((commit tag title-text body-text change) (a (@ (class "btn btn-default")
`(div (href ,(string-append "/compare/packages" query-params)))
(h4 ,@(if (null? commit) "Compare packages")
'() (a (@ (class "btn btn-default")
`(("Commit: " (samp ,commit)))) (href ,(string-append "/compare/package-derivations"
,@(if (null? tag) query-params)))
'() "Compare package derivations")))
`(("Tag: " ,tag)))) (div
(table (@ (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
(@ (class "col-sm-12"))
(h3 (@ (style "clear: both;"))
"News entries")
,(if (null? channel-news-data)
"No news entry changes"
(map
(match-lambda
((commit tag title-text body-text change)
`(div
(h4 ,@(if (null? commit)
'()
`(("Commit: " (samp ,commit))))
,@(if (null? tag)
'()
`(("Tag: " ,tag))))
(table
(@ (class "table"))
(thead
(tr
(th (@ (class "col-sm-1")) "")
(th (@ (class "col-sm-1")) "Language")
(th (@ (class "col-sm-3")) "Title")
(th (@ (class "col-sm-7")) "Body"))
(tbody
,@(let ((languages
(sort
(delete-duplicates
(append (map car title-text)
(map car body-text)))
string<?)))
(map (lambda (lang index)
`(tr
,@(if (eq? index 0)
`((td (@ (rowspan ,(length languages)))
,(case change
((new) "New")
((removed) "Removed")
((changed) "Changed"))))
'())
(td ,lang)
(td ,(stexi->shtml
(texi-fragment->stexi
(assoc-ref title-text lang))))
(td ,
(stexi->shtml
(texi-fragment->stexi
(assoc-ref body-text lang))))))
languages
(iota (length languages))))))))))
channel-news-data))))
(div
(@ (class "row"))
(div
(@ (class "col-sm-12"))
(h3 "New packages")
,(if (null? new-packages)
'(p "No new packages")
`(table
(@ (class "table")) (@ (class "table"))
(thead (thead
(tr (tr
(th (@ (class "col-sm-1")) "") (th (@ (class "col-md-4")) "Name")
(th (@ (class "col-sm-1")) "Language") (th (@ (class "col-md-4")) "Version")
(th (@ (class "col-sm-3")) "Title") (th (@ (class "col-md-4")) "")))
(th (@ (class "col-sm-7")) "Body")) (tbody
(tbody ,@(map
,@(let ((languages (match-lambda
(sort ((('name . name)
(delete-duplicates ('version . version))
(append (map car title-text) `(tr
(map car body-text))) (td ,name)
string<?))) (td ,version)
(map (lambda (lang index) (td (@ (class "text-right"))
`(tr (a (@ (href ,(string-append
,@(if (eq? index 0) "/revision/" target-commit
`((td (@ (rowspan ,(length languages))) "/package/" name "/" version)))
,(case change "More information")))))
((new) "New") new-packages))))))
((removed) "Removed") (div
((changed) "Changed")))) (@ (class "row"))
'()) (div
(td ,lang) (@ (class "col-sm-12"))
(td ,(stexi->shtml (h3 "Removed packages")
(texi-fragment->stexi ,(if (null? removed-packages)
(assoc-ref title-text lang)))) '(p "No removed packages")
(td , `(table
(stexi->shtml (@ (class "table"))
(texi-fragment->stexi (thead
(assoc-ref body-text lang)))))) (tr
languages (th (@ (class "col-md-4")) "Name")
(iota (length languages)))))))))) (th (@ (class "col-md-4")) "Version")
channel-news-data)))) (th (@ (class "col-md-4")) "")))
(div (tbody
(@ (class "row")) ,@(map
(div (match-lambda
(@ (class "col-sm-12")) ((('name . name)
(h3 "New packages") ('version . version))
,(if (null? new-packages) `(tr
'(p "No new packages") (td ,name)
`(table (td ,version)
(@ (class "table")) (td (@ (class "text-right"))
(thead (a (@ (href ,(string-append
(tr "/revision/" base-commit
(th (@ (class "col-md-4")) "Name") "/package/" name "/" version)))
(th (@ (class "col-md-4")) "Version") "More information")))))
(th (@ (class "col-md-4")) ""))) removed-packages))))))
(tbody (div
,@(map (@ (class "row"))
(match-lambda (div
((('name . name) (@ (class "col-sm-12"))
('version . version)) (h3 "Version changes")
`(tr ,(if
(td ,name) (null? version-changes)
(td ,version) '(p "No version changes")
(td (@ (class "text-right")) `(table
(a (@ (href ,(string-append (@ (class "table"))
"/revision/" target-commit (thead
"/package/" name "/" version))) (tr
"More information"))))) (th (@ (class "col-md-3")) "Name")
new-packages)))))) (th (@ (class "col-md-9")) "Versions")))
(div (tbody
(@ (class "row")) ,@(map
(div (match-lambda
(@ (class "col-sm-12")) ((name . versions)
(h3 "Removed packages") `(tr
,(if (null? removed-packages) (td ,name)
'(p "No removed packages") (td
`(table (ul
(@ (class "table")) (@ (class "list-unstyled"))
(thead ,@(map
(tr (match-lambda
(th (@ (class "col-md-4")) "Name") ((type . versions)
(th (@ (class "col-md-4")) "Version") `(li (@ (class ,(if (eq? type 'base)
(th (@ (class "col-md-4")) ""))) "text-danger"
(tbody "text-success")))
,@(map (ul
(match-lambda (@ (class "list-inline")
((('name . name) (style "display: inline-block;"))
('version . version)) ,@(map
`(tr (lambda (version)
(td ,name) `(li (a (@ (href
(td ,version) ,(string-append
(td (@ (class "text-right")) "/revision/"
(a (@ (href ,(string-append (if (eq? type 'base)
"/revision/" base-commit base-commit
"/package/" name "/" version))) target-commit)
"More information"))))) "/package/"
removed-packages)))))) name "/" version)))
(div ,version)))
(@ (class "row")) (vector->list versions)))
(div ,(if (eq? type 'base)
(@ (class "col-sm-12")) " (old)"
(h3 "Version changes") " (new)"))))
,(if versions))))))
(null? version-changes) version-changes))))))
'(p "No version changes") (div
`(table (@ (class "row"))
(@ (class "table")) (div
(thead (@ (class "col-sm-12"))
(tr (h2 "Lint warnings")
(th (@ (class "col-md-3")) "Name") ,@(if
(th (@ (class "col-md-9")) "Versions"))) (null? lint-warnings-data)
(tbody '((p "No lint warning changes"))
,@(map (map
(match-lambda (match-lambda
((name . versions) (((package-name package-version) . warnings)
`(tr `((h4 ,package-name " (version: " ,package-version ")")
(td ,name) (table
(td (@ (class "table"))
(ul (thead
(@ (class "list-unstyled")) (tr
,@(map (th "")
(match-lambda (th "Linter")
((type . versions) (th "Message")))
`(li (@ (class ,(if (eq? type 'base) (tbody
"text-danger" ,@(map (match-lambda
"text-success"))) ((lint-checker-name
(ul message
(@ (class "list-inline") lint-checker-description
(style "display: inline-block;")) lint-checker-network-dependent
,@(map file line column-number ;; TODO Maybe use the location?
(lambda (version) change)
`(li (a (@ (href
,(string-append
"/revision/"
(if (eq? type 'base)
base-commit
target-commit)
"/package/"
name "/" version)))
,version)))
(vector->list versions)))
,(if (eq? type 'base)
" (old)"
" (new)"))))
versions))))))
version-changes))))))
(div
(@ (class "row"))
(div
(@ (class "col-sm-12"))
(h2 "Lint warnings")
,@(if
(null? lint-warnings-data)
'((p "No lint warning changes"))
(map
(match-lambda
(((package-name package-version) . warnings)
`((h4 ,package-name " (version: " ,package-version ")")
(table
(@ (class "table"))
(thead
(tr
(th "")
(th "Linter")
(th "Message")))
(tbody
,@(map (match-lambda
((lint-checker-name
message
lint-checker-description
lint-checker-network-dependent
file line column-number ;; TODO Maybe use the location?
change)
`(tr `(tr
(td (@ (class ,(if (string=? change "new") (td (@ (class ,(if (string=? change "new")
"text-danger" "text-danger"
"text-success")) "text-success"))
(style "font-weight: bold")) (style "font-weight: bold"))
,(if (string=? change "new") ,(if (string=? change "new")
"New warning" "New warning"
"Resolved warning")) "Resolved warning"))
(td (span (@ (style "font-family: monospace; display: block;")) (td (span (@ (style "font-family: monospace; display: block;"))
,lint-checker-name) ,lint-checker-name)
(p (@ (style "font-size: small; margin: 6px 0 0px;")) (p (@ (style "font-size: small; margin: 6px 0 0px;"))
,lint-checker-description)) ,lint-checker-description))
(td ,message)))) (td ,message))))
warnings)))))) warnings))))))
lint-warnings-data)))))))) lint-warnings-data))))))))))
(define (compare/derivation query-parameters data) (define (compare/derivation query-parameters data)
(define base (define base
@ -1077,53 +1120,3 @@ enough builds to determine a change")))
(map (lambda (data) (map (lambda (data)
(take data 2)) (take data 2))
(vlist->list target-packages-vhash)))))))))))) (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))
"."))))))