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)

175
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
(unless invalid-query?
(string-append "?base_commit=" base-commit (string-append "?base_commit=" base-commit
"&target_commit=" target-commit "&target_commit=" target-commit
"&locale=" locale)) "&locale=" locale)))
(layout (layout
#:body #:body
@ -61,8 +66,10 @@
(div (div
(@ (class "row")) (@ (class "row"))
(div (div
(@ (class "col-sm-8")) (@ (class "col-sm-7"))
(h1 "Comparing " ,@(if invalid-query?
`((h1 "Compare"))
`((h1 "Comparing "
(a (@ (href ,(string-append "/revision/" base-commit))) (a (@ (href ,(string-append "/revision/" base-commit)))
(samp ,(string-take base-commit 8) "…")) (samp ,(string-take base-commit 8) "…"))
" and " " and "
@ -74,19 +81,27 @@
"log/?qt=range&q=" "log/?qt=range&q="
base-commit ".." target-commit))) base-commit ".." target-commit)))
"(View cgit)")) "(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,15 +162,30 @@
(button (@ (type "submit") (button (@ (type "submit")
(class "btn btn-lg btn-primary")) (class "btn btn-lg btn-primary"))
"Update results"))))))) "Update results")))))))
(div
,@(if
invalid-query?
'()
`((div
(@ (class "row") (style "clear: left;")) (@ (class "row") (style "clear: left;"))
(div (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") (a (@ (class "btn btn-default btn-lg pull-right")
(href ,(string-append (href ,(string-append
"/compare.json" query-params))) "/compare.json" query-params)))
"View JSON"))) "View JSON")))
(div (div
(@ (class "row")) (@ (class "row"))
(div (div
@ -343,7 +386,7 @@
,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))
"."))))))