Add a page to show the lint warnings for a revision

2 files changed, 275 insertions, 0 deletions

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