aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorChristopher Baines <mail@cbaines.net>2019-10-13 23:17:57 +0100
committerChristopher Baines <mail@cbaines.net>2019-10-13 23:17:57 +0100
commit0fa79c44cc06981122b969666bbc1aa43adcc4d6 (patch)
treec8148b3aa805d8c3207e1a875b590de0816fb558
parent660df79a69aa983598bd64e39836a481a2035adb (diff)
downloaddata-service-refactor-revision-controller.tar
data-service-refactor-revision-controller.tar.gz
-rw-r--r--guix-data-service/web/controller.scm448
-rw-r--r--guix-data-service/web/revision/controller.scm501
-rw-r--r--guix-data-service/web/revision/html.scm704
-rw-r--r--guix-data-service/web/view/html.scm682
4 files changed, 1211 insertions, 1124 deletions
diff --git a/guix-data-service/web/controller.scm b/guix-data-service/web/controller.scm
index 7ad097f..5aecd9d 100644
--- a/guix-data-service/web/controller.scm
+++ b/guix-data-service/web/controller.scm
@@ -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,6 +50,7 @@
#: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)
#:export (controller))
@@ -89,375 +89,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 +614,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)
diff --git a/guix-data-service/web/revision/controller.scm b/guix-data-service/web/revision/controller.scm
new file mode 100644
index 0000000..6f5ae26
--- /dev/null
+++ b/guix-data-service/web/revision/controller.scm
@@ -0,0 +1,501 @@
+;;; 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))
+
+(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))))))
diff --git a/guix-data-service/web/revision/html.scm b/guix-data-service/web/revision/html.scm
new file mode 100644
index 0000000..1f3189a
--- /dev/null
+++ b/guix-data-service/web/revision/html.scm
@@ -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))))))))))
diff --git a/guix-data-service/web/view/html.scm b/guix-data-service/web/view/html.scm
index 2750944..2417888 100644
--- a/guix-data-service/web/view/html.scm
+++ b/guix-data-service/web/view/html.scm
@@ -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