Add a page to show the lint warnings for a revision
This commit is contained in:
parent
3544f9300f
commit
609c5cf4f0
2 changed files with 275 additions and 0 deletions
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue