diff options
Diffstat (limited to 'guix-data-service/web/repository')
-rw-r--r-- | guix-data-service/web/repository/controller.scm | 210 | ||||
-rw-r--r-- | guix-data-service/web/repository/html.scm | 279 |
2 files changed, 489 insertions, 0 deletions
diff --git a/guix-data-service/web/repository/controller.scm b/guix-data-service/web/repository/controller.scm new file mode 100644 index 0000000..7ed147c --- /dev/null +++ b/guix-data-service/web/repository/controller.scm @@ -0,0 +1,210 @@ +;;; 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 repository controller) + #:use-module (ice-9 match) + #:use-module (guix-data-service web render) + #:use-module (guix-data-service web query-parameters) + #:use-module (guix-data-service web util) + #: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 web repository html) + #:export (repository-controller)) + +(define (repository-controller request + method-and-path-components + mime-types + body + conn) + + (match method-and-path-components + (('GET "repository" id) + (match (select-git-repository conn id) + ((label url cgit-url-base) + (render-html + #:sxml + (view-git-repository + (string->number id) + label url cgit-url-base + (all-branches-with-most-recent-commit conn + (string->number id))))) + (#f + (render-html + #:sxml (general-not-found + "Repository not found" + "") + #:code 404)))) + (('GET "repository" repository-id "branch" branch-name) + (let ((parsed-query-parameters + (parse-query-parameters + request + `((after_date ,parse-datetime) + (before_date ,parse-datetime) + (limit_results ,parse-result-limit #:default 100))))) + (render-html + #:sxml (if (any-invalid-query-parameters? parsed-query-parameters) + (view-branch repository-id + branch-name parsed-query-parameters '()) + (view-branch + repository-id + branch-name + parsed-query-parameters + (most-recent-commits-for-branch + conn + (string->number repository-id) + branch-name + #:limit (assq-ref parsed-query-parameters 'limit_results) + #:after-date (assq-ref parsed-query-parameters + 'after_date) + #:before-date (assq-ref parsed-query-parameters + 'before_date))))))) + (('GET "repository" repository-id "branch" branch-name "package" package-name) + (let ((package-versions + (package-versions-for-branch conn + (string->number repository-id) + branch-name + package-name))) + (case (most-appropriate-mime-type + '(application/json text/html) + mime-types) + ((application/json) + (render-json + `((versions . ,(list->vector + (map (match-lambda + ((package-version first-guix-revision-commit + first-datetime + last-guix-revision-commit + last-datetime) + `((version . ,package-version) + (first_revision + . ((commit . ,first-guix-revision-commit) + (datetime . ,first-datetime))) + (last_revision + . ((commit . ,last-guix-revision-commit) + (datetime . ,last-datetime)))))) + package-versions)))))) + (else + (render-html + #:sxml (view-branch-package + repository-id + branch-name + package-name + package-versions)))))) + (('GET "repository" repository-id "branch" branch-name "latest-processed-revision") + (let ((commit-hash + (latest-processed-commit-for-branch conn repository-id branch-name))) + (if commit-hash + (render-view-revision mime-types + conn + commit-hash + #:path-base path + #:header-text + `("Latest processed revision for branch " + (samp ,branch-name))) + (render-unknown-revision mime-types + conn + commit-hash)))) + (('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "packages") + (let ((commit-hash + (latest-processed-commit-for-branch conn repository-id branch-name))) + (if 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 + #:header-text + `("Latest processed revision for branch " + (samp ,branch-name)) + #:header-link + (string-append + "/repository/" repository-id + "/branch/" branch-name + "/latest-processed-revision"))) + (render-unknown-revision mime-types + conn + commit-hash)))) + (('GET "repository" repository-id "branch" branch-name "latest-processed-revision" + "lint-warnings") + (let ((commit-hash + (latest-processed-commit-for-branch conn repository-id branch-name))) + (if commit-hash + (let ((parsed-query-parameters + (parse-query-parameters + request + `((package_query ,identity) + (linter ,identity #:multi-value) + (message_query ,identity) + (field ,identity #:multi-value + #:default ("linter" + "message" + "location")))))) + + (render-revision-lint-warnings mime-types + conn + commit-hash + parsed-query-parameters + #:path-base path + #:header-text + `("Latest processed revision for branch " + (samp ,branch-name)) + #:header-link + (string-append + "/repository/" repository-id + "/branch/" branch-name + "/latest-processed-revision"))) + (render-unknown-revision mime-types + conn + commit-hash)))) + (('GET "repository" repository-id "branch" branch-name "latest-processed-revision" "package" name version) + (let ((commit-hash + (latest-processed-commit-for-branch conn repository-id branch-name))) + (if commit-hash + (render-revision-package-version mime-types + conn + commit-hash + name + version + #:header-text + `("Latest processed revision for branch " + (samp ,branch-name)) + #:header-link + (string-append + "/repository/" repository-id + "/branch/" branch-name + "/latest-processed-revision")) + (render-unknown-revision mime-types + conn + commit-hash)))))) diff --git a/guix-data-service/web/repository/html.scm b/guix-data-service/web/repository/html.scm new file mode 100644 index 0000000..43f3df7 --- /dev/null +++ b/guix-data-service/web/repository/html.scm @@ -0,0 +1,279 @@ +;;; 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 repository html) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-19) + #:use-module (ice-9 match) + #:use-module (guix-data-service web view html) + #:export (view-git-repository + view-branches + view-branch + view-branch-package)) + +(define* (view-git-repository git-repository-id + label url cgit-url-base + branches-with-most-recent-commits) + (layout + #:body + `(,(header) + (div + (@ (class "container")) + (div + (@ (class "row")) + (div + (@ (class "col-md-12")) + (h1 ,url))) + (div + (@ (class "row")) + (div + (@ (class "col-md-12")) + (h3 "Branches") + ,(table/branches-with-most-recent-commits + git-repository-id + branches-with-most-recent-commits))))))) + +(define (view-branch git-repository-id + branch-name query-parameters branch-commits) + (layout + #:body + `(,(header) + (div + (@ (class "container")) + (div + (@ (class "row")) + (div + (@ (class "col-md-12")) + (a (@ (href ,(string-append "/repository/" git-repository-id))) + (h3 "Repository")) + (h1 (@ (style "white-space: nowrap;")) + (samp ,branch-name) " branch"))) + (div + (@ (class "row")) + (div + (@ (class "col-md-12")) + (div + (@ (class "well")) + (form + (@ (method "get") + (action "") + (class "form-horizontal")) + ,(form-horizontal-control + "After date" query-parameters + #:help-text "Only show the branch history after this date.") + ,(form-horizontal-control + "Before date" query-parameters + #:help-text "Only show the branch history before this date.") + ,(form-horizontal-control + "Limit results" query-parameters + #:help-text "The maximum number of results to return.") + (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 ,(string-append + "/repository/" git-repository-id + "/branch/" branch-name "/latest-processed-revision"))) + "Latest processed revision"))) + (div + (@ (class "row")) + (div + (@ (class "col-md-12")) + (table + (@ (class "table") + (style "table-layout: fixed;")) + (thead + (tr + (th (@ (class "col-sm-3")) "Date") + (th (@ (class "col-sm-7")) "Commit") + (th (@ (class "col-sm-1"))))) + (tbody + ,@(map + (match-lambda* + (((commit date revision-exists? job-events) + (previous-commit previous-revision-exists?)) + `(tr + (td ,date) + (td ,@(if (string=? commit "") + '((samp "branch deleted")) + `((a (@ (href ,(string-append + "/revision/" commit))) + (samp ,commit)) + " " + ,(cond + (revision-exists? + '(span + (@ (class "label label-success")) + "✓")) + ((member "failure" job-events) + '(span (@ (class "label label-danger")) + "Failed to import data")) + (else + '(span (@ (class "label label-default")) + "No information yet")))))) + ,@(if (and previous-commit + revision-exists? + previous-revision-exists?) + `((td + (@ (style "vertical-align: middle;") + (rowspan "2")) + (div + (@ (class "btn-group") + (role "group")) + (a (@ (class "btn btn-sm btn-default") + (title "Compare") + (href ,(string-append + "/compare" + "?base_commit=" previous-commit + "&target_commit=" commit))) + "⇕ Compare")))) + '())))) + branch-commits + (append (map (match-lambda + ((commit date revision-exists? job-events) + (list commit + revision-exists?))) + (cdr branch-commits)) + '((#f #f)))))))))))) + +(define (view-branch-package git-repository-id + branch-name + package-name + versions-by-revision-range) + (layout + #:body + `(,(header) + (div + (@ (class "container")) + (div + (@ (class "row")) + (div + (@ (class "col-md-12")) + (a (@ (href ,(string-append "/repository/" git-repository-id))) + (h3 "Repository")) + (a (@ (href ,(string-append "/repository/" git-repository-id + "/branch/" branch-name))) + (h3 ,(string-append branch-name " branch"))) + (a (@ (class "btn btn-default btn-lg pull-right") + (href ,(string-append + "/repository/" git-repository-id + "/branch/" branch-name + "/package/" package-name + ".json"))) + "View JSON") + (h1 (@ (style "white-space: nowrap;")) + (samp ,package-name)))) + (div + (@ (class "row")) + (div + (@ (class "col-md-12")) + (table + (@ (class "table") + (style "table-layout: fixed;")) + (thead + (tr + (th (@ (class "col-sm-4")) "Version") + (th (@ (class "col-sm-4")) "From") + (th (@ (class "col-sm-4")) "To"))) + (tbody + ,@(let* ((times-in-seconds + (map (lambda (d) + (time-second + (date->time-monotonic + (string->date d "~Y-~m-~d ~H:~M:~S")))) + (append (map third versions-by-revision-range) + (map fifth versions-by-revision-range)))) + (earliest-date-seconds + (apply min + times-in-seconds)) + (latest-date-seconds + (apply max + times-in-seconds)) + (min-to-max-seconds + (- latest-date-seconds + earliest-date-seconds))) + (map + (match-lambda + ((package-version first-guix-revision-commit + first-datetime + last-guix-revision-commit + last-datetime) + `((tr + (@ (style "border-bottom: 0;")) + (td ,package-version) + (td (a (@ (href ,(string-append + "/revision/" first-guix-revision-commit))) + ,first-datetime) + (br) + (a (@ (href ,(string-append + "/revision/" + first-guix-revision-commit + "/package/" + package-name "/" package-version))) + "(More information)")) + (td (a (@ (href ,(string-append + "/revision/" last-guix-revision-commit))) + ,last-datetime) + (br) + (a (@ (href ,(string-append + "/revision/" + last-guix-revision-commit + "/package/" + package-name "/" package-version))) + "(More information)"))) + (tr + (td + (@ (colspan 3) + (style "border-top: 0; padding-top: 0;")) + (div + (@ + (style + ,(let* ((start-seconds + (time-second + (date->time-monotonic + (string->date first-datetime + "~Y-~m-~d ~H:~M:~S")))) + (end-seconds + (time-second + (date->time-monotonic + (string->date last-datetime + "~Y-~m-~d ~H:~M:~S")))) + (margin-left + (min + (* (/ (- start-seconds earliest-date-seconds) + min-to-max-seconds) + 100) + 98)) + (width + (max + (- (* (/ (- end-seconds earliest-date-seconds) + min-to-max-seconds) + 100) + margin-left) + 2))) + (simple-format + #f + "margin-left: ~A%; width: ~A%; height: 10px; background: #DCDCDC;" + (rationalize margin-left 1) + (rationalize width 1))))))))))) + versions-by-revision-range)))))))))) |