From 86db73c05abed4feb830cb079c9d81ffd26eb949 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Mon, 14 Oct 2019 18:28:25 +0100 Subject: Refactor the repository pages code Move it out of the main controller and html modules to better separate the code, which should allow to make it easier to read in the future. --- guix-data-service/web/view/html.scm | 259 +----------------------------------- 1 file changed, 2 insertions(+), 257 deletions(-) (limited to 'guix-data-service/web/view/html.scm') 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 -- cgit v1.2.3