Christopher Baines
4ce8d9e830
In to their own modules. This should help make the code more understandable, and allow future refactoring for readability.
596 lines
21 KiB
Scheme
596 lines
21 KiB
Scheme
;;; Guix Data Service -- Information about Guix over time
|
|
;;; Copyright © 2016, 2017, 2018, 2019 Ricardo Wurmus <rekado@elephly.net>
|
|
;;; Copyright © 2018, 2019 Arun Isaac <arunisaac@systemreboot.net>
|
|
;;; 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 view html)
|
|
#:use-module (guix-data-service config)
|
|
#:use-module (guix-data-service web query-parameters)
|
|
#:use-module (guix-data-service web util)
|
|
#:use-module (ice-9 vlist)
|
|
#:use-module (ice-9 match)
|
|
#:use-module (srfi srfi-1)
|
|
#:use-module (srfi srfi-19)
|
|
#:use-module (texinfo)
|
|
#:use-module (texinfo html)
|
|
#:use-module (json)
|
|
#:export (layout
|
|
header
|
|
form-horizontal-control
|
|
|
|
display-store-item-short
|
|
build-status-span
|
|
|
|
table/branches-with-most-recent-commits
|
|
|
|
index
|
|
readme
|
|
general-not-found
|
|
view-statistics
|
|
view-builds
|
|
view-derivation
|
|
view-store-item
|
|
error-page))
|
|
|
|
(define* (header)
|
|
`(nav
|
|
(@ (id "header") (class "navbar navbar-default"))
|
|
(div
|
|
(@ (class "container-fluid"))
|
|
(div
|
|
(@ (class "navbar-header"))
|
|
(div (@ (class "navbar-brand"))
|
|
(a (@ (href "/") (class "logo"))))))))
|
|
|
|
(define* (layout #:key
|
|
(head '())
|
|
(body '())
|
|
(title "Guix Data Service"))
|
|
`((doctype "html")
|
|
(html
|
|
(head
|
|
(title ,title)
|
|
(meta (@ (http-equiv "Content-Type")
|
|
(content "text/html; charset=UTF-8")))
|
|
(meta (@ (http-equiv "Content-Language") (content "en")))
|
|
(meta (@ (name "author") (content "Christopher Baines")))
|
|
(meta (@ (name "viewport")
|
|
(content "width=device-width, initial-scale=1")))
|
|
(link
|
|
(@ (rel "stylesheet")
|
|
(media "screen")
|
|
(type "text/css")
|
|
(href "/assets/css/reset.css")))
|
|
(link
|
|
(@ (rel "stylesheet")
|
|
(media "screen")
|
|
(type "text/css")
|
|
(href "/assets/css/bootstrap.css")))
|
|
,@head
|
|
(link
|
|
(@ (rel "stylesheet")
|
|
(media "screen")
|
|
(type "text/css")
|
|
(href "/assets/css/screen.css"))))
|
|
(body (a (@ (id "top")))
|
|
,@body
|
|
(footer
|
|
(p "Copyright © 2016—2019 by the GNU Guix community."
|
|
(br)
|
|
"Now with even more " (span (@ (class "lambda")) "λ") "! ")
|
|
(p "This is free software. Download the "
|
|
(a (@ (href "https://git.savannah.gnu.org/cgit/guix/data-service.git/"))
|
|
"source code here") "."))))))
|
|
|
|
(define* (form-horizontal-control label query-parameters
|
|
#:key
|
|
name
|
|
help-text
|
|
required?
|
|
options
|
|
font-family
|
|
(type "text"))
|
|
(define (value->text value)
|
|
(match value
|
|
(#f "")
|
|
((? date? date)
|
|
(date->string date "~1 ~3"))
|
|
(other other)))
|
|
|
|
(let* ((input-id (hyphenate-words
|
|
(string-downcase label)))
|
|
(help-span-id (string-append
|
|
input-id "-help-text"))
|
|
(input-name (or name
|
|
(underscore-join-words
|
|
(string-downcase label))))
|
|
(has-error? (invalid-query-parameter?
|
|
(assq-ref query-parameters
|
|
(string->symbol input-name))))
|
|
(show-help-span?
|
|
(or help-text has-error? required?)))
|
|
`(div
|
|
(@ (class ,(string-append
|
|
"form-group form-group-lg"
|
|
(if has-error? " has-error" ""))))
|
|
(label (@ (for ,input-id)
|
|
(class "col-sm-2 control-label"))
|
|
,label)
|
|
(div
|
|
(@ (class "col-sm-9"))
|
|
,(if options
|
|
`(select (@ (class "form-control")
|
|
(style ,(if font-family
|
|
(string-append
|
|
"font-family: " font-family ";")
|
|
""))
|
|
(multiple #t)
|
|
(id ,input-id)
|
|
,@(if show-help-span?
|
|
`((aria-describedby ,help-span-id))
|
|
'())
|
|
|
|
(name ,input-name))
|
|
,@(let ((selected-options
|
|
(match (assq (string->symbol input-name)
|
|
query-parameters)
|
|
((_key . value)
|
|
value)
|
|
(_ '()))))
|
|
|
|
(map (match-lambda
|
|
((option-label . option-value)
|
|
`(option
|
|
(@ ,@(if (member option-value selected-options)
|
|
'((selected ""))
|
|
'())
|
|
(value ,option-value))
|
|
,(value->text option-label)))
|
|
(option-value
|
|
`(option
|
|
(@ ,@(if (member option-value selected-options)
|
|
'((selected ""))
|
|
'()))
|
|
,(value->text option-value))))
|
|
options)))
|
|
`(input (@ (class "form-control")
|
|
(style ,(if font-family
|
|
(string-append
|
|
"font-family: " font-family ";")
|
|
""))
|
|
(id ,input-id)
|
|
(type ,type)
|
|
,@(if required?
|
|
'((required #t))
|
|
'())
|
|
,@(if show-help-span?
|
|
`((aria-describedby ,help-span-id))
|
|
'())
|
|
(name ,input-name)
|
|
,@(match (assq (string->symbol input-name)
|
|
query-parameters)
|
|
(#f '())
|
|
((_key . ($ <invalid-query-parameter> value))
|
|
(if (string=? type "checkbox")
|
|
(if value
|
|
'((checked #t))
|
|
'())
|
|
`((value ,(value->text value)))))
|
|
((_key . value)
|
|
(if (string=? type "checkbox")
|
|
(if value
|
|
'((checked #t))
|
|
'())
|
|
`((value ,(value->text value)))))))))
|
|
,@(if show-help-span?
|
|
`((span (@ (id ,help-span-id)
|
|
(class "help-block"))
|
|
,@(if has-error?
|
|
(let ((message
|
|
(invalid-query-parameter-message
|
|
(assq-ref query-parameters
|
|
(string->symbol input-name)))))
|
|
`((p (strong
|
|
,(string-append
|
|
"Error: "
|
|
(if message
|
|
message
|
|
"invalid value."))))))
|
|
'())
|
|
,@(if required? '((strong "Required. ")) '())
|
|
,@(if help-text
|
|
(list help-text)
|
|
'())))
|
|
'())))))
|
|
|
|
(define (readme contents)
|
|
(layout
|
|
#:body
|
|
`(,(header)
|
|
(div
|
|
(@ (class "container"))
|
|
(div
|
|
(@ (class "row"))
|
|
(div
|
|
(@ (class "col-sm-12"))
|
|
(h1 "The README document")))
|
|
(div
|
|
(@ (class "row"))
|
|
(div
|
|
(@ (class "col-sm-12"))
|
|
(raw ,contents)))))))
|
|
|
|
(define (index git-repositories-and-revisions)
|
|
(layout
|
|
#:body
|
|
`(,(header)
|
|
(div
|
|
(@ (class "container"))
|
|
(div
|
|
(@ (class "row"))
|
|
(div
|
|
(@ (class "col-sm-12"))
|
|
(h1 (@ (style "display: inline-block;"))
|
|
"Guix Data Service")
|
|
(div
|
|
(@ (class "btn-group pull-right")
|
|
(style "margin-top: 1.3rem;")
|
|
(role "group"))
|
|
(a (@ (class "btn btn-lg btn-default")
|
|
(href "/statistics")
|
|
(role "button"))
|
|
"Statistics")
|
|
(a (@ (class "btn btn-lg btn-default")
|
|
(href "/jobs")
|
|
(role "button"))
|
|
"Jobs"))))
|
|
,@(map
|
|
(match-lambda
|
|
(((repository-id label url cgit-url-base) . branches-with-most-recent-commits)
|
|
`(div
|
|
(@ (class "row"))
|
|
(div
|
|
(@ (class "col-sm-12"))
|
|
(h3 (@ (style "display: inline-block;"))
|
|
,url)
|
|
,@(if (string-null? cgit-url-base)
|
|
'()
|
|
`((a (@ (style "padding-left: 0.8em;")
|
|
(href ,cgit-url-base))
|
|
"(View cgit)")))
|
|
,(if (null? branches-with-most-recent-commits)
|
|
'(p "No branches")
|
|
(table/branches-with-most-recent-commits
|
|
repository-id
|
|
(filter (lambda (data)
|
|
(not (string-null? (second data))))
|
|
branches-with-most-recent-commits)))))))
|
|
git-repositories-and-revisions)))))
|
|
|
|
(define (view-statistics guix-revisions-count derivations-count)
|
|
(layout
|
|
#:body
|
|
`(,(header)
|
|
(div
|
|
(@ (class "container"))
|
|
(div
|
|
(@ (class "row"))
|
|
(div
|
|
(@ (class "col-md-6"))
|
|
(h3 "Guix revisions")
|
|
(strong (@ (class "text-center")
|
|
(style "font-size: 2em; display: block;"))
|
|
,guix-revisions-count))
|
|
(div
|
|
(@ (class "col-md-6"))
|
|
(h3 "Derivations")
|
|
(strong (@ (class "text-center")
|
|
(style "font-size: 2em; display: block;"))
|
|
,derivations-count)))))))
|
|
|
|
(define (table/branches-with-most-recent-commits
|
|
git-repository-id branches-with-most-recent-commits)
|
|
`(table
|
|
(@ (class "table table-responsive"))
|
|
(thead
|
|
(tr
|
|
(th (@ (class "col-md-3")) "Name")
|
|
(th (@ (class "col-md-2")) "Date")
|
|
(th (@ (class "col-md-7")) "Commit")))
|
|
(tbody
|
|
,@(map
|
|
(match-lambda
|
|
((name commit date revision-exists? job-events)
|
|
`(tr
|
|
(td
|
|
(a (@ (href ,(string-append
|
|
"/repository/" (number->string git-repository-id)
|
|
"/branch/" name)))
|
|
,name))
|
|
(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")))))))))
|
|
branches-with-most-recent-commits))))
|
|
|
|
(define (view-builds stats builds)
|
|
(layout
|
|
#:body
|
|
`(,(header)
|
|
(div
|
|
(@ (class "container"))
|
|
(div
|
|
(@ (class "row"))
|
|
(div
|
|
(@ (class "col-sm-12"))
|
|
(h1 "Builds")
|
|
(table
|
|
(@ (class "table"))
|
|
(thead
|
|
(tr
|
|
(th (@ (class "col-md-2")) "Status")
|
|
(th (@ (class "col-md-2")) "Count")))
|
|
(tbody
|
|
,@(map
|
|
(match-lambda
|
|
((status count)
|
|
`(tr
|
|
(td ,(build-status-span status))
|
|
(td ,count))))
|
|
stats)))))
|
|
(div
|
|
(@ (class "row"))
|
|
(div
|
|
(@ (class "col-sm-12"))
|
|
(table
|
|
(@ (class "table"))
|
|
(thead
|
|
(tr
|
|
(th (@ (class "col-xs-2")) "Status")
|
|
(th (@ (class "col-xs-9")) "Derivation")
|
|
(th (@ (class "col-xs-1")) "Started at")
|
|
(th (@ (class "col-xs-1")) "Finished at")
|
|
(th (@ (class "col-xs-1")) "")))
|
|
(tbody
|
|
,@(map
|
|
(match-lambda
|
|
((build-id build-server-url derivation-file-name
|
|
status-fetched-at starttime stoptime status)
|
|
`(tr
|
|
(td (@ (class "text-center"))
|
|
,(build-status-span status))
|
|
(td (a (@ (href ,derivation-file-name))
|
|
,(display-store-item-short derivation-file-name)))
|
|
(td ,starttime)
|
|
(td ,stoptime)
|
|
(td (a (@ (href ,(simple-format
|
|
#f "~Abuild/~A" build-server-url build-id)))
|
|
"View build on " ,build-server-url)))))
|
|
builds)))))))))
|
|
|
|
(define (build-status-value->display-string value)
|
|
(assoc-ref
|
|
'(("scheduled" . "Scheduled")
|
|
("started" . "Started")
|
|
("succeeded" . "Succeeded")
|
|
("failed" . "Failed")
|
|
("failed-dependency" . "Failed (dependency)")
|
|
("failed-other" . "Failed (other)")
|
|
("canceled" . "Canceled")
|
|
("" . "Unknown"))
|
|
value))
|
|
|
|
(define (build-status-span status)
|
|
`(span (@ (class ,(string-append
|
|
"label label-"
|
|
(assoc-ref
|
|
'(("scheduled" . "info")
|
|
("started" . "primary")
|
|
("succeeded" . "success")
|
|
("failed" . "danger")
|
|
("failed-dependency" . "warning")
|
|
("failed-other" . "danger")
|
|
("canceled" . "default")
|
|
("" . "default"))
|
|
status)))
|
|
(style "display: inline-block; font-size: 1.2em; margin-top: 0.4em;"))
|
|
,(build-status-value->display-string status)))
|
|
|
|
(define (display-store-item-short item)
|
|
`((span (@ (style "font-size: small; font-family: monospace; display: block;"))
|
|
,(string-take item 44))
|
|
(span (@ (style "font-size: x-large; font-family: monospace; display: block;"))
|
|
,(string-drop item 44))))
|
|
|
|
(define (display-store-item item)
|
|
`((span (@ (style "font-size: small; font-family: monospace; white-space: nowrap;"))
|
|
,(string-take item 44))
|
|
(span (@ (style "font-size: x-large; font-family: monospace; white-space: nowrap;"))
|
|
,(string-drop item 44))))
|
|
|
|
(define (display-store-item-title item)
|
|
`(h1 (span (@ (style "font-size: 1em; font-family: monospace; display: block;"))
|
|
,(string-take item 44))
|
|
(span (@ (style "line-height: 1.7em; font-size: 1.5em; font-family: monospace;"))
|
|
,(string-drop item 44))))
|
|
|
|
(define (display-file-in-store-item filename)
|
|
(match (string-split filename #\/)
|
|
(("" "gnu" "store" item fileparts ...)
|
|
`(,(let ((full-item (string-append "/gnu/store/" item)))
|
|
`(a (@ (href ,full-item))
|
|
,(display-store-item-short full-item)))
|
|
,(string-append
|
|
"/" (string-join fileparts "/"))))))
|
|
|
|
(define (view-store-item filename derivations derivations-using-store-item-list)
|
|
(layout
|
|
#:body
|
|
`(,(header)
|
|
(div
|
|
(@ (class "container"))
|
|
(div
|
|
(@ (class "row"))
|
|
(div
|
|
(@ (class "col-sm-12"))
|
|
,(display-store-item-title filename)))
|
|
,@(map (lambda (derivation derivations-using-store-item)
|
|
`((div
|
|
(@ (class "row"))
|
|
(div
|
|
(@ (class "col-sm-12"))
|
|
(h4 "Derivation: ")
|
|
,(match derivation
|
|
((file-name output-id)
|
|
`(a (@ (href ,file-name))
|
|
,(display-store-item file-name))))))
|
|
(div
|
|
(@ (class "row"))
|
|
(div
|
|
(@ (class "col-sm-12"))
|
|
(h2 "Derivations using this store item "
|
|
,(let ((count (length derivations-using-store-item)))
|
|
(if (eq? count 100)
|
|
"(> 100)"
|
|
(simple-format #f "(~A)" count))))
|
|
(ul
|
|
(@ (class "list-unstyled"))
|
|
,(map
|
|
(match-lambda
|
|
((file-name)
|
|
`(li (a (@ (href ,file-name))
|
|
,(display-store-item file-name)))))
|
|
derivations-using-store-item))))))
|
|
derivations
|
|
derivations-using-store-item-list)))))
|
|
|
|
(define (view-derivation derivation derivation-inputs derivation-outputs
|
|
builds)
|
|
(layout
|
|
#:body
|
|
`(,(header)
|
|
(div
|
|
(@ (class "container"))
|
|
,(match derivation
|
|
((id file-name builder args env-vars system)
|
|
`(div
|
|
(@ (class "row"))
|
|
(div
|
|
(@ (class "col-sm-12"))
|
|
,(display-store-item-title file-name)))))
|
|
(div
|
|
(@ (class "row"))
|
|
(div
|
|
(@ (class "col-md-4"))
|
|
(h3 "Inputs")
|
|
,(if (null? derivation-inputs)
|
|
"No inputs"
|
|
`(table
|
|
(@ (class "table"))
|
|
(thead
|
|
(tr
|
|
(th "File name")))
|
|
(tdata
|
|
,@(map (match-lambda
|
|
((file-name output-name path)
|
|
`(tr
|
|
(td (a (@ (href ,file-name))
|
|
,(display-store-item-short path))))))
|
|
derivation-inputs)))))
|
|
(div
|
|
(@ (class "col-md-4"))
|
|
(h3 "Derivation details")
|
|
,(match derivation
|
|
((id file-name builder args env-vars system)
|
|
`(table
|
|
(@ (class "table"))
|
|
(tbody
|
|
(tr
|
|
(td "Builder")
|
|
(td ,(if (string=? "builtin:download"
|
|
builder)
|
|
"builtin:download"
|
|
`(a (@ (href ,builder))
|
|
,(display-file-in-store-item builder)))))
|
|
(tr
|
|
(td "System")
|
|
(td (samp ,system)))))))
|
|
(h3 "Build status")
|
|
,@(if (null? builds)
|
|
`((div
|
|
(@ (class "text-center"))
|
|
,(build-status-span "")))
|
|
(map
|
|
(match-lambda
|
|
((build-id build-server-url status-fetched-at
|
|
starttime stoptime status)
|
|
`(div
|
|
(@ (class "text-center"))
|
|
(div ,(build-status-span status))
|
|
(a (@ (style "display: inline-block; margin-top: 0.4em;")
|
|
(href ,(simple-format
|
|
#f "~Abuild/~A" build-server-url build-id)))
|
|
"View build on " ,build-server-url))))
|
|
builds)))
|
|
(div
|
|
(@ (class "col-md-4"))
|
|
(h3 "Outputs")
|
|
(table
|
|
(@ (class "table"))
|
|
(thead
|
|
(tr
|
|
(th "File name")))
|
|
(tdata
|
|
,@(map (match-lambda
|
|
((output-name path hash-algorithm hash recursive?)
|
|
`(tr
|
|
(td (a (@ (href ,path))
|
|
,(display-store-item-short path))))))
|
|
derivation-outputs)))))))))
|
|
|
|
(define (general-not-found header-text body)
|
|
(layout
|
|
#:body
|
|
`(,(header)
|
|
(div
|
|
(@ (class "container"))
|
|
(h1 ,header-text)
|
|
(p ,body)))))
|
|
|
|
(define (error-page message)
|
|
(layout
|
|
#:body
|
|
`(,(header)
|
|
(div (@ (class "container"))
|
|
(h1 "Error")
|
|
(p "An error occurred. Sorry about that!")
|
|
,message
|
|
(p (a (@ (href "/")) "Try something else?"))))))
|