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:
Christopher Baines
parent
660df79a69
commit
49ea210382
|
|
@ -28,7 +28,6 @@
|
|||
#:use-module (web uri)
|
||||
#:use-module (texinfo)
|
||||
#:use-module (texinfo html)
|
||||
#:use-module (texinfo plain-text)
|
||||
#:use-module (squee)
|
||||
#:use-module (json)
|
||||
#:use-module (guix-data-service config)
|
||||
|
|
@ -51,8 +50,10 @@
|
|||
#: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 web revision controller)
|
||||
#:use-module (guix-data-service web jobs controller)
|
||||
#:use-module (guix-data-service web view html)
|
||||
#:use-module (guix-data-service web revision controller)
|
||||
#:export (controller))
|
||||
|
||||
(define cache-control-default-max-age
|
||||
|
|
@ -89,375 +90,6 @@
|
|||
value)))
|
||||
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
|
||||
conn
|
||||
query-parameters)
|
||||
|
|
@ -983,81 +615,8 @@
|
|||
(render-html
|
||||
#:sxml (view-statistics (count-guix-revisions conn)
|
||||
(count-derivations conn))))
|
||||
(('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)))
|
||||
(('GET "revision" args ...)
|
||||
(delegate-to revision-controller))
|
||||
(('GET "repository" id)
|
||||
(match (select-git-repository conn id)
|
||||
((label url cgit-url-base)
|
||||
|
|
|
|||
|
|
@ -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))))))
|
||||
|
|
@ -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
|
||||
form-horizontal-control
|
||||
|
||||
display-store-item-short
|
||||
build-status-span
|
||||
|
||||
index
|
||||
readme
|
||||
general-not-found
|
||||
unknown-revision
|
||||
view-statistics
|
||||
view-revision-package
|
||||
view-revision-package-and-version
|
||||
view-revision
|
||||
view-revision-packages
|
||||
view-revision-lint-warnings
|
||||
view-git-repository
|
||||
view-branches
|
||||
view-branch
|
||||
|
|
@ -312,680 +310,6 @@
|
|||
(style "font-size: 2em; display: block;"))
|
||||
,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
|
||||
git-repository-id branches-with-most-recent-commits)
|
||||
`(table
|
||||
|
|
|
|||
Loading…
Reference in New Issue