diff options
Diffstat (limited to 'guix-data-service/web')
| -rw-r--r-- | guix-data-service/web/controller.scm | 178 | ||||
| -rw-r--r-- | guix-data-service/web/repository/controller.scm | 210 | ||||
| -rw-r--r-- | guix-data-service/web/repository/html.scm | 279 | ||||
| -rw-r--r-- | guix-data-service/web/view/html.scm | 259 |
4 files changed, 494 insertions, 432 deletions
diff --git a/guix-data-service/web/controller.scm b/guix-data-service/web/controller.scm index b6381a3..769d2dd 100644 --- a/guix-data-service/web/controller.scm +++ b/guix-data-service/web/controller.scm @@ -54,6 +54,7 @@ #:use-module (guix-data-service web jobs controller) #:use-module (guix-data-service web view html) #:use-module (guix-data-service web revision controller) + #:use-module (guix-data-service web repository controller) #:export (controller)) (define cache-control-default-max-age @@ -617,181 +618,8 @@ (count-derivations conn)))) (('GET "revision" args ...) (delegate-to revision-controller)) - (('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)))) + (('GET "repository" _ ...) + (delegate-to repository-controller)) (('GET "gnu" "store" filename) ;; These routes are a little special, as the extensions aren't used for ;; content negotiation, so just use the path from the request 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)))))))))) diff --git a/guix-data-service/web/view/html.scm b/guix-data-service/web/view/html.scm index 2417888..3102106 100644 --- a/guix-data-service/web/view/html.scm +++ b/guix-data-service/web/view/html.scm @@ -35,15 +35,13 @@ display-store-item-short build-status-span + table/branches-with-most-recent-commits + index readme general-not-found unknown-revision view-statistics - view-git-repository - view-branches - view-branch - view-branch-package view-builds view-derivation view-store-item @@ -349,259 +347,6 @@ "No information yet"))))))))) branches-with-most-recent-commits)))) -(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)))))))))) - (define (view-builds stats builds) (layout #:body |