aboutsummaryrefslogtreecommitdiff
path: root/guix-data-service/web/repository/html.scm
diff options
context:
space:
mode:
Diffstat (limited to 'guix-data-service/web/repository/html.scm')
-rw-r--r--guix-data-service/web/repository/html.scm279
1 files changed, 279 insertions, 0 deletions
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))))))))))
generated by cgit v1.2.3 (git 2.25.4) at 2024-05-17 00:30:34 +0000