diff options
| -rw-r--r-- | guix-data-service/web/controller.scm | 448 | ||||
| -rw-r--r-- | guix-data-service/web/revision/controller.scm | 501 | ||||
| -rw-r--r-- | guix-data-service/web/revision/html.scm | 704 | ||||
| -rw-r--r-- | guix-data-service/web/view/html.scm | 682 |
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 |