aboutsummaryrefslogtreecommitdiff
path: root/guix-data-service/web
diff options
context:
space:
mode:
Diffstat (limited to 'guix-data-service/web')
-rw-r--r--guix-data-service/web/controller.scm178
-rw-r--r--guix-data-service/web/repository/controller.scm210
-rw-r--r--guix-data-service/web/repository/html.scm279
-rw-r--r--guix-data-service/web/view/html.scm259
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