From 7321ce4408306e021d767597a7319d0b5130844e Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Sat, 21 Nov 2020 18:37:19 +0000 Subject: [PATCH] Improve the comparison page interface Try to unify the code for the different comparison modes, so that there's less of it. --- guix-data-service/web/compare/controller.scm | 28 +- guix-data-service/web/compare/html.scm | 603 +++++++++---------- 2 files changed, 318 insertions(+), 313 deletions(-) diff --git a/guix-data-service/web/compare/controller.scm b/guix-data-service/web/compare/controller.scm index 5edd922..0445961 100644 --- a/guix-data-service/web/compare/controller.scm +++ b/guix-data-service/web/compare/controller.scm @@ -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) diff --git a/guix-data-service/web/compare/html.scm b/guix-data-service/web/compare/html.scm index 46e7be0..23cafaf 100644 --- a/guix-data-service/web/compare/html.scm +++ b/guix-data-service/web/compare/html.scm @@ -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 - (string-append "?base_commit=" base-commit - "&target_commit=" target-commit - "&locale=" locale)) + (unless invalid-query? + (string-append "?base_commit=" base-commit + "&target_commit=" target-commit + "&locale=" locale))) (layout #:body @@ -61,32 +66,42 @@ (div (@ (class "row")) (div - (@ (class "col-sm-8")) - (h1 "Comparing " - (a (@ (href ,(string-append "/revision/" base-commit))) - (samp ,(string-take base-commit 8) "…")) - " and " - (a (@ (href ,(string-append "/revision/" target-commit))) - (samp ,(string-take target-commit 8) "…"))) - ,@(if (apply string=? cgit-url-bases) - `((a (@ (href ,(string-append - (first cgit-url-bases) - "log/?qt=range&q=" - base-commit ".." target-commit))) - "(View cgit)")) - '())) + (@ (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 " + (a (@ (href ,(string-append "/revision/" target-commit))) + (samp ,(string-take target-commit 8) "…"))) + ,@(if (apply string=? cgit-url-bases) + `((a (@ (href ,(string-append + (first cgit-url-bases) + "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,216 +162,231 @@ (button (@ (type "submit") (class "btn btn-lg btn-primary")) "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 - (@ (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 + ,@(if + invalid-query? + '() + `((div + (@ (class "row") (style "clear: left;")) + (div + (@ (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 + (@ (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))) + stringshtml + (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")) (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))) - stringshtml - (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")) - (thead - (tr - (th (@ (class "col-md-4")) "Name") - (th (@ (class "col-md-4")) "Version") - (th (@ (class "col-md-4")) ""))) - (tbody - ,@(map - (match-lambda - ((('name . name) - ('version . version)) - `(tr - (td ,name) - (td ,version) - (td (@ (class "text-right")) - (a (@ (href ,(string-append - "/revision/" target-commit - "/package/" name "/" version))) - "More information"))))) - new-packages)))))) - (div - (@ (class "row")) - (div - (@ (class "col-sm-12")) - (h3 "Removed packages") - ,(if (null? removed-packages) - '(p "No removed packages") - `(table - (@ (class "table")) - (thead - (tr - (th (@ (class "col-md-4")) "Name") - (th (@ (class "col-md-4")) "Version") - (th (@ (class "col-md-4")) ""))) - (tbody - ,@(map - (match-lambda - ((('name . name) - ('version . version)) - `(tr - (td ,name) - (td ,version) - (td (@ (class "text-right")) - (a (@ (href ,(string-append - "/revision/" base-commit - "/package/" name "/" version))) - "More information"))))) - removed-packages)))))) - (div - (@ (class "row")) - (div - (@ (class "col-sm-12")) - (h3 "Version changes") - ,(if - (null? version-changes) - '(p "No version changes") - `(table - (@ (class "table")) - (thead - (tr - (th (@ (class "col-md-3")) "Name") - (th (@ (class "col-md-9")) "Versions"))) - (tbody - ,@(map - (match-lambda - ((name . versions) - `(tr - (td ,name) - (td - (ul - (@ (class "list-unstyled")) - ,@(map - (match-lambda - ((type . versions) - `(li (@ (class ,(if (eq? type 'base) - "text-danger" - "text-success"))) - (ul - (@ (class "list-inline") - (style "display: inline-block;")) - ,@(map - (lambda (version) - `(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) + (th (@ (class "col-md-4")) "Name") + (th (@ (class "col-md-4")) "Version") + (th (@ (class "col-md-4")) ""))) + (tbody + ,@(map + (match-lambda + ((('name . name) + ('version . version)) + `(tr + (td ,name) + (td ,version) + (td (@ (class "text-right")) + (a (@ (href ,(string-append + "/revision/" target-commit + "/package/" name "/" version))) + "More information"))))) + new-packages)))))) + (div + (@ (class "row")) + (div + (@ (class "col-sm-12")) + (h3 "Removed packages") + ,(if (null? removed-packages) + '(p "No removed packages") + `(table + (@ (class "table")) + (thead + (tr + (th (@ (class "col-md-4")) "Name") + (th (@ (class "col-md-4")) "Version") + (th (@ (class "col-md-4")) ""))) + (tbody + ,@(map + (match-lambda + ((('name . name) + ('version . version)) + `(tr + (td ,name) + (td ,version) + (td (@ (class "text-right")) + (a (@ (href ,(string-append + "/revision/" base-commit + "/package/" name "/" version))) + "More information"))))) + removed-packages)))))) + (div + (@ (class "row")) + (div + (@ (class "col-sm-12")) + (h3 "Version changes") + ,(if + (null? version-changes) + '(p "No version changes") + `(table + (@ (class "table")) + (thead + (tr + (th (@ (class "col-md-3")) "Name") + (th (@ (class "col-md-9")) "Versions"))) + (tbody + ,@(map + (match-lambda + ((name . versions) + `(tr + (td ,name) + (td + (ul + (@ (class "list-unstyled")) + ,@(map + (match-lambda + ((type . versions) + `(li (@ (class ,(if (eq? type 'base) + "text-danger" + "text-success"))) + (ul + (@ (class "list-inline") + (style "display: inline-block;")) + ,@(map + (lambda (version) + `(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 - (td (@ (class ,(if (string=? change "new") - "text-danger" - "text-success")) - (style "font-weight: bold")) - ,(if (string=? change "new") - "New warning" - "Resolved warning")) - (td (span (@ (style "font-family: monospace; display: block;")) - ,lint-checker-name) - (p (@ (style "font-size: small; margin: 6px 0 0px;")) - ,lint-checker-description)) - (td ,message)))) - warnings)))))) - lint-warnings-data)))))))) + `(tr + (td (@ (class ,(if (string=? change "new") + "text-danger" + "text-success")) + (style "font-weight: bold")) + ,(if (string=? change "new") + "New warning" + "Resolved warning")) + (td (span (@ (style "font-family: monospace; display: block;")) + ,lint-checker-name) + (p (@ (style "font-size: small; margin: 6px 0 0px;")) + ,lint-checker-description)) + (td ,message)))) + warnings)))))) + 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)) - "."))))))