mirror of
git://git.savannah.gnu.org/guix/data-service.git
synced 2023-12-14 03:23:03 +01:00
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.
This commit is contained in:
Christopher Baines
parent
49ea210382
commit
86db73c05a
|
|
@ -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
|
||||
|
|
|
|||
210
guix-data-service/web/repository/controller.scm
Normal file
210
guix-data-service/web/repository/controller.scm
Normal file
|
|
@ -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))))))
|
||||
279
guix-data-service/web/repository/html.scm
Normal file
279
guix-data-service/web/repository/html.scm
Normal file
|
|
@ -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))))))))))
|
||||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue