From 609c5cf4f0da63d913f0dcc36828fe7c5d2b4090 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Sun, 1 Sep 2019 12:59:45 +0100 Subject: Add a page to show the lint warnings for a revision --- guix-data-service/web/controller.scm | 132 ++++++++++++++++++++++++++++++++ guix-data-service/web/view/html.scm | 143 +++++++++++++++++++++++++++++++++++ 2 files changed, 275 insertions(+) diff --git a/guix-data-service/web/controller.scm b/guix-data-service/web/controller.scm index 1ecdd19..f7cd42f 100644 --- a/guix-data-service/web/controller.scm +++ b/guix-data-service/web/controller.scm @@ -42,6 +42,7 @@ #:use-module (guix-data-service model build-status) #:use-module (guix-data-service model build) #:use-module (guix-data-service model lint-checker) + #:use-module (guix-data-service model lint-warning) #:use-module (guix-data-service jobs load-new-guix-revision) #:use-module (guix-data-service web render) #:use-module (guix-data-service web sxml) @@ -333,6 +334,84 @@ #:header-link header-link) #:extra-headers http-headers-for-unchanging-content))))) +(define* (render-revision-lint-warnings mime-types + conn + commit-hash + query-parameters + #:key + (path-base "/revision/") + (header-text + `("Revision " (samp ,commit-hash))) + (header-link + (string-append "/revision/" commit-hash))) + (if (any-invalid-query-parameters? query-parameters) + (case (most-appropriate-mime-type + '(application/json text/html) + mime-types) + ((application/json) + (render-json + `((error . "invalid query")))) + (else + (render-html + #:sxml (view-revision-lint-warnings commit-hash + query-parameters + '() + '() + #:path-base path-base + #:header-text header-text + #:header-link header-link)))) + + (let* ((package-query (assq-ref query-parameters 'package_query)) + (linters (assq-ref query-parameters 'linter)) + (message-query (assq-ref query-parameters 'message_query)) + (fields (assq-ref query-parameters 'field)) + (git-repositories + (git-repositories-containing-commit conn + commit-hash)) + (lint-warnings + (lint-warnings-for-guix-revision conn commit-hash + #:package-query package-query + #:linters linters + #:message-query message-query))) + (case (most-appropriate-mime-type + '(application/json text/html) + mime-types) + ((application/json) + (render-json + `((revision + . ((commit . ,commit-hash))) + (lint_warnings + . ,(list->vector + (map (match-lambda + ((id lint-checker-name lint-checker-description + lint-checker-network-dependent + package-name package-version + file line-number column-number + message) + `((package . ((name . ,package-name) + (version . ,package-version))) + ,@(if (member "message" fields) + `((message . ,message)) + '()) + ,@(if (member "location" fields) + `((location . ((file . ,file) + (line-number . ,line-number) + (column-number . ,column-number)))) + '())))) + lint-warnings)))) + #:extra-headers http-headers-for-unchanging-content)) + (else + (render-html + #:sxml (view-revision-lint-warnings commit-hash + query-parameters + lint-warnings + git-repositories + '() + #:path-base path-base + #:header-text header-text + #:header-link header-link) + #:extra-headers http-headers-for-unchanging-content)))))) + (define (render-compare-unknown-commit mime-types conn base-commit @@ -707,6 +786,27 @@ (render-unknown-revision mime-types conn commit-hash))) + (('GET "revision" commit-hash "lint-warnings") + (if (guix-commit-exists? conn commit-hash) + (let ((parsed-query-parameters + (parse-query-parameters + request + `((package_query ,identity) + (linter ,identity #:multi-value) + (message_query ,identity) + (field ,identity #:multi-value + #:default ("linter" + "message" + "location")))))) + + (render-revision-lint-warnings mime-types + conn + commit-hash + parsed-query-parameters + #:path-base path)) + (render-unknown-revision mime-types + conn + commit-hash))) (('GET "repository" id) (match (select-git-repository conn id) ((label url cgit-url-base) @@ -797,6 +897,38 @@ (render-unknown-revision mime-types conn commit-hash)))) + (('GET "repository" repository-id "branch" branch-name "latest-processed-revision" + "lint-warnings") + (let ((commit-hash + (latest-processed-commit-for-branch conn repository-id branch-name))) + (if commit-hash + (let ((parsed-query-parameters + (parse-query-parameters + request + `((package_query ,identity) + (linter ,identity #:multi-value) + (message_query ,identity) + (field ,identity #:multi-value + #:default ("linter" + "message" + "location")))))) + + (render-revision-lint-warnings mime-types + conn + commit-hash + parsed-query-parameters + #:path-base path + #:header-text + `("Latest processed revision for branch " + (samp ,branch-name)) + #:header-link + (string-append + "/repository/" repository-id + "/branch/" branch-name + "/latest-processed-revision"))) + (render-unknown-revision mime-types + conn + commit-hash)))) (('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "package" name version) (let ((commit-hash (latest-processed-commit-for-branch conn repository-id branch-name))) diff --git a/guix-data-service/web/view/html.scm b/guix-data-service/web/view/html.scm index b8cad39..3dc3e8f 100644 --- a/guix-data-service/web/view/html.scm +++ b/guix-data-service/web/view/html.scm @@ -35,6 +35,7 @@ view-revision-package-and-version view-revision view-revision-packages + view-revision-lint-warnings view-git-repository view-branches view-branch @@ -696,6 +697,148 @@ "Next page"))) '()))))) +(define* (view-revision-lint-warnings revision-commit-hash + query-parameters + lint-warnings + git-repositories + lint-checker-options + #:key path-base + header-text header-link) + (define field-options + (map + (lambda (field) + (cons field + (hyphenate-words + (string-downcase field)))) + '("Linter" "Message" "Location"))) + + (layout + #:body + `(,(header) + (div + (@ (class "container")) + (div + (@ (class "row")) + (div + (@ (class "col-sm-12")) + (h3 (a (@ (style "white-space: nowrap;") + (href ,header-link)) + ,@header-text)))) + (div + (@ (class "row")) + (div + (@ (class "col-md-12")) + (div + (@ (class "well")) + (form + (@ (method "get") + (action "") + (style "padding-bottom: 0") + (class "form-horizontal")) + ,(form-horizontal-control + "Package query" query-parameters + #:help-text + "Lint warnings where the package name matches the query.") + ;; TODO as there's not an easy way to find all the relevant lint checkers + ;; ,(form-horizontal-control + ;; "Linter" query-parameters + ;; #:options lint-checker-options + ;; #:help-text + ;; "Lint warnings for specific lint checkers.") + ,(form-horizontal-control + "Message query" query-parameters + #:help-text + "Lint warnings where the message matches the query.") + ,(form-horizontal-control + "Fields" query-parameters + #:name "field" + #:options field-options + #:help-text "Fields to return in the response.") + (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"))))))) + (div + (@ (class "row")) + (div + (@ (class "col-sm-12")) + (a (@ (class "btn btn-default btn-lg pull-right") + (href ,(let ((query-parameter-string + (query-parameters->string query-parameters))) + (string-append + path-base ".json" + (if (string-null? query-parameter-string) + "" + (string-append "?" query-parameter-string)))))) + "View JSON"))) + (div + (@ (class "row")) + (div + (@ (class "col-sm-12")) + (h1 "Lint warnings") + (table + (@ (class "table table-responsive")) + (thead + (tr + (th (@ (class "col-md-3")) "Package") + ,@(filter-map + (match-lambda + ((label . value) + (if (member value (assq-ref query-parameters 'field)) + `(th (@ (class "col-md-3")) ,label) + #f))) + field-options) + (th (@ (class "col-md-3")) ""))) + (tbody + ,@(let ((fields (assq-ref query-parameters 'field))) + (map + (match-lambda + ((id lint-checker-name lint-checker-description + lint-checker-network-dependent + package-name package-version file line-number column-number + message) + `(tr + (td ,package-name " @ " ,package-version) + ,@(if (member "linter" fields) + `((td (span (@ (style "font-family: monospace; display: block;")) + ,lint-checker-name) + (p (@ (style "font-size: small; margin: 6px 0 0px;")) + ,lint-checker-description))) + '()) + ,@(if (member "message" fields) + `((td ,message)) + '()) + ,@(if (member "location" fields) + `((td + ,@(if (and file (not (string-null? file))) + `((ul + ,@(map + (match-lambda + ((id label url cgit-url-base) + (let ((output + `(,file + " " + (span + (@ (style "white-space: nowrap")) + "(line: " ,line-number + ", column: " ,column-number ")")))) + (if + (and cgit-url-base + (not (string-null? cgit-url-base))) + `(li + (a (@ (href + ,(string-append + cgit-url-base "tree/" + file "?id=" revision-commit-hash + "#n" line-number))) + ,@output)) + `(li ,@output))))) + git-repositories))) + '()))) + '())))) + lint-warnings)))))))))) + (define (table/branches-with-most-recent-commits git-repository-id branches-with-most-recent-commits) `(table -- cgit v1.2.3