;;; Guix QA Frontpage
;;;
;;; Copyright © 2022 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-qa-frontpage view util)
#:use-module (guix-data-service config)
#:use-module (guix-data-service web query-parameters)
#:use-module (guix-data-service web util)
#:use-module (guix-data-service web html-utils)
#:use-module ((guix-data-service web render) #:prefix guix-data-service:)
#:use-module (ice-9 ftw)
#:use-module (ice-9 vlist)
#:use-module (ice-9 match)
#:use-module (ice-9 binary-ports)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-26)
#:use-module (web uri)
#:use-module (web response)
#:use-module (texinfo)
#:use-module (texinfo html)
#:use-module (json)
#:export (layout
header
form-horizontal-control
display-possible-store-item
display-store-item
display-store-item-short
table/branches-with-most-recent-commits
render-html
general-not-found
error-page
static-asset-from-store-renderer
static-asset-from-directory-renderer))
(define* (layout #:key
(head '())
(body '())
title
description)
`((doctype "html")
(html
(@ (lang "en"))
(head
(title ,(if title
(string-append title " — Guix Quality Assurance")
"Guix Quality Assurance"))
(meta (@ (http-equiv "Content-Type")
(content "text/html; charset=UTF-8")))
(meta (@ (name "viewport")
(content "width=device-width, initial-scale=1")))
,@(if description
`((meta
(@ (name "description")
(content ,description))))
'())
(link
(@ (rel "stylesheet")
(media "screen")
(type "text/css")
(href "/assets/css/mvp.css")))
(style
"
:root {
--justify-important: left;
--justify-normal: center;
--line-height: 1.5;
}
table td,
table th,
table tr {
text-align: center;
}
header, main {
padding: 1rem;
}
main > header {
border-bottom: 2px dashed orange;
}
.row {
display: flex;
border-bottom: 2px dashed orange;
}
.two-element-row section {
width: 50%;
}
.row section {
flex-grow: 1;
padding-left: 10px;
margin-top: 10px;
margin-bottom: 10px;
}
.row section:not(:last-child) {
border-right: 2px dashed orange;
}
.monospace {
font-family: monospace;
font-size: 16px;
}
@media (min-width: 700px) {
.large-screen-float-right {
float: right;
}
}
.darkgreen-dot {
vertical-align: text-bottom;
height: 23px;
width: 23px;
background-color: #006400;
border-radius: 50%;
display: inline-block;
text-align: center;
}
.green-dot {
vertical-align: text-bottom;
height: 23px;
width: 23px;
background-color: #28a745;
border-radius: 50%;
display: inline-block;
text-align: center;
}
.orange-dot {
vertical-align: text-bottom;
height: 23px;
width: 23px;
background-color: orange;
border-radius: 50%;
display: inline-block;
text-align: center;
}
.yellow-dot {
vertical-align: text-bottom;
height: 23px;
width: 23px;
background-color: yellow;
border-radius: 50%;
display: inline-block;
text-align: center;
}
.purple-dot {
vertical-align: text-bottom;
height: 23px;
width: 23px;
background-color: purple;
border-radius: 50%;
display: inline-block;
text-align: center;
}
.lightblue-dot {
vertical-align: text-bottom;
height: 23px;
width: 23px;
background-color: lightblue;
border-radius: 50%;
display: inline-block;
text-align: center;
}
.red-dot {
vertical-align: text-bottom;
height: 23px;
width: 23px;
background-color: red;
border-radius: 50%;
display: inline-block;
text-align: center;
}
.darkred-dot {
vertical-align: text-bottom;
height: 23px;
width: 23px;
background-color: darkred;
border-radius: 50%;
display: inline-block;
text-align: center;
}
.pink-dot {
vertical-align: text-bottom;
height: 23px;
width: 23px;
background-color: pink;
border-radius: 50%;
display: inline-block;
text-align: center;
}
.grey-dot {
vertical-align: text-bottom;
height: 23px;
width: 23px;
background-color: grey;
border-radius: 50%;
display: inline-block;
text-align: center;
}
")
,@head)
(body (header
(h1
(img (@ (style "height: 1.4em;")
(src "/assets/img/guix.svg")))
(span
(@ (style "position: relative; left: -0.3em;"))
"Guix QA"
,@(if title
`(": " ,title)
'()))))
,@body))))
(define* (form-horizontal-control label query-parameters
#:key
name
help-text
required?
options
(allow-selecting-multiple-options #t)
font-family
(type "text")
(null-string-value "none"))
(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? (let ((val
(assq-ref query-parameters
(string->symbol input-name))))
(if (list? val)
(any invalid-query-parameter? val)
(invalid-query-parameter? val))))
(show-help-span?
(or help-text has-error? required?)))
(if (string=? type "hidden")
`(input (@ (class "form-control")
(id ,input-id)
(type ,type)
(name ,input-name)
,@(match (assq (string->symbol input-name)
query-parameters)
(#f '())
((_key . value)
`((value ,(value->text value)))))))
`(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 ";")
""))
,@(if allow-selecting-multiple-options
'((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)
(if (not allow-selecting-multiple-options)
(list value)
value))
(_ '()))))
(map (match-lambda
((option-label . option-value)
`(option
(@ ,@(if (member (if (and
(string? option-value)
(string=? option-value
null-string-value))
""
option-value)
selected-options)
'((selected ""))
'())
(value ,option-value))
,(value->text option-label)))
(option-value
`(option
(@ ,@(if (member (if (and
(string? option-value)
(string=? option-value
null-string-value))
""
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* ((val
(assq-ref query-parameters
(string->symbol input-name)))
(messages
(map invalid-query-parameter-message
(if (list? val)
val
(list val)))))
`((p
,@(if (null? messages)
'(string "Error: invalid value")
(map
(lambda (message)
`(strong
(@ (style "display: block;"))
"Error: "
,@(if (list? message)
message
(list message))))
(remove (lambda (v)
(eq? #f v))
messages))))))
'())
,@(if required? '((strong "Required. ")) '())
,@(if help-text
(list help-text)
'())))
'()))))))
(define render-html
guix-data-service:render-html)
(define (general-not-found header-text body)
(layout
#:body
`((main
(h1 ,header-text)
(p ,body)))))
(define* (error-page #:optional error)
(layout
#:body
`((main
(h1 "An error occurred")
(p "Sorry about that!")
,@(if error
(match error
((key . args)
`((b ,key)
(pre ,args))))
'())))))
(define file-mime-types
'(("css" . (text/css))
("js" . (text/javascript))
("svg" . (image/svg+xml))
("png" . (image/png))
("gif" . (image/gif))
("woff" . (application/font-woff))
("ttf" . (application/octet-stream))
("html" . (text/html))))
(define (static-asset-from-store-renderer assets-directory)
(define last-modified
;; Use the process start time as the last modified time, as the file
;; metadata in the store is normalised.
(current-time))
(define files
(file-system-fold
(const #t) ; enter
(lambda (filename stat result)
(let ((relative-filename (string-drop filename
(+ 1 ; to account for the /
(string-length
assets-directory)))))
(cons (cons relative-filename
(call-with-input-file filename
get-bytevector-all))
result)))
(lambda (name stat result) result) ; down
(lambda (name stat result) result) ; up
(lambda (name stat result) result) ; skip
(lambda (name stat errno result)
(error name))
'()
assets-directory))
(define (send-file path contents)
(list `((content-type
. ,(assoc-ref file-mime-types
(file-extension path)))
(last-modified . ,(time-utc->date last-modified))
(cache-control . (public
;; Set the max-age at 5 minutes, as the files
;; could change when the code changes
(max-age . ,(* 60 5)))))
contents))
(lambda (path headers)
(and=> (assoc-ref files path)
(lambda (contents)
(cond ((assoc-ref headers 'if-modified-since)
=>
(lambda (client-date)
(if (time>? last-modified
(date->time-utc client-date))
(send-file path contents)
(list (build-response #:code 304) ; "Not Modified"
#f))))
(else
(send-file path contents)))))))
(define (static-asset-from-directory-renderer assets-directory)
(lambda (path headers)
(render-static-file assets-directory path headers)))
(define %not-slash
(char-set-complement (char-set #\/)))
(define (render-static-file root path headers)
(let ((file-name (string-append root "/" path)))
(if (not (any (cut string-contains <> "..")
(string-tokenize path %not-slash)))
(let* ((stat (stat file-name #f))
(modified (and stat
(make-time time-utc 0 (stat:mtime stat)))))
(define (send-file)
(list `((content-type
. ,(assoc-ref file-mime-types
(file-extension file-name)))
(last-modified . ,(time-utc->date modified)))
(call-with-input-file file-name get-bytevector-all)))
(if (and stat (not (eq? 'directory (stat:type stat))))
(cond ((assoc-ref headers 'if-modified-since)
=>
(lambda (client-date)
(if (time>? modified (date->time-utc client-date))
(send-file)
(list (build-response #:code 304) ;"Not Modified"
#f))))
(else
(send-file)))
#f))
#f)))