Refactor the revision pages
Move the code to a more specific controller and html module. There's a lot of code related to the revision pages, and having it separated will help with refactoring it.
This commit is contained in:
parent
660df79a69
commit
49ea210382
4 changed files with 1218 additions and 1124 deletions
|
|
@ -28,7 +28,6 @@
|
||||||
#:use-module (web uri)
|
#:use-module (web uri)
|
||||||
#:use-module (texinfo)
|
#:use-module (texinfo)
|
||||||
#:use-module (texinfo html)
|
#:use-module (texinfo html)
|
||||||
#:use-module (texinfo plain-text)
|
|
||||||
#:use-module (squee)
|
#:use-module (squee)
|
||||||
#:use-module (json)
|
#:use-module (json)
|
||||||
#:use-module (guix-data-service config)
|
#:use-module (guix-data-service config)
|
||||||
|
|
@ -51,8 +50,10 @@
|
||||||
#:use-module (guix-data-service web sxml)
|
#:use-module (guix-data-service web sxml)
|
||||||
#:use-module (guix-data-service web query-parameters)
|
#:use-module (guix-data-service web query-parameters)
|
||||||
#:use-module (guix-data-service web util)
|
#:use-module (guix-data-service web util)
|
||||||
|
#:use-module (guix-data-service web revision controller)
|
||||||
#:use-module (guix-data-service web jobs controller)
|
#:use-module (guix-data-service web jobs controller)
|
||||||
#:use-module (guix-data-service web view html)
|
#:use-module (guix-data-service web view html)
|
||||||
|
#:use-module (guix-data-service web revision controller)
|
||||||
#:export (controller))
|
#:export (controller))
|
||||||
|
|
||||||
(define cache-control-default-max-age
|
(define cache-control-default-max-age
|
||||||
|
|
@ -89,375 +90,6 @@
|
||||||
value)))
|
value)))
|
||||||
alist))
|
alist))
|
||||||
|
|
||||||
(define* (render-view-revision mime-types
|
|
||||||
conn
|
|
||||||
commit-hash
|
|
||||||
#:key path-base
|
|
||||||
(header-text
|
|
||||||
`("Revision " (samp ,commit-hash))))
|
|
||||||
(let ((packages-count
|
|
||||||
(count-packages-in-revision conn commit-hash))
|
|
||||||
(git-repositories-and-branches
|
|
||||||
(git-branches-with-repository-details-for-commit conn commit-hash))
|
|
||||||
(derivations-counts
|
|
||||||
(count-packages-derivations-in-revision conn commit-hash))
|
|
||||||
(jobs-and-events
|
|
||||||
(select-jobs-and-events-for-commit conn commit-hash))
|
|
||||||
(lint-warning-counts
|
|
||||||
(lint-warning-count-by-lint-checker-for-revision conn commit-hash)))
|
|
||||||
(case (most-appropriate-mime-type
|
|
||||||
'(application/json text/html)
|
|
||||||
mime-types)
|
|
||||||
((application/json)
|
|
||||||
(render-json
|
|
||||||
`((packages_count . ,(caar packages-count))
|
|
||||||
(derivations_counts . ,(list->vector
|
|
||||||
(map (match-lambda
|
|
||||||
((system target derivation_count)
|
|
||||||
`((system . ,system)
|
|
||||||
(target . ,target)
|
|
||||||
(derivation_count . ,derivation_count))))
|
|
||||||
derivations-counts)))
|
|
||||||
(lint_warning_counts . ,(map (match-lambda
|
|
||||||
((name description network-dependent count)
|
|
||||||
`(,name . ((description . ,description)
|
|
||||||
(network_dependent . ,(string=? network-dependent "t"))
|
|
||||||
(count . ,(string->number count))))))
|
|
||||||
lint-warning-counts)))
|
|
||||||
#:extra-headers http-headers-for-unchanging-content))
|
|
||||||
(else
|
|
||||||
(render-html
|
|
||||||
#:sxml (view-revision
|
|
||||||
commit-hash
|
|
||||||
packages-count
|
|
||||||
git-repositories-and-branches
|
|
||||||
derivations-counts
|
|
||||||
jobs-and-events
|
|
||||||
lint-warning-counts
|
|
||||||
#:path-base path-base
|
|
||||||
#:header-text header-text)
|
|
||||||
#:extra-headers http-headers-for-unchanging-content)))))
|
|
||||||
|
|
||||||
(define (texinfo->variants-alist s)
|
|
||||||
(let ((stexi (texi-fragment->stexi s)))
|
|
||||||
`((source . ,s)
|
|
||||||
(html . ,(with-output-to-string
|
|
||||||
(lambda ()
|
|
||||||
(sxml->html (stexi->shtml stexi)))))
|
|
||||||
(plain . ,(stexi->plain-text stexi)))))
|
|
||||||
|
|
||||||
(define (render-unknown-revision mime-types conn commit-hash)
|
|
||||||
(case (most-appropriate-mime-type
|
|
||||||
'(application/json text/html)
|
|
||||||
mime-types)
|
|
||||||
((application/json)
|
|
||||||
(render-json
|
|
||||||
'((unknown_commit . ,commit-hash))
|
|
||||||
#:code 404))
|
|
||||||
(else
|
|
||||||
(render-html
|
|
||||||
#:code 404
|
|
||||||
#:sxml (unknown-revision
|
|
||||||
commit-hash
|
|
||||||
(select-job-for-commit
|
|
||||||
conn commit-hash)
|
|
||||||
(git-branches-with-repository-details-for-commit conn commit-hash)
|
|
||||||
(select-jobs-and-events-for-commit conn commit-hash))))))
|
|
||||||
|
|
||||||
|
|
||||||
(define* (render-revision-packages 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-packages commit-hash
|
|
||||||
query-parameters
|
|
||||||
'()
|
|
||||||
'()
|
|
||||||
#f
|
|
||||||
#:path-base path-base
|
|
||||||
#:header-text header-text
|
|
||||||
#:header-link header-link))))
|
|
||||||
|
|
||||||
(let* ((search-query (assq-ref query-parameters 'search_query))
|
|
||||||
(limit-results (or (assq-ref query-parameters 'limit_results)
|
|
||||||
99999)) ; TODO There shouldn't be a limit
|
|
||||||
(fields (assq-ref query-parameters 'field))
|
|
||||||
(packages
|
|
||||||
(if search-query
|
|
||||||
(search-packages-in-revision
|
|
||||||
conn
|
|
||||||
commit-hash
|
|
||||||
search-query
|
|
||||||
#:limit-results limit-results)
|
|
||||||
(select-packages-in-revision
|
|
||||||
conn
|
|
||||||
commit-hash
|
|
||||||
#:limit-results limit-results
|
|
||||||
#:after-name (assq-ref query-parameters 'after_name))))
|
|
||||||
(git-repositories
|
|
||||||
(git-repositories-containing-commit conn
|
|
||||||
commit-hash))
|
|
||||||
(show-next-page?
|
|
||||||
(and (not search-query)
|
|
||||||
(>= (length packages)
|
|
||||||
limit-results))))
|
|
||||||
(case (most-appropriate-mime-type
|
|
||||||
'(application/json text/html)
|
|
||||||
mime-types)
|
|
||||||
((application/json)
|
|
||||||
(render-json
|
|
||||||
`((revision
|
|
||||||
. ((commit . ,commit-hash)))
|
|
||||||
(packages
|
|
||||||
. ,(list->vector
|
|
||||||
(map (match-lambda
|
|
||||||
((name version synopsis description home-page
|
|
||||||
location-file location-line
|
|
||||||
location-column-number licenses)
|
|
||||||
`((name . ,name)
|
|
||||||
,@(if (member "version" fields)
|
|
||||||
`((version . ,version))
|
|
||||||
'())
|
|
||||||
,@(if (member "synopsis" fields)
|
|
||||||
`((synopsis
|
|
||||||
. ,(texinfo->variants-alist synopsis)))
|
|
||||||
'())
|
|
||||||
,@(if (member "description" fields)
|
|
||||||
`((description
|
|
||||||
. ,(texinfo->variants-alist description)))
|
|
||||||
'())
|
|
||||||
,@(if (member "home-page" fields)
|
|
||||||
`((home-page . ,home-page))
|
|
||||||
'())
|
|
||||||
,@(if (member "location" fields)
|
|
||||||
`((location
|
|
||||||
. ((file . ,location-file)
|
|
||||||
(line . ,location-line)
|
|
||||||
(column . ,location-column-number))))
|
|
||||||
'())
|
|
||||||
,@(if (member "licenses" fields)
|
|
||||||
`((licenses
|
|
||||||
. ,(if (string-null? licenses)
|
|
||||||
#()
|
|
||||||
(json-string->scm licenses))))
|
|
||||||
'()))))
|
|
||||||
packages))))
|
|
||||||
#:extra-headers http-headers-for-unchanging-content))
|
|
||||||
(else
|
|
||||||
(render-html
|
|
||||||
#:sxml (view-revision-packages commit-hash
|
|
||||||
query-parameters
|
|
||||||
packages
|
|
||||||
git-repositories
|
|
||||||
show-next-page?
|
|
||||||
#:path-base path-base
|
|
||||||
#:header-text header-text
|
|
||||||
#:header-link header-link)
|
|
||||||
#:extra-headers http-headers-for-unchanging-content))))))
|
|
||||||
|
|
||||||
(define* (render-revision-package mime-types
|
|
||||||
conn
|
|
||||||
commit-hash
|
|
||||||
name
|
|
||||||
#:key
|
|
||||||
(path-base "/revision/")
|
|
||||||
(header-text
|
|
||||||
`("Revision "
|
|
||||||
(samp ,commit-hash)))
|
|
||||||
(header-link
|
|
||||||
(string-append
|
|
||||||
"/revision/" commit-hash)))
|
|
||||||
(let ((package-versions
|
|
||||||
(select-package-versions-for-revision conn
|
|
||||||
commit-hash
|
|
||||||
name))
|
|
||||||
(git-repositories-and-branches
|
|
||||||
(git-branches-with-repository-details-for-commit conn
|
|
||||||
commit-hash)))
|
|
||||||
(case (most-appropriate-mime-type
|
|
||||||
'(application/json text/html)
|
|
||||||
mime-types)
|
|
||||||
((application/json)
|
|
||||||
(render-json
|
|
||||||
`((versions . ,(list->vector package-versions)))
|
|
||||||
#:extra-headers http-headers-for-unchanging-content))
|
|
||||||
(else
|
|
||||||
(render-html
|
|
||||||
#:sxml (view-revision-package commit-hash
|
|
||||||
name
|
|
||||||
package-versions
|
|
||||||
git-repositories-and-branches
|
|
||||||
#:path-base path-base
|
|
||||||
#:header-text header-text
|
|
||||||
#:header-link header-link)
|
|
||||||
#:extra-headers http-headers-for-unchanging-content)))))
|
|
||||||
|
|
||||||
(define* (render-revision-package-version mime-types
|
|
||||||
conn
|
|
||||||
commit-hash
|
|
||||||
name
|
|
||||||
version
|
|
||||||
#:key
|
|
||||||
(header-text
|
|
||||||
`("Revision "
|
|
||||||
(samp ,commit-hash)))
|
|
||||||
(header-link
|
|
||||||
(string-append
|
|
||||||
"/revision/" commit-hash)))
|
|
||||||
(let ((metadata
|
|
||||||
(select-package-metadata-by-revision-name-and-version
|
|
||||||
conn
|
|
||||||
commit-hash
|
|
||||||
name
|
|
||||||
version))
|
|
||||||
(derivations
|
|
||||||
(select-derivations-by-revision-name-and-version
|
|
||||||
conn
|
|
||||||
commit-hash
|
|
||||||
name
|
|
||||||
version))
|
|
||||||
(git-repositories
|
|
||||||
(git-repositories-containing-commit conn
|
|
||||||
commit-hash))
|
|
||||||
(lint-warnings
|
|
||||||
(select-lint-warnings-by-revision-package-name-and-version
|
|
||||||
conn
|
|
||||||
commit-hash
|
|
||||||
name
|
|
||||||
version)))
|
|
||||||
(case (most-appropriate-mime-type
|
|
||||||
'(application/json text/html)
|
|
||||||
mime-types)
|
|
||||||
((application/json)
|
|
||||||
(render-json
|
|
||||||
`((name . ,name)
|
|
||||||
(version . ,version)
|
|
||||||
,@(match metadata
|
|
||||||
(((synopsis description home-page))
|
|
||||||
`((synopsis . ,synopsis)
|
|
||||||
(description . ,description)
|
|
||||||
(home-page . ,home-page))))
|
|
||||||
(derivations . ,(list->vector
|
|
||||||
(map (match-lambda
|
|
||||||
((system target file-name status)
|
|
||||||
`((system . ,system)
|
|
||||||
(target . ,target)
|
|
||||||
(derivation . ,file-name))))
|
|
||||||
derivations))))
|
|
||||||
#:extra-headers http-headers-for-unchanging-content))
|
|
||||||
(else
|
|
||||||
(render-html
|
|
||||||
#:sxml (view-revision-package-and-version commit-hash
|
|
||||||
name
|
|
||||||
version
|
|
||||||
metadata
|
|
||||||
derivations
|
|
||||||
git-repositories
|
|
||||||
lint-warnings
|
|
||||||
#:header-text header-text
|
|
||||||
#: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)))
|
|
||||||
(define lint-checker-options
|
|
||||||
(map (match-lambda
|
|
||||||
((name description network-dependent)
|
|
||||||
(cons (string-append name ": " description )
|
|
||||||
name)))
|
|
||||||
(lint-checkers-for-revision conn 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
|
|
||||||
'()
|
|
||||||
lint-checker-options
|
|
||||||
#: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
|
|
||||||
lint-checker-options
|
|
||||||
#:path-base path-base
|
|
||||||
#:header-text header-text
|
|
||||||
#:header-link header-link)
|
|
||||||
#:extra-headers http-headers-for-unchanging-content))))))
|
|
||||||
|
|
||||||
(define (render-compare mime-types
|
(define (render-compare mime-types
|
||||||
conn
|
conn
|
||||||
query-parameters)
|
query-parameters)
|
||||||
|
|
@ -983,81 +615,8 @@
|
||||||
(render-html
|
(render-html
|
||||||
#:sxml (view-statistics (count-guix-revisions conn)
|
#:sxml (view-statistics (count-guix-revisions conn)
|
||||||
(count-derivations conn))))
|
(count-derivations conn))))
|
||||||
(('GET "revision" commit-hash) (if (guix-commit-exists? conn commit-hash)
|
(('GET "revision" args ...)
|
||||||
(render-view-revision mime-types
|
(delegate-to revision-controller))
|
||||||
conn
|
|
||||||
commit-hash
|
|
||||||
#:path-base path)
|
|
||||||
(render-unknown-revision mime-types
|
|
||||||
conn
|
|
||||||
commit-hash)))
|
|
||||||
(('GET "revision" commit-hash "packages")
|
|
||||||
(if (guix-commit-exists? conn commit-hash)
|
|
||||||
(let ((parsed-query-parameters
|
|
||||||
(guard-against-mutually-exclusive-query-parameters
|
|
||||||
(parse-query-parameters
|
|
||||||
request
|
|
||||||
`((after_name ,identity)
|
|
||||||
(field ,identity #:multi-value
|
|
||||||
#:default ("version" "synopsis"))
|
|
||||||
(search_query ,identity)
|
|
||||||
(limit_results ,parse-result-limit
|
|
||||||
#:no-default-when (all_results)
|
|
||||||
#:default 100)
|
|
||||||
(all_results ,parse-checkbox-value)))
|
|
||||||
;; You can't specify a search query, but then also limit the
|
|
||||||
;; results by filtering for after a particular package name
|
|
||||||
'((after_name search_query)
|
|
||||||
(limit_results all_results)))))
|
|
||||||
|
|
||||||
(render-revision-packages mime-types
|
|
||||||
conn
|
|
||||||
commit-hash
|
|
||||||
parsed-query-parameters
|
|
||||||
#:path-base path))
|
|
||||||
(render-unknown-revision mime-types
|
|
||||||
conn
|
|
||||||
commit-hash)))
|
|
||||||
(('GET "revision" commit-hash "package" name)
|
|
||||||
(if (guix-commit-exists? conn commit-hash)
|
|
||||||
(render-revision-package mime-types
|
|
||||||
conn
|
|
||||||
commit-hash
|
|
||||||
name)
|
|
||||||
(render-unknown-revision mime-types
|
|
||||||
conn
|
|
||||||
commit-hash)))
|
|
||||||
(('GET "revision" commit-hash "package" name version)
|
|
||||||
(if (guix-commit-exists? conn commit-hash)
|
|
||||||
(render-revision-package-version mime-types
|
|
||||||
conn
|
|
||||||
commit-hash
|
|
||||||
name
|
|
||||||
version)
|
|
||||||
(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)
|
(('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)
|
||||||
|
|
|
||||||
507
guix-data-service/web/revision/controller.scm
Normal file
507
guix-data-service/web/revision/controller.scm
Normal file
|
|
@ -0,0 +1,507 @@
|
||||||
|
;;; Guix Data Service -- Information about Guix over time
|
||||||
|
;;; Copyright © 2019 Christopher Baines <mail@cbaines.net>
|
||||||
|
;;;
|
||||||
|
;;; This program is free software: you can redistribute it and/or
|
||||||
|
;;; modify it under the terms of the GNU Affero General Public License
|
||||||
|
;;; as published by the Free Software Foundation, either version 3 of
|
||||||
|
;;; the License, or (at your option) any later version.
|
||||||
|
;;;
|
||||||
|
;;; This program is distributed in the hope that it will be useful,
|
||||||
|
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||||
|
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||||
|
;;; Affero General Public License for more details.
|
||||||
|
;;;
|
||||||
|
;;; You should have received a copy of the GNU Affero General Public
|
||||||
|
;;; License along with this program. If not, see
|
||||||
|
;;; <http://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
|
(define-module (guix-data-service web revision controller)
|
||||||
|
#:use-module (ice-9 match)
|
||||||
|
#:use-module (web uri)
|
||||||
|
#:use-module (web request)
|
||||||
|
#:use-module (texinfo)
|
||||||
|
#:use-module (texinfo html)
|
||||||
|
#:use-module (texinfo plain-text)
|
||||||
|
#:use-module (guix-data-service web render)
|
||||||
|
#:use-module (guix-data-service web sxml)
|
||||||
|
#:use-module (guix-data-service web query-parameters)
|
||||||
|
#:use-module (guix-data-service web util)
|
||||||
|
#:use-module (guix-data-service jobs load-new-guix-revision)
|
||||||
|
#:use-module (guix-data-service model package)
|
||||||
|
#:use-module (guix-data-service model git-branch)
|
||||||
|
#:use-module (guix-data-service model git-repository)
|
||||||
|
#:use-module (guix-data-service model derivation)
|
||||||
|
#:use-module (guix-data-service model package-derivation)
|
||||||
|
#:use-module (guix-data-service model package-metadata)
|
||||||
|
#:use-module (guix-data-service model lint-checker)
|
||||||
|
#:use-module (guix-data-service model lint-warning)
|
||||||
|
#:use-module (guix-data-service model guix-revision)
|
||||||
|
#:use-module (guix-data-service web revision html)
|
||||||
|
#:export (revision-controller
|
||||||
|
|
||||||
|
render-revision-lint-warnings
|
||||||
|
render-revision-package-version
|
||||||
|
render-revision-packages
|
||||||
|
render-unknown-revision
|
||||||
|
render-view-revision))
|
||||||
|
|
||||||
|
(define cache-control-default-max-age
|
||||||
|
(* 60 60 24)) ; One day
|
||||||
|
|
||||||
|
(define http-headers-for-unchanging-content
|
||||||
|
`((cache-control
|
||||||
|
. (public
|
||||||
|
(max-age . ,cache-control-default-max-age)))))
|
||||||
|
|
||||||
|
(define (revision-controller request
|
||||||
|
method-and-path-components
|
||||||
|
mime-types
|
||||||
|
body
|
||||||
|
conn)
|
||||||
|
(define path
|
||||||
|
(uri-path (request-uri request)))
|
||||||
|
|
||||||
|
(match method-and-path-components
|
||||||
|
(('GET "revision" commit-hash) (if (guix-commit-exists? conn commit-hash)
|
||||||
|
(render-view-revision mime-types
|
||||||
|
conn
|
||||||
|
commit-hash
|
||||||
|
#:path-base path)
|
||||||
|
(render-unknown-revision mime-types
|
||||||
|
conn
|
||||||
|
commit-hash)))
|
||||||
|
(('GET "revision" commit-hash "packages")
|
||||||
|
(if (guix-commit-exists? conn commit-hash)
|
||||||
|
(let ((parsed-query-parameters
|
||||||
|
(guard-against-mutually-exclusive-query-parameters
|
||||||
|
(parse-query-parameters
|
||||||
|
request
|
||||||
|
`((after_name ,identity)
|
||||||
|
(field ,identity #:multi-value
|
||||||
|
#:default ("version" "synopsis"))
|
||||||
|
(search_query ,identity)
|
||||||
|
(limit_results ,parse-result-limit
|
||||||
|
#:no-default-when (all_results)
|
||||||
|
#:default 100)
|
||||||
|
(all_results ,parse-checkbox-value)))
|
||||||
|
;; You can't specify a search query, but then also limit the
|
||||||
|
;; results by filtering for after a particular package name
|
||||||
|
'((after_name search_query)
|
||||||
|
(limit_results all_results)))))
|
||||||
|
|
||||||
|
(render-revision-packages mime-types
|
||||||
|
conn
|
||||||
|
commit-hash
|
||||||
|
parsed-query-parameters
|
||||||
|
#:path-base path))
|
||||||
|
(render-unknown-revision mime-types
|
||||||
|
conn
|
||||||
|
commit-hash)))
|
||||||
|
(('GET "revision" commit-hash "package" name)
|
||||||
|
(if (guix-commit-exists? conn commit-hash)
|
||||||
|
(render-revision-package mime-types
|
||||||
|
conn
|
||||||
|
commit-hash
|
||||||
|
name)
|
||||||
|
(render-unknown-revision mime-types
|
||||||
|
conn
|
||||||
|
commit-hash)))
|
||||||
|
(('GET "revision" commit-hash "package" name version)
|
||||||
|
(if (guix-commit-exists? conn commit-hash)
|
||||||
|
(render-revision-package-version mime-types
|
||||||
|
conn
|
||||||
|
commit-hash
|
||||||
|
name
|
||||||
|
version)
|
||||||
|
(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)))))
|
||||||
|
|
||||||
|
(define (texinfo->variants-alist s)
|
||||||
|
(let ((stexi (texi-fragment->stexi s)))
|
||||||
|
`((source . ,s)
|
||||||
|
(html . ,(with-output-to-string
|
||||||
|
(lambda ()
|
||||||
|
(sxml->html (stexi->shtml stexi)))))
|
||||||
|
(plain . ,(stexi->plain-text stexi)))))
|
||||||
|
|
||||||
|
(define (render-unknown-revision mime-types conn commit-hash)
|
||||||
|
(case (most-appropriate-mime-type
|
||||||
|
'(application/json text/html)
|
||||||
|
mime-types)
|
||||||
|
((application/json)
|
||||||
|
(render-json
|
||||||
|
'((unknown_commit . ,commit-hash))
|
||||||
|
#:code 404))
|
||||||
|
(else
|
||||||
|
(render-html
|
||||||
|
#:code 404
|
||||||
|
#:sxml (unknown-revision
|
||||||
|
commit-hash
|
||||||
|
(select-job-for-commit
|
||||||
|
conn commit-hash)
|
||||||
|
(git-branches-with-repository-details-for-commit conn commit-hash)
|
||||||
|
(select-jobs-and-events-for-commit conn commit-hash))))))
|
||||||
|
|
||||||
|
(define* (render-view-revision mime-types
|
||||||
|
conn
|
||||||
|
commit-hash
|
||||||
|
#:key path-base
|
||||||
|
(header-text
|
||||||
|
`("Revision " (samp ,commit-hash))))
|
||||||
|
(let ((packages-count
|
||||||
|
(count-packages-in-revision conn commit-hash))
|
||||||
|
(git-repositories-and-branches
|
||||||
|
(git-branches-with-repository-details-for-commit conn commit-hash))
|
||||||
|
(derivations-counts
|
||||||
|
(count-packages-derivations-in-revision conn commit-hash))
|
||||||
|
(jobs-and-events
|
||||||
|
(select-jobs-and-events-for-commit conn commit-hash))
|
||||||
|
(lint-warning-counts
|
||||||
|
(lint-warning-count-by-lint-checker-for-revision conn commit-hash)))
|
||||||
|
(case (most-appropriate-mime-type
|
||||||
|
'(application/json text/html)
|
||||||
|
mime-types)
|
||||||
|
((application/json)
|
||||||
|
(render-json
|
||||||
|
`((packages_count . ,(caar packages-count))
|
||||||
|
(derivations_counts . ,(list->vector
|
||||||
|
(map (match-lambda
|
||||||
|
((system target derivation_count)
|
||||||
|
`((system . ,system)
|
||||||
|
(target . ,target)
|
||||||
|
(derivation_count . ,derivation_count))))
|
||||||
|
derivations-counts)))
|
||||||
|
(lint_warning_counts . ,(map (match-lambda
|
||||||
|
((name description network-dependent count)
|
||||||
|
`(,name . ((description . ,description)
|
||||||
|
(network_dependent . ,(string=? network-dependent "t"))
|
||||||
|
(count . ,(string->number count))))))
|
||||||
|
lint-warning-counts)))
|
||||||
|
#:extra-headers http-headers-for-unchanging-content))
|
||||||
|
(else
|
||||||
|
(render-html
|
||||||
|
#:sxml (view-revision
|
||||||
|
commit-hash
|
||||||
|
packages-count
|
||||||
|
git-repositories-and-branches
|
||||||
|
derivations-counts
|
||||||
|
jobs-and-events
|
||||||
|
lint-warning-counts
|
||||||
|
#:path-base path-base
|
||||||
|
#:header-text header-text)
|
||||||
|
#:extra-headers http-headers-for-unchanging-content)))))
|
||||||
|
|
||||||
|
(define* (render-revision-packages 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-packages commit-hash
|
||||||
|
query-parameters
|
||||||
|
'()
|
||||||
|
'()
|
||||||
|
#f
|
||||||
|
#:path-base path-base
|
||||||
|
#:header-text header-text
|
||||||
|
#:header-link header-link))))
|
||||||
|
|
||||||
|
(let* ((search-query (assq-ref query-parameters 'search_query))
|
||||||
|
(limit-results (or (assq-ref query-parameters 'limit_results)
|
||||||
|
99999)) ; TODO There shouldn't be a limit
|
||||||
|
(fields (assq-ref query-parameters 'field))
|
||||||
|
(packages
|
||||||
|
(if search-query
|
||||||
|
(search-packages-in-revision
|
||||||
|
conn
|
||||||
|
commit-hash
|
||||||
|
search-query
|
||||||
|
#:limit-results limit-results)
|
||||||
|
(select-packages-in-revision
|
||||||
|
conn
|
||||||
|
commit-hash
|
||||||
|
#:limit-results limit-results
|
||||||
|
#:after-name (assq-ref query-parameters 'after_name))))
|
||||||
|
(git-repositories
|
||||||
|
(git-repositories-containing-commit conn
|
||||||
|
commit-hash))
|
||||||
|
(show-next-page?
|
||||||
|
(and (not search-query)
|
||||||
|
(>= (length packages)
|
||||||
|
limit-results))))
|
||||||
|
(case (most-appropriate-mime-type
|
||||||
|
'(application/json text/html)
|
||||||
|
mime-types)
|
||||||
|
((application/json)
|
||||||
|
(render-json
|
||||||
|
`((revision
|
||||||
|
. ((commit . ,commit-hash)))
|
||||||
|
(packages
|
||||||
|
. ,(list->vector
|
||||||
|
(map (match-lambda
|
||||||
|
((name version synopsis description home-page
|
||||||
|
location-file location-line
|
||||||
|
location-column-number licenses)
|
||||||
|
`((name . ,name)
|
||||||
|
,@(if (member "version" fields)
|
||||||
|
`((version . ,version))
|
||||||
|
'())
|
||||||
|
,@(if (member "synopsis" fields)
|
||||||
|
`((synopsis
|
||||||
|
. ,(texinfo->variants-alist synopsis)))
|
||||||
|
'())
|
||||||
|
,@(if (member "description" fields)
|
||||||
|
`((description
|
||||||
|
. ,(texinfo->variants-alist description)))
|
||||||
|
'())
|
||||||
|
,@(if (member "home-page" fields)
|
||||||
|
`((home-page . ,home-page))
|
||||||
|
'())
|
||||||
|
,@(if (member "location" fields)
|
||||||
|
`((location
|
||||||
|
. ((file . ,location-file)
|
||||||
|
(line . ,location-line)
|
||||||
|
(column . ,location-column-number))))
|
||||||
|
'())
|
||||||
|
,@(if (member "licenses" fields)
|
||||||
|
`((licenses
|
||||||
|
. ,(if (string-null? licenses)
|
||||||
|
#()
|
||||||
|
(json-string->scm licenses))))
|
||||||
|
'()))))
|
||||||
|
packages))))
|
||||||
|
#:extra-headers http-headers-for-unchanging-content))
|
||||||
|
(else
|
||||||
|
(render-html
|
||||||
|
#:sxml (view-revision-packages commit-hash
|
||||||
|
query-parameters
|
||||||
|
packages
|
||||||
|
git-repositories
|
||||||
|
show-next-page?
|
||||||
|
#:path-base path-base
|
||||||
|
#:header-text header-text
|
||||||
|
#:header-link header-link)
|
||||||
|
#:extra-headers http-headers-for-unchanging-content))))))
|
||||||
|
|
||||||
|
(define* (render-revision-package mime-types
|
||||||
|
conn
|
||||||
|
commit-hash
|
||||||
|
name
|
||||||
|
#:key
|
||||||
|
(path-base "/revision/")
|
||||||
|
(header-text
|
||||||
|
`("Revision "
|
||||||
|
(samp ,commit-hash)))
|
||||||
|
(header-link
|
||||||
|
(string-append
|
||||||
|
"/revision/" commit-hash)))
|
||||||
|
(let ((package-versions
|
||||||
|
(select-package-versions-for-revision conn
|
||||||
|
commit-hash
|
||||||
|
name))
|
||||||
|
(git-repositories-and-branches
|
||||||
|
(git-branches-with-repository-details-for-commit conn
|
||||||
|
commit-hash)))
|
||||||
|
(case (most-appropriate-mime-type
|
||||||
|
'(application/json text/html)
|
||||||
|
mime-types)
|
||||||
|
((application/json)
|
||||||
|
(render-json
|
||||||
|
`((versions . ,(list->vector package-versions)))
|
||||||
|
#:extra-headers http-headers-for-unchanging-content))
|
||||||
|
(else
|
||||||
|
(render-html
|
||||||
|
#:sxml (view-revision-package commit-hash
|
||||||
|
name
|
||||||
|
package-versions
|
||||||
|
git-repositories-and-branches
|
||||||
|
#:path-base path-base
|
||||||
|
#:header-text header-text
|
||||||
|
#:header-link header-link)
|
||||||
|
#:extra-headers http-headers-for-unchanging-content)))))
|
||||||
|
|
||||||
|
(define* (render-revision-package-version mime-types
|
||||||
|
conn
|
||||||
|
commit-hash
|
||||||
|
name
|
||||||
|
version
|
||||||
|
#:key
|
||||||
|
(header-text
|
||||||
|
`("Revision "
|
||||||
|
(samp ,commit-hash)))
|
||||||
|
(header-link
|
||||||
|
(string-append
|
||||||
|
"/revision/" commit-hash)))
|
||||||
|
(let ((metadata
|
||||||
|
(select-package-metadata-by-revision-name-and-version
|
||||||
|
conn
|
||||||
|
commit-hash
|
||||||
|
name
|
||||||
|
version))
|
||||||
|
(derivations
|
||||||
|
(select-derivations-by-revision-name-and-version
|
||||||
|
conn
|
||||||
|
commit-hash
|
||||||
|
name
|
||||||
|
version))
|
||||||
|
(git-repositories
|
||||||
|
(git-repositories-containing-commit conn
|
||||||
|
commit-hash))
|
||||||
|
(lint-warnings
|
||||||
|
(select-lint-warnings-by-revision-package-name-and-version
|
||||||
|
conn
|
||||||
|
commit-hash
|
||||||
|
name
|
||||||
|
version)))
|
||||||
|
(case (most-appropriate-mime-type
|
||||||
|
'(application/json text/html)
|
||||||
|
mime-types)
|
||||||
|
((application/json)
|
||||||
|
(render-json
|
||||||
|
`((name . ,name)
|
||||||
|
(version . ,version)
|
||||||
|
,@(match metadata
|
||||||
|
(((synopsis description home-page))
|
||||||
|
`((synopsis . ,synopsis)
|
||||||
|
(description . ,description)
|
||||||
|
(home-page . ,home-page))))
|
||||||
|
(derivations . ,(list->vector
|
||||||
|
(map (match-lambda
|
||||||
|
((system target file-name status)
|
||||||
|
`((system . ,system)
|
||||||
|
(target . ,target)
|
||||||
|
(derivation . ,file-name))))
|
||||||
|
derivations))))
|
||||||
|
#:extra-headers http-headers-for-unchanging-content))
|
||||||
|
(else
|
||||||
|
(render-html
|
||||||
|
#:sxml (view-revision-package-and-version commit-hash
|
||||||
|
name
|
||||||
|
version
|
||||||
|
metadata
|
||||||
|
derivations
|
||||||
|
git-repositories
|
||||||
|
lint-warnings
|
||||||
|
#:header-text header-text
|
||||||
|
#: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)))
|
||||||
|
(define lint-checker-options
|
||||||
|
(map (match-lambda
|
||||||
|
((name description network-dependent)
|
||||||
|
(cons (string-append name ": " description )
|
||||||
|
name)))
|
||||||
|
(lint-checkers-for-revision conn 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
|
||||||
|
'()
|
||||||
|
lint-checker-options
|
||||||
|
#: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
|
||||||
|
lint-checker-options
|
||||||
|
#:path-base path-base
|
||||||
|
#:header-text header-text
|
||||||
|
#:header-link header-link)
|
||||||
|
#:extra-headers http-headers-for-unchanging-content))))))
|
||||||
704
guix-data-service/web/revision/html.scm
Normal file
704
guix-data-service/web/revision/html.scm
Normal file
|
|
@ -0,0 +1,704 @@
|
||||||
|
;;; Guix Data Service -- Information about Guix over time
|
||||||
|
;;; Copyright © 2019 Christopher Baines <mail@cbaines.net>
|
||||||
|
;;;
|
||||||
|
;;; This program is free software: you can redistribute it and/or
|
||||||
|
;;; modify it under the terms of the GNU Affero General Public License
|
||||||
|
;;; as published by the Free Software Foundation, either version 3 of
|
||||||
|
;;; the License, or (at your option) any later version.
|
||||||
|
;;;
|
||||||
|
;;; This program is distributed in the hope that it will be useful,
|
||||||
|
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||||
|
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||||
|
;;; Affero General Public License for more details.
|
||||||
|
;;;
|
||||||
|
;;; You should have received a copy of the GNU Affero General Public
|
||||||
|
;;; License along with this program. If not, see
|
||||||
|
;;; <http://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
|
(define-module (guix-data-service web revision html)
|
||||||
|
#:use-module (srfi srfi-1)
|
||||||
|
#:use-module (ice-9 match)
|
||||||
|
#:use-module (texinfo)
|
||||||
|
#:use-module (texinfo html)
|
||||||
|
#:use-module (guix-data-service web util)
|
||||||
|
#:use-module (guix-data-service web query-parameters)
|
||||||
|
#:use-module (guix-data-service web view html)
|
||||||
|
#:export (view-revision-package
|
||||||
|
view-revision-package-and-version
|
||||||
|
view-revision
|
||||||
|
view-revision-packages
|
||||||
|
view-revision-lint-warnings))
|
||||||
|
|
||||||
|
(define* (view-revision-package revision-commit-hash
|
||||||
|
name
|
||||||
|
versions
|
||||||
|
git-repositories-and-branches
|
||||||
|
#:key path-base
|
||||||
|
header-text
|
||||||
|
header-link)
|
||||||
|
(layout
|
||||||
|
#:body
|
||||||
|
`(,(header)
|
||||||
|
(div
|
||||||
|
(@ (class "container"))
|
||||||
|
(div
|
||||||
|
(@ (class "row"))
|
||||||
|
(div
|
||||||
|
(@ (class "col-sm-12"))
|
||||||
|
(h3 (a (@ (href ,header-link))
|
||||||
|
,@header-text))))
|
||||||
|
(div
|
||||||
|
(@ (class "row"))
|
||||||
|
(div
|
||||||
|
(@ (class "col-sm-12"))
|
||||||
|
,(append-map
|
||||||
|
(match-lambda
|
||||||
|
(((id label url cgit-url-base) . branches)
|
||||||
|
(map (match-lambda
|
||||||
|
((branch-name datetime)
|
||||||
|
`(a (@ (class "btn btn-default btn-lg pull-right")
|
||||||
|
(href ,(simple-format
|
||||||
|
#f "/repository/~A/branch/~A/package/~A"
|
||||||
|
id branch-name name)))
|
||||||
|
,(simple-format #f "View ~A branch version history"
|
||||||
|
branch-name))))
|
||||||
|
branches)))
|
||||||
|
git-repositories-and-branches)
|
||||||
|
(h1 "Package " ,name)))
|
||||||
|
(div
|
||||||
|
(@ (class "row"))
|
||||||
|
(div
|
||||||
|
(@ (class "col-sm-12"))
|
||||||
|
(h3 "Versions")
|
||||||
|
(table
|
||||||
|
(@ (class "table"))
|
||||||
|
(thead
|
||||||
|
(tr
|
||||||
|
(th (@ (class "col-sm-10")) "Version")
|
||||||
|
(th (@ (class "col-sm-2")) "")))
|
||||||
|
(tbody
|
||||||
|
,@(map
|
||||||
|
(lambda (version)
|
||||||
|
`(tr
|
||||||
|
(td (samp ,version))
|
||||||
|
(td
|
||||||
|
(a (@ (href ,(string-append
|
||||||
|
path-base
|
||||||
|
revision-commit-hash
|
||||||
|
"/package/" name "/" version)))
|
||||||
|
"More information"))))
|
||||||
|
versions)))))))))
|
||||||
|
|
||||||
|
(define* (view-revision-package-and-version revision-commit-hash name version
|
||||||
|
package-metadata
|
||||||
|
derivations git-repositories
|
||||||
|
lint-warnings
|
||||||
|
#:key header-text
|
||||||
|
header-link)
|
||||||
|
(layout
|
||||||
|
#:body
|
||||||
|
`(,(header)
|
||||||
|
(div
|
||||||
|
(@ (class "container"))
|
||||||
|
(div
|
||||||
|
(@ (class "row"))
|
||||||
|
(div
|
||||||
|
(@ (class "col-sm-12"))
|
||||||
|
(h3 (a (@ (href ,header-link))
|
||||||
|
,@header-text))))
|
||||||
|
(div
|
||||||
|
(@ (class "row"))
|
||||||
|
(div
|
||||||
|
(@ (class "col-sm-12"))
|
||||||
|
(h1 "Package " ,name " @ " ,version)))
|
||||||
|
(div
|
||||||
|
(@ (class "row"))
|
||||||
|
(div
|
||||||
|
(@ (class "col-sm-12"))
|
||||||
|
,(match package-metadata
|
||||||
|
(((synopsis description home-page file line column-number
|
||||||
|
licenses))
|
||||||
|
`(dl
|
||||||
|
(@ (class "dl-horizontal"))
|
||||||
|
(dt "Synopsis")
|
||||||
|
(dd ,(stexi->shtml (texi-fragment->stexi synopsis)))
|
||||||
|
(dt "Description")
|
||||||
|
(dd ,(stexi->shtml (texi-fragment->stexi description)))
|
||||||
|
(dt "Home page")
|
||||||
|
(dd (a (@ (href ,home-page)) ,home-page))
|
||||||
|
,@(if (and file (not (string-null? file))
|
||||||
|
(not (null? git-repositories)))
|
||||||
|
`((dt "Location")
|
||||||
|
(dd ,@(map
|
||||||
|
(match-lambda
|
||||||
|
((id label url cgit-url-base)
|
||||||
|
(if
|
||||||
|
(and cgit-url-base
|
||||||
|
(not (string-null? cgit-url-base)))
|
||||||
|
`(a (@ (href
|
||||||
|
,(string-append
|
||||||
|
cgit-url-base "tree/"
|
||||||
|
file "?id=" revision-commit-hash
|
||||||
|
"#n" line)))
|
||||||
|
,file
|
||||||
|
" (line: " ,line
|
||||||
|
", column: " ,column-number ")")
|
||||||
|
'())))
|
||||||
|
git-repositories)))
|
||||||
|
'())
|
||||||
|
,@(if (> (vector-length licenses) 0)
|
||||||
|
`((dt ,(if (eq? (vector-length licenses) 1)
|
||||||
|
"License"
|
||||||
|
"Licenses"))
|
||||||
|
(dd (ul
|
||||||
|
,@(map (lambda (license)
|
||||||
|
`(li (a (@ (href ,(assoc-ref license "uri")))
|
||||||
|
,(assoc-ref license "name"))))
|
||||||
|
(vector->list licenses)))))
|
||||||
|
'()))))))
|
||||||
|
(div
|
||||||
|
(@ (class "row"))
|
||||||
|
(div
|
||||||
|
(@ (class "col-sm-12"))
|
||||||
|
(h3 "Derivations")
|
||||||
|
(table
|
||||||
|
(@ (class "table"))
|
||||||
|
(thead
|
||||||
|
(tr
|
||||||
|
(th "System")
|
||||||
|
(th "Target")
|
||||||
|
(th "Derivation")
|
||||||
|
(th "Build status")))
|
||||||
|
(tbody
|
||||||
|
,@(map
|
||||||
|
(match-lambda
|
||||||
|
((system target file-name status)
|
||||||
|
`(tr
|
||||||
|
(td (samp ,system))
|
||||||
|
(td (samp ,target))
|
||||||
|
(td (a (@ (href ,file-name))
|
||||||
|
,(display-store-item-short file-name)))
|
||||||
|
(td ,(build-status-span status)))))
|
||||||
|
derivations)))))
|
||||||
|
(div
|
||||||
|
(@ (class "row"))
|
||||||
|
(div
|
||||||
|
(@ (class "col-sm-12"))
|
||||||
|
(h3 "Lint warnings")
|
||||||
|
(table
|
||||||
|
(@ (class "table"))
|
||||||
|
(thead
|
||||||
|
(tr
|
||||||
|
(th "Linter")
|
||||||
|
(th "Message")
|
||||||
|
(th "Location")))
|
||||||
|
(tbody
|
||||||
|
,@(map
|
||||||
|
(match-lambda
|
||||||
|
((id lint-checker-name lint-checker-description
|
||||||
|
lint-checker-network-dependent
|
||||||
|
file line-number column-number
|
||||||
|
message)
|
||||||
|
`(tr
|
||||||
|
(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)
|
||||||
|
(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 (view-revision/git-repositories git-repositories-and-branches
|
||||||
|
commit-hash)
|
||||||
|
`((h3 "Git repositories")
|
||||||
|
,@(map
|
||||||
|
(match-lambda
|
||||||
|
(((id label url cgit-url-base) . branches)
|
||||||
|
`((a (@ (href ,(string-append
|
||||||
|
"/repository/" id)))
|
||||||
|
(h4 ,url))
|
||||||
|
,@(map
|
||||||
|
(match-lambda
|
||||||
|
((name datetime)
|
||||||
|
`(div
|
||||||
|
(a (@ (href ,(string-append "/repository/" id
|
||||||
|
"/branch/" name)))
|
||||||
|
,name)
|
||||||
|
" at " ,datetime
|
||||||
|
,@(if (string-null? cgit-url-base)
|
||||||
|
'()
|
||||||
|
`(" "
|
||||||
|
(a (@ (href ,(string-append
|
||||||
|
cgit-url-base
|
||||||
|
"commit/?id="
|
||||||
|
commit-hash)))
|
||||||
|
"(View cgit)"))))))
|
||||||
|
branches))))
|
||||||
|
git-repositories-and-branches)))
|
||||||
|
|
||||||
|
(define (view-revision/jobs-and-events jobs-and-events)
|
||||||
|
`((h3 "Jobs")
|
||||||
|
(table
|
||||||
|
(@ (class "table"))
|
||||||
|
(thead
|
||||||
|
(tr
|
||||||
|
(th "Source")
|
||||||
|
(th "Events")
|
||||||
|
(th "")))
|
||||||
|
(tbody
|
||||||
|
,@(map (match-lambda
|
||||||
|
((id commit source git-repository-id created-at succeeded-at
|
||||||
|
events log-exists?)
|
||||||
|
`(tr
|
||||||
|
(@ (class
|
||||||
|
,(let ((event-names
|
||||||
|
(map (lambda (event)
|
||||||
|
(assoc-ref event "event"))
|
||||||
|
(vector->list events))))
|
||||||
|
(cond
|
||||||
|
((member "success" event-names)
|
||||||
|
"success")
|
||||||
|
((member "failure" event-names)
|
||||||
|
"danger")
|
||||||
|
((member "start" event-names)
|
||||||
|
"info")
|
||||||
|
(else
|
||||||
|
""))))
|
||||||
|
(title ,(simple-format #f "Job id: ~A" id)))
|
||||||
|
(td ,source)
|
||||||
|
(td
|
||||||
|
(dl
|
||||||
|
,@(map
|
||||||
|
(lambda (event)
|
||||||
|
`((dt ,(assoc-ref event "event"))
|
||||||
|
(dd ,(assoc-ref event "occurred_at"))))
|
||||||
|
(cons
|
||||||
|
`(("event" . "created")
|
||||||
|
("occurred_at" . ,created-at))
|
||||||
|
(vector->list events)))))
|
||||||
|
(td
|
||||||
|
,@(if log-exists?
|
||||||
|
`((a (@ (href ,(string-append "/job/" id)))
|
||||||
|
"View log"))
|
||||||
|
'())))))
|
||||||
|
jobs-and-events)))))
|
||||||
|
|
||||||
|
(define (view-revision/lint-warning-counts path-base lint-warning-counts)
|
||||||
|
`((h3 "Lint warnings")
|
||||||
|
(a (@ (href ,(string-append path-base "/lint-warnings")))
|
||||||
|
"View lint warnings")
|
||||||
|
(table
|
||||||
|
(@ (class "table"))
|
||||||
|
(thead
|
||||||
|
(tr
|
||||||
|
(th "Linter")
|
||||||
|
(th "Count")))
|
||||||
|
(tbody
|
||||||
|
,@(map (match-lambda
|
||||||
|
((name description network-dependent count)
|
||||||
|
`(tr
|
||||||
|
(td (span (@ (style "font-family: monospace; display: block;"))
|
||||||
|
,name)
|
||||||
|
(p (@ (style "margin: 6px 0 0px;"))
|
||||||
|
,description))
|
||||||
|
(td ,count))))
|
||||||
|
lint-warning-counts)))))
|
||||||
|
|
||||||
|
(define* (view-revision commit-hash packages-count
|
||||||
|
git-repositories-and-branches derivations-count
|
||||||
|
jobs-and-events
|
||||||
|
lint-warning-counts
|
||||||
|
#:key (path-base "/revision/")
|
||||||
|
header-text)
|
||||||
|
(layout
|
||||||
|
#:body
|
||||||
|
`(,(header)
|
||||||
|
(div
|
||||||
|
(@ (class "container"))
|
||||||
|
(div
|
||||||
|
(@ (class "row"))
|
||||||
|
(div
|
||||||
|
(@ (class "col-md-12"))
|
||||||
|
(h1 (@ (style "white-space: nowrap;"))
|
||||||
|
,@header-text)))
|
||||||
|
(div
|
||||||
|
(@ (class "row"))
|
||||||
|
(div
|
||||||
|
(@ (class "col-md-6"))
|
||||||
|
(h2 "Packages")
|
||||||
|
(strong (@ (class "text-center")
|
||||||
|
(style "font-size: 2em; display: block;"))
|
||||||
|
,packages-count)
|
||||||
|
(a (@ (href ,(string-append path-base "/packages")))
|
||||||
|
"View packages")
|
||||||
|
|
||||||
|
,@(if (null? git-repositories-and-branches)
|
||||||
|
'()
|
||||||
|
(view-revision/git-repositories git-repositories-and-branches
|
||||||
|
commit-hash))
|
||||||
|
,@(view-revision/jobs-and-events jobs-and-events)
|
||||||
|
,@(view-revision/lint-warning-counts path-base
|
||||||
|
lint-warning-counts))
|
||||||
|
(div
|
||||||
|
(@ (class "col-md-6"))
|
||||||
|
(h3 "Derivations")
|
||||||
|
(table
|
||||||
|
(@ (class "table")
|
||||||
|
(style "white-space: nowrap;"))
|
||||||
|
(thead
|
||||||
|
(tr
|
||||||
|
(th "System")
|
||||||
|
(th "Target")
|
||||||
|
(th "Derivations")))
|
||||||
|
(tbody
|
||||||
|
,@(map (match-lambda
|
||||||
|
((system target count)
|
||||||
|
(if (string=? system target)
|
||||||
|
`(tr
|
||||||
|
(td (@ (class "text-center")
|
||||||
|
(colspan 2))
|
||||||
|
(samp ,system))
|
||||||
|
(td (samp ,count)))
|
||||||
|
`(tr
|
||||||
|
(td (samp ,system))
|
||||||
|
(td (samp ,target))
|
||||||
|
(td (samp ,count))))))
|
||||||
|
derivations-count)))))))))
|
||||||
|
|
||||||
|
(define* (view-revision-packages revision-commit-hash
|
||||||
|
query-parameters
|
||||||
|
packages
|
||||||
|
git-repositories
|
||||||
|
show-next-page?
|
||||||
|
#:key path-base
|
||||||
|
header-text header-link)
|
||||||
|
(define field-options
|
||||||
|
(map
|
||||||
|
(lambda (field)
|
||||||
|
(cons field
|
||||||
|
(hyphenate-words
|
||||||
|
(string-downcase field))))
|
||||||
|
'("Version" "Synopsis" "Description"
|
||||||
|
"Home page" "Location" "Licenses")))
|
||||||
|
|
||||||
|
(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
|
||||||
|
"Search query" query-parameters
|
||||||
|
#:help-text
|
||||||
|
"List packages where the name or synopsis match the query.")
|
||||||
|
,(form-horizontal-control
|
||||||
|
"Fields" query-parameters
|
||||||
|
#:name "field"
|
||||||
|
#:options field-options
|
||||||
|
#:help-text "Fields to return in the response.")
|
||||||
|
,(form-horizontal-control
|
||||||
|
"After name" query-parameters
|
||||||
|
#:help-text
|
||||||
|
"List packages that are alphabetically after the given name.")
|
||||||
|
,(form-horizontal-control
|
||||||
|
"Limit results" query-parameters
|
||||||
|
#:help-text "The maximum number of packages by name to return.")
|
||||||
|
,(form-horizontal-control
|
||||||
|
"All results" query-parameters
|
||||||
|
#:type "checkbox"
|
||||||
|
#:help-text "Return all results.")
|
||||||
|
(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 "Packages")
|
||||||
|
(table
|
||||||
|
(@ (class "table table-responsive"))
|
||||||
|
(thead
|
||||||
|
(tr
|
||||||
|
(th (@ (class "col-md-3")) "Name")
|
||||||
|
,@(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
|
||||||
|
((name version synopsis description home-page
|
||||||
|
location-file location-line
|
||||||
|
location-column-number licenses)
|
||||||
|
`(tr
|
||||||
|
(td ,name)
|
||||||
|
,@(if (member "version" fields)
|
||||||
|
`((td ,version))
|
||||||
|
'())
|
||||||
|
,(if (member "synopsis" fields)
|
||||||
|
`((td ,(stexi->shtml (texi-fragment->stexi synopsis))))
|
||||||
|
'())
|
||||||
|
,(if (member "description" fields)
|
||||||
|
`((td ,(stexi->shtml (texi-fragment->stexi description))))
|
||||||
|
'())
|
||||||
|
,(if (member "home-page" fields)
|
||||||
|
`((td ,home-page))
|
||||||
|
'())
|
||||||
|
,(if (member "location" fields)
|
||||||
|
`((td
|
||||||
|
,@(if (and location-file
|
||||||
|
(not (string-null? location-file)))
|
||||||
|
`((ul
|
||||||
|
,@(map
|
||||||
|
(match-lambda
|
||||||
|
((id label url cgit-url-base)
|
||||||
|
(if
|
||||||
|
(and cgit-url-base
|
||||||
|
(not (string-null? cgit-url-base)))
|
||||||
|
`(li
|
||||||
|
(a (@ (href
|
||||||
|
,(string-append
|
||||||
|
cgit-url-base "tree/"
|
||||||
|
location-file "?id=" revision-commit-hash
|
||||||
|
"#n" location-line)))
|
||||||
|
,location-file
|
||||||
|
" (line: " ,location-line
|
||||||
|
", column: " ,location-column-number ")"))
|
||||||
|
`(li ,location-file
|
||||||
|
" (line: " ,location-line
|
||||||
|
", column: " ,location-column-number ")"))))
|
||||||
|
git-repositories)))
|
||||||
|
'())))
|
||||||
|
'())
|
||||||
|
,(if (member "licenses" fields)
|
||||||
|
`((td
|
||||||
|
(ul
|
||||||
|
(@ (class "list-inline"))
|
||||||
|
,@(map (lambda (license)
|
||||||
|
`(li (a (@ (href ,(assoc-ref license "uri")))
|
||||||
|
,(assoc-ref license "name"))))
|
||||||
|
(vector->list
|
||||||
|
(json-string->scm licenses))))))
|
||||||
|
'())
|
||||||
|
(td (@ (class "text-right"))
|
||||||
|
(a (@ (href ,(string-append
|
||||||
|
(string-drop-right path-base 1)
|
||||||
|
"/" name "/" version)))
|
||||||
|
"More information")))))
|
||||||
|
packages))))))
|
||||||
|
,@(if show-next-page?
|
||||||
|
`((div
|
||||||
|
(@ (class "row"))
|
||||||
|
(a (@ (href ,(string-append path-base
|
||||||
|
"?after_name="
|
||||||
|
(car (last packages)))))
|
||||||
|
"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.")
|
||||||
|
,(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 (a (@ (href ,(string-append
|
||||||
|
(string-join
|
||||||
|
(drop-right (string-split path-base #\/) 1)
|
||||||
|
"/")
|
||||||
|
"/package/" package-name "/" package-version)))
|
||||||
|
,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))))))))))
|
||||||
|
|
@ -32,16 +32,14 @@
|
||||||
header
|
header
|
||||||
form-horizontal-control
|
form-horizontal-control
|
||||||
|
|
||||||
|
display-store-item-short
|
||||||
|
build-status-span
|
||||||
|
|
||||||
index
|
index
|
||||||
readme
|
readme
|
||||||
general-not-found
|
general-not-found
|
||||||
unknown-revision
|
unknown-revision
|
||||||
view-statistics
|
view-statistics
|
||||||
view-revision-package
|
|
||||||
view-revision-package-and-version
|
|
||||||
view-revision
|
|
||||||
view-revision-packages
|
|
||||||
view-revision-lint-warnings
|
|
||||||
view-git-repository
|
view-git-repository
|
||||||
view-branches
|
view-branches
|
||||||
view-branch
|
view-branch
|
||||||
|
|
@ -312,680 +310,6 @@
|
||||||
(style "font-size: 2em; display: block;"))
|
(style "font-size: 2em; display: block;"))
|
||||||
,derivations-count)))))))
|
,derivations-count)))))))
|
||||||
|
|
||||||
(define* (view-revision-package revision-commit-hash
|
|
||||||
name
|
|
||||||
versions
|
|
||||||
git-repositories-and-branches
|
|
||||||
#:key path-base
|
|
||||||
header-text
|
|
||||||
header-link)
|
|
||||||
(layout
|
|
||||||
#:body
|
|
||||||
`(,(header)
|
|
||||||
(div
|
|
||||||
(@ (class "container"))
|
|
||||||
(div
|
|
||||||
(@ (class "row"))
|
|
||||||
(div
|
|
||||||
(@ (class "col-sm-12"))
|
|
||||||
(h3 (a (@ (href ,header-link))
|
|
||||||
,@header-text))))
|
|
||||||
(div
|
|
||||||
(@ (class "row"))
|
|
||||||
(div
|
|
||||||
(@ (class "col-sm-12"))
|
|
||||||
,(append-map
|
|
||||||
(match-lambda
|
|
||||||
(((id label url cgit-url-base) . branches)
|
|
||||||
(map (match-lambda
|
|
||||||
((branch-name datetime)
|
|
||||||
`(a (@ (class "btn btn-default btn-lg pull-right")
|
|
||||||
(href ,(simple-format
|
|
||||||
#f "/repository/~A/branch/~A/package/~A"
|
|
||||||
id branch-name name)))
|
|
||||||
,(simple-format #f "View ~A branch version history"
|
|
||||||
branch-name))))
|
|
||||||
branches)))
|
|
||||||
git-repositories-and-branches)
|
|
||||||
(h1 "Package " ,name)))
|
|
||||||
(div
|
|
||||||
(@ (class "row"))
|
|
||||||
(div
|
|
||||||
(@ (class "col-sm-12"))
|
|
||||||
(h3 "Versions")
|
|
||||||
(table
|
|
||||||
(@ (class "table"))
|
|
||||||
(thead
|
|
||||||
(tr
|
|
||||||
(th (@ (class "col-sm-10")) "Version")
|
|
||||||
(th (@ (class "col-sm-2")) "")))
|
|
||||||
(tbody
|
|
||||||
,@(map
|
|
||||||
(lambda (version)
|
|
||||||
`(tr
|
|
||||||
(td (samp ,version))
|
|
||||||
(td
|
|
||||||
(a (@ (href ,(string-append
|
|
||||||
path-base
|
|
||||||
revision-commit-hash
|
|
||||||
"/package/" name "/" version)))
|
|
||||||
"More information"))))
|
|
||||||
versions)))))))))
|
|
||||||
|
|
||||||
(define* (view-revision-package-and-version revision-commit-hash name version
|
|
||||||
package-metadata
|
|
||||||
derivations git-repositories
|
|
||||||
lint-warnings
|
|
||||||
#:key header-text
|
|
||||||
header-link)
|
|
||||||
(layout
|
|
||||||
#:body
|
|
||||||
`(,(header)
|
|
||||||
(div
|
|
||||||
(@ (class "container"))
|
|
||||||
(div
|
|
||||||
(@ (class "row"))
|
|
||||||
(div
|
|
||||||
(@ (class "col-sm-12"))
|
|
||||||
(h3 (a (@ (href ,header-link))
|
|
||||||
,@header-text))))
|
|
||||||
(div
|
|
||||||
(@ (class "row"))
|
|
||||||
(div
|
|
||||||
(@ (class "col-sm-12"))
|
|
||||||
(h1 "Package " ,name " @ " ,version)))
|
|
||||||
(div
|
|
||||||
(@ (class "row"))
|
|
||||||
(div
|
|
||||||
(@ (class "col-sm-12"))
|
|
||||||
,(match package-metadata
|
|
||||||
(((synopsis description home-page file line column-number
|
|
||||||
licenses))
|
|
||||||
`(dl
|
|
||||||
(@ (class "dl-horizontal"))
|
|
||||||
(dt "Synopsis")
|
|
||||||
(dd ,(stexi->shtml (texi-fragment->stexi synopsis)))
|
|
||||||
(dt "Description")
|
|
||||||
(dd ,(stexi->shtml (texi-fragment->stexi description)))
|
|
||||||
(dt "Home page")
|
|
||||||
(dd (a (@ (href ,home-page)) ,home-page))
|
|
||||||
,@(if (and file (not (string-null? file))
|
|
||||||
(not (null? git-repositories)))
|
|
||||||
`((dt "Location")
|
|
||||||
(dd ,@(map
|
|
||||||
(match-lambda
|
|
||||||
((id label url cgit-url-base)
|
|
||||||
(if
|
|
||||||
(and cgit-url-base
|
|
||||||
(not (string-null? cgit-url-base)))
|
|
||||||
`(a (@ (href
|
|
||||||
,(string-append
|
|
||||||
cgit-url-base "tree/"
|
|
||||||
file "?id=" revision-commit-hash
|
|
||||||
"#n" line)))
|
|
||||||
,file
|
|
||||||
" (line: " ,line
|
|
||||||
", column: " ,column-number ")")
|
|
||||||
'())))
|
|
||||||
git-repositories)))
|
|
||||||
'())
|
|
||||||
,@(if (> (vector-length licenses) 0)
|
|
||||||
`((dt ,(if (eq? (vector-length licenses) 1)
|
|
||||||
"License"
|
|
||||||
"Licenses"))
|
|
||||||
(dd (ul
|
|
||||||
,@(map (lambda (license)
|
|
||||||
`(li (a (@ (href ,(assoc-ref license "uri")))
|
|
||||||
,(assoc-ref license "name"))))
|
|
||||||
(vector->list licenses)))))
|
|
||||||
'()))))))
|
|
||||||
(div
|
|
||||||
(@ (class "row"))
|
|
||||||
(div
|
|
||||||
(@ (class "col-sm-12"))
|
|
||||||
(h3 "Derivations")
|
|
||||||
(table
|
|
||||||
(@ (class "table"))
|
|
||||||
(thead
|
|
||||||
(tr
|
|
||||||
(th "System")
|
|
||||||
(th "Target")
|
|
||||||
(th "Derivation")
|
|
||||||
(th "Build status")))
|
|
||||||
(tbody
|
|
||||||
,@(map
|
|
||||||
(match-lambda
|
|
||||||
((system target file-name status)
|
|
||||||
`(tr
|
|
||||||
(td (samp ,system))
|
|
||||||
(td (samp ,target))
|
|
||||||
(td (a (@ (href ,file-name))
|
|
||||||
,(display-store-item-short file-name)))
|
|
||||||
(td ,(build-status-span status)))))
|
|
||||||
derivations)))))
|
|
||||||
(div
|
|
||||||
(@ (class "row"))
|
|
||||||
(div
|
|
||||||
(@ (class "col-sm-12"))
|
|
||||||
(h3 "Lint warnings")
|
|
||||||
(table
|
|
||||||
(@ (class "table"))
|
|
||||||
(thead
|
|
||||||
(tr
|
|
||||||
(th "Linter")
|
|
||||||
(th "Message")
|
|
||||||
(th "Location")))
|
|
||||||
(tbody
|
|
||||||
,@(map
|
|
||||||
(match-lambda
|
|
||||||
((id lint-checker-name lint-checker-description
|
|
||||||
lint-checker-network-dependent
|
|
||||||
file line-number column-number
|
|
||||||
message)
|
|
||||||
`(tr
|
|
||||||
(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)
|
|
||||||
(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 (view-revision/git-repositories git-repositories-and-branches
|
|
||||||
commit-hash)
|
|
||||||
`((h3 "Git repositories")
|
|
||||||
,@(map
|
|
||||||
(match-lambda
|
|
||||||
(((id label url cgit-url-base) . branches)
|
|
||||||
`((a (@ (href ,(string-append
|
|
||||||
"/repository/" id)))
|
|
||||||
(h4 ,url))
|
|
||||||
,@(map
|
|
||||||
(match-lambda
|
|
||||||
((name datetime)
|
|
||||||
`(div
|
|
||||||
(a (@ (href ,(string-append "/repository/" id
|
|
||||||
"/branch/" name)))
|
|
||||||
,name)
|
|
||||||
" at " ,datetime
|
|
||||||
,@(if (string-null? cgit-url-base)
|
|
||||||
'()
|
|
||||||
`(" "
|
|
||||||
(a (@ (href ,(string-append
|
|
||||||
cgit-url-base
|
|
||||||
"commit/?id="
|
|
||||||
commit-hash)))
|
|
||||||
"(View cgit)"))))))
|
|
||||||
branches))))
|
|
||||||
git-repositories-and-branches)))
|
|
||||||
|
|
||||||
(define (view-revision/jobs-and-events jobs-and-events)
|
|
||||||
`((h3 "Jobs")
|
|
||||||
(table
|
|
||||||
(@ (class "table"))
|
|
||||||
(thead
|
|
||||||
(tr
|
|
||||||
(th "Source")
|
|
||||||
(th "Events")
|
|
||||||
(th "")))
|
|
||||||
(tbody
|
|
||||||
,@(map (match-lambda
|
|
||||||
((id commit source git-repository-id created-at succeeded-at
|
|
||||||
events log-exists?)
|
|
||||||
`(tr
|
|
||||||
(@ (class
|
|
||||||
,(let ((event-names
|
|
||||||
(map (lambda (event)
|
|
||||||
(assoc-ref event "event"))
|
|
||||||
(vector->list events))))
|
|
||||||
(cond
|
|
||||||
((member "success" event-names)
|
|
||||||
"success")
|
|
||||||
((member "failure" event-names)
|
|
||||||
"danger")
|
|
||||||
((member "start" event-names)
|
|
||||||
"info")
|
|
||||||
(else
|
|
||||||
""))))
|
|
||||||
(title ,(simple-format #f "Job id: ~A" id)))
|
|
||||||
(td ,source)
|
|
||||||
(td
|
|
||||||
(dl
|
|
||||||
,@(map
|
|
||||||
(lambda (event)
|
|
||||||
`((dt ,(assoc-ref event "event"))
|
|
||||||
(dd ,(assoc-ref event "occurred_at"))))
|
|
||||||
(cons
|
|
||||||
`(("event" . "created")
|
|
||||||
("occurred_at" . ,created-at))
|
|
||||||
(vector->list events)))))
|
|
||||||
(td
|
|
||||||
,@(if log-exists?
|
|
||||||
`((a (@ (href ,(string-append "/job/" id)))
|
|
||||||
"View log"))
|
|
||||||
'())))))
|
|
||||||
jobs-and-events)))))
|
|
||||||
|
|
||||||
(define (view-revision/lint-warning-counts path-base lint-warning-counts)
|
|
||||||
`((h3 "Lint warnings")
|
|
||||||
(a (@ (href ,(string-append path-base "/lint-warnings")))
|
|
||||||
"View lint warnings")
|
|
||||||
(table
|
|
||||||
(@ (class "table"))
|
|
||||||
(thead
|
|
||||||
(tr
|
|
||||||
(th "Linter")
|
|
||||||
(th "Count")))
|
|
||||||
(tbody
|
|
||||||
,@(map (match-lambda
|
|
||||||
((name description network-dependent count)
|
|
||||||
`(tr
|
|
||||||
(td (span (@ (style "font-family: monospace; display: block;"))
|
|
||||||
,name)
|
|
||||||
(p (@ (style "margin: 6px 0 0px;"))
|
|
||||||
,description))
|
|
||||||
(td ,count))))
|
|
||||||
lint-warning-counts)))))
|
|
||||||
|
|
||||||
(define* (view-revision commit-hash packages-count
|
|
||||||
git-repositories-and-branches derivations-count
|
|
||||||
jobs-and-events
|
|
||||||
lint-warning-counts
|
|
||||||
#:key (path-base "/revision/")
|
|
||||||
header-text)
|
|
||||||
(layout
|
|
||||||
#:body
|
|
||||||
`(,(header)
|
|
||||||
(div
|
|
||||||
(@ (class "container"))
|
|
||||||
(div
|
|
||||||
(@ (class "row"))
|
|
||||||
(div
|
|
||||||
(@ (class "col-md-12"))
|
|
||||||
(h1 (@ (style "white-space: nowrap;"))
|
|
||||||
,@header-text)))
|
|
||||||
(div
|
|
||||||
(@ (class "row"))
|
|
||||||
(div
|
|
||||||
(@ (class "col-md-6"))
|
|
||||||
(h2 "Packages")
|
|
||||||
(strong (@ (class "text-center")
|
|
||||||
(style "font-size: 2em; display: block;"))
|
|
||||||
,packages-count)
|
|
||||||
(a (@ (href ,(string-append path-base "/packages")))
|
|
||||||
"View packages")
|
|
||||||
|
|
||||||
,@(if (null? git-repositories-and-branches)
|
|
||||||
'()
|
|
||||||
(view-revision/git-repositories git-repositories-and-branches
|
|
||||||
commit-hash))
|
|
||||||
,@(view-revision/jobs-and-events jobs-and-events)
|
|
||||||
,@(view-revision/lint-warning-counts path-base
|
|
||||||
lint-warning-counts))
|
|
||||||
(div
|
|
||||||
(@ (class "col-md-6"))
|
|
||||||
(h3 "Derivations")
|
|
||||||
(table
|
|
||||||
(@ (class "table")
|
|
||||||
(style "white-space: nowrap;"))
|
|
||||||
(thead
|
|
||||||
(tr
|
|
||||||
(th "System")
|
|
||||||
(th "Target")
|
|
||||||
(th "Derivations")))
|
|
||||||
(tbody
|
|
||||||
,@(map (match-lambda
|
|
||||||
((system target count)
|
|
||||||
(if (string=? system target)
|
|
||||||
`(tr
|
|
||||||
(td (@ (class "text-center")
|
|
||||||
(colspan 2))
|
|
||||||
(samp ,system))
|
|
||||||
(td (samp ,count)))
|
|
||||||
`(tr
|
|
||||||
(td (samp ,system))
|
|
||||||
(td (samp ,target))
|
|
||||||
(td (samp ,count))))))
|
|
||||||
derivations-count)))))))))
|
|
||||||
|
|
||||||
(define* (view-revision-packages revision-commit-hash
|
|
||||||
query-parameters
|
|
||||||
packages
|
|
||||||
git-repositories
|
|
||||||
show-next-page?
|
|
||||||
#:key path-base
|
|
||||||
header-text header-link)
|
|
||||||
(define field-options
|
|
||||||
(map
|
|
||||||
(lambda (field)
|
|
||||||
(cons field
|
|
||||||
(hyphenate-words
|
|
||||||
(string-downcase field))))
|
|
||||||
'("Version" "Synopsis" "Description"
|
|
||||||
"Home page" "Location" "Licenses")))
|
|
||||||
|
|
||||||
(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
|
|
||||||
"Search query" query-parameters
|
|
||||||
#:help-text
|
|
||||||
"List packages where the name or synopsis match the query.")
|
|
||||||
,(form-horizontal-control
|
|
||||||
"Fields" query-parameters
|
|
||||||
#:name "field"
|
|
||||||
#:options field-options
|
|
||||||
#:help-text "Fields to return in the response.")
|
|
||||||
,(form-horizontal-control
|
|
||||||
"After name" query-parameters
|
|
||||||
#:help-text
|
|
||||||
"List packages that are alphabetically after the given name.")
|
|
||||||
,(form-horizontal-control
|
|
||||||
"Limit results" query-parameters
|
|
||||||
#:help-text "The maximum number of packages by name to return.")
|
|
||||||
,(form-horizontal-control
|
|
||||||
"All results" query-parameters
|
|
||||||
#:type "checkbox"
|
|
||||||
#:help-text "Return all results.")
|
|
||||||
(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 "Packages")
|
|
||||||
(table
|
|
||||||
(@ (class "table table-responsive"))
|
|
||||||
(thead
|
|
||||||
(tr
|
|
||||||
(th (@ (class "col-md-3")) "Name")
|
|
||||||
,@(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
|
|
||||||
((name version synopsis description home-page
|
|
||||||
location-file location-line
|
|
||||||
location-column-number licenses)
|
|
||||||
`(tr
|
|
||||||
(td ,name)
|
|
||||||
,@(if (member "version" fields)
|
|
||||||
`((td ,version))
|
|
||||||
'())
|
|
||||||
,(if (member "synopsis" fields)
|
|
||||||
`((td ,(stexi->shtml (texi-fragment->stexi synopsis))))
|
|
||||||
'())
|
|
||||||
,(if (member "description" fields)
|
|
||||||
`((td ,(stexi->shtml (texi-fragment->stexi description))))
|
|
||||||
'())
|
|
||||||
,(if (member "home-page" fields)
|
|
||||||
`((td ,home-page))
|
|
||||||
'())
|
|
||||||
,(if (member "location" fields)
|
|
||||||
`((td
|
|
||||||
,@(if (and location-file
|
|
||||||
(not (string-null? location-file)))
|
|
||||||
`((ul
|
|
||||||
,@(map
|
|
||||||
(match-lambda
|
|
||||||
((id label url cgit-url-base)
|
|
||||||
(if
|
|
||||||
(and cgit-url-base
|
|
||||||
(not (string-null? cgit-url-base)))
|
|
||||||
`(li
|
|
||||||
(a (@ (href
|
|
||||||
,(string-append
|
|
||||||
cgit-url-base "tree/"
|
|
||||||
location-file "?id=" revision-commit-hash
|
|
||||||
"#n" location-line)))
|
|
||||||
,location-file
|
|
||||||
" (line: " ,location-line
|
|
||||||
", column: " ,location-column-number ")"))
|
|
||||||
`(li ,location-file
|
|
||||||
" (line: " ,location-line
|
|
||||||
", column: " ,location-column-number ")"))))
|
|
||||||
git-repositories)))
|
|
||||||
'())))
|
|
||||||
'())
|
|
||||||
,(if (member "licenses" fields)
|
|
||||||
`((td
|
|
||||||
(ul
|
|
||||||
(@ (class "list-inline"))
|
|
||||||
,@(map (lambda (license)
|
|
||||||
`(li (a (@ (href ,(assoc-ref license "uri")))
|
|
||||||
,(assoc-ref license "name"))))
|
|
||||||
(vector->list
|
|
||||||
(json-string->scm licenses))))))
|
|
||||||
'())
|
|
||||||
(td (@ (class "text-right"))
|
|
||||||
(a (@ (href ,(string-append
|
|
||||||
(string-drop-right path-base 1)
|
|
||||||
"/" name "/" version)))
|
|
||||||
"More information")))))
|
|
||||||
packages))))))
|
|
||||||
,@(if show-next-page?
|
|
||||||
`((div
|
|
||||||
(@ (class "row"))
|
|
||||||
(a (@ (href ,(string-append path-base
|
|
||||||
"?after_name="
|
|
||||||
(car (last packages)))))
|
|
||||||
"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.")
|
|
||||||
,(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 (a (@ (href ,(string-append
|
|
||||||
(string-join
|
|
||||||
(drop-right (string-split path-base #\/) 1)
|
|
||||||
"/")
|
|
||||||
"/package/" package-name "/" package-version)))
|
|
||||||
,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