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-status)
|
||||||
#:use-module (guix-data-service model build)
|
#:use-module (guix-data-service model build)
|
||||||
#:use-module (guix-data-service model lint-checker)
|
#: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 jobs load-new-guix-revision)
|
||||||
#:use-module (guix-data-service web render)
|
#:use-module (guix-data-service web render)
|
||||||
#:use-module (guix-data-service web sxml)
|
#:use-module (guix-data-service web sxml)
|
||||||
|
|
@ -333,6 +334,84 @@
|
||||||
#:header-link header-link)
|
#:header-link header-link)
|
||||||
#:extra-headers http-headers-for-unchanging-content)))))
|
#: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
|
(define (render-compare-unknown-commit mime-types
|
||||||
conn
|
conn
|
||||||
base-commit
|
base-commit
|
||||||
|
|
@ -707,6 +786,27 @@
|
||||||
(render-unknown-revision mime-types
|
(render-unknown-revision mime-types
|
||||||
conn
|
conn
|
||||||
commit-hash)))
|
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)
|
(('GET "repository" id)
|
||||||
(match (select-git-repository conn id)
|
(match (select-git-repository conn id)
|
||||||
((label url cgit-url-base)
|
((label url cgit-url-base)
|
||||||
|
|
@ -797,6 +897,38 @@
|
||||||
(render-unknown-revision mime-types
|
(render-unknown-revision mime-types
|
||||||
conn
|
conn
|
||||||
commit-hash))))
|
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)
|
(('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "package" name version)
|
||||||
(let ((commit-hash
|
(let ((commit-hash
|
||||||
(latest-processed-commit-for-branch conn repository-id branch-name)))
|
(latest-processed-commit-for-branch conn repository-id branch-name)))
|
||||||
|
|
|
||||||
|
|
@ -35,6 +35,7 @@
|
||||||
view-revision-package-and-version
|
view-revision-package-and-version
|
||||||
view-revision
|
view-revision
|
||||||
view-revision-packages
|
view-revision-packages
|
||||||
|
view-revision-lint-warnings
|
||||||
view-git-repository
|
view-git-repository
|
||||||
view-branches
|
view-branches
|
||||||
view-branch
|
view-branch
|
||||||
|
|
@ -696,6 +697,148 @@
|
||||||
"Next page")))
|
"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
|
(define (table/branches-with-most-recent-commits
|
||||||
git-repository-id branches-with-most-recent-commits)
|
git-repository-id branches-with-most-recent-commits)
|
||||||
`(table
|
`(table
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue