guix
/
guix-cuirass
mirror of git://git.savannah.gnu.org/guix/guix-cuirass.git
2
0
Fork 0
Code Issues Releases Wiki Activity

templates: Add a navigation bar. 

* src/cuirass/database.scm (db-get-evaluation-specification): New exported
procedure.
* src/cuirass/http.scm (respond-html): Allow to pass CODE as argument.
(respond-html-eval-not-found): New procedure.
(url-handler): Fill navigation arguments.  Handle the case where the
evaluation doesn't exist.
* src/cuirass/templates.scm (navigation-items): New procedure.
(html-page): Add navigation bar.

Co-authored-by: Clément Lassieur <clement@lassieur.org>
This commit is contained in:
TSholokhova 2018-08-05 21:25:37 +02:00 committed by Clément Lassieur
parent 3b08d6ea98
commit cbf8e13835
No known key found for this signature in database
GPG Key ID: 89F96D4808F359C7
3 changed files with 91 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
src/cuirass/database.scm
View File

@ -53,6 +53,7 @@
db-get-evaluations-build-summary
db-get-evaluations-id-min
db-get-evaluations-id-max
db-get-evaluation-specification
read-sql-file
read-quoted-string
sqlite-exec
@ -751,3 +752,13 @@ AND (" status " IS NULL OR (" status " = 'pending'
OR (" status " = 'failed'
AND Builds.status > 0))))")))
(vector->list (car rows)))))
(define (db-get-evaluation-specification eval)
"Return specification of evaluation with id EVAL."
(with-db-critical-section db
(let ((rows (sqlite-exec db "
SELECT specification FROM Evaluations
WHERE id = " eval)))
(match rows
((row) (vector-ref row 0))
(() #f)))))

90
src/cuirass/http.scm
View File

@ -167,15 +167,19 @@ Hydra format."
(object->json-string
`((error . ,message)))))
(define (respond-html body)
(respond '((content-type . (application/xhtml+xml)))
#:body
(lambda (port)
(format
port "<!DOCTYPE html PUBLIC ~s ~s>"
"-//W3C//DTD XHTML 1.0 Transitional//EN"
"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd")
(sxml->xml body port))))
(define* (respond-html body #:key code)
(respond
(let ((content-type '((content-type . (application/xhtml+xml)))))
(if code
(build-response #:headers content-type #:code code)
content-type))
#:body
(lambda (port)
(format
port "<!DOCTYPE html PUBLIC ~s ~s>"
"-//W3C//DTD XHTML 1.0 Transitional//EN"
"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd")
(sxml->xml body port))))
(define (respond-static-file path)
;; PATH is a list of path components
@ -194,6 +198,13 @@ Hydra format."
404
(format #f "Build with ID ~a doesn't exist." build-id)))
(define (respond-html-eval-not-found eval-id)
(respond-html
(html-page "Page not found"
(format #f "Evaluation with ID ~a doesn't exist." eval-id)
'())
#:code 404))
(define (respond-build-log-not-found build)
(let ((drv (assq-ref build #:derivation)))
(respond-json-with-error
@ -275,7 +286,8 @@ Hydra format."
('()
(respond-html (html-page
"Cuirass"
(specifications-table (db-get-specifications)))))
(specifications-table (db-get-specifications))
'())))
(("jobset" name)
(respond-html
@ -291,32 +303,42 @@ Hydra format."
(html-page name (evaluation-info-table name
evaluations
evaluation-id-min
evaluation-id-max)))))
evaluation-id-max)
`(((#:name . ,name)
(#:link . ,(string-append "/jobset/" name))))))))
(("eval" id)
(respond-html
(let* ((params (request-parameters request))
(status (assq-ref params 'status))
(builds-id-max (db-get-builds-max id status))
(builds-id-min (db-get-builds-min id status))
(border-high-time (assq-ref params 'border-high-time))
(border-low-time (assq-ref params 'border-low-time))
(border-high-id (assq-ref params 'border-high-id))
(border-low-id (assq-ref params 'border-low-id)))
(html-page
"Evaluation"
(build-eval-table
(handle-builds-request `((evaluation . ,id)
(status . ,(and=> status string->symbol))
(nr . ,%page-size)
(order . finish-time+build-id)
(border-high-time . ,border-high-time)
(border-low-time . ,border-low-time)
(border-high-id . ,border-high-id)
(border-low-id . ,border-low-id)))
builds-id-min
builds-id-max
status)))))
(let* ((params (request-parameters request))
(status (assq-ref params 'status))
(builds-id-max (db-get-builds-max id status))
(builds-id-min (db-get-builds-min id status))
(border-high-time (assq-ref params 'border-high-time))
(border-low-time (assq-ref params 'border-low-time))
(border-high-id (assq-ref params 'border-high-id))
(border-low-id (assq-ref params 'border-low-id))
(specification (db-get-evaluation-specification id)))
(if specification
(respond-html
(html-page
"Evaluation"
(build-eval-table
(handle-builds-request
`((evaluation . ,id)
(status . ,(and=> status string->symbol))
(nr . ,%page-size)
(order . finish-time+build-id)
(border-high-time . ,border-high-time)
(border-low-time . ,border-low-time)
(border-high-id . ,border-high-id)
(border-low-id . ,border-low-id)))
builds-id-min
builds-id-max
status)
`(((#:name . ,specification)
(#:link . ,(string-append "/jobset/" specification)))
((#:name . ,(string-append "Evaluation " id))
(#:link . ,(string-append "/eval/" id))))))
(respond-html-eval-not-found id))))
(("static" path ...)
(respond-static-file path))

28
src/cuirass/templates.scm
View File

@ -26,7 +26,17 @@
evaluation-info-table
build-eval-table))
(define (html-page title body)
(define (navigation-items navigation)
(match navigation
(() '())
((item . rest)
(cons `(li (@ (class "nav-item"))
(a (@ (class "nav-link" ,(if (null? rest) " active" ""))
(href ,(assq-ref item #:link)))
,(assq-ref item #:name)))
(navigation-items rest)))))
(define (html-page title body navigation)
"Return HTML page with given TITLE and BODY."
`(html (@ (xmlns "http://www.w3.org/1999/xhtml")
(xml:lang "en")
@ -44,11 +54,21 @@
(href "/static/css/open-iconic-bootstrap.css")))
(title ,title))
(body
(nav (@ (class "navbar navbar-expand-lg navbar-light bg-light"))
(a (@ (class "navbar-brand") (href "/"))
(nav (@ (class "navbar navbar-expand navbar-light bg-light"))
(a (@ (class "navbar-brand pt-0")
(href "/"))
(img (@ (src "/static/images/logo.png")
(alt "logo")
(height "25")))))
(height "25")
(style "margin-top: -12px"))))
(div (@ (class "navbar-nav-scroll"))
(ul (@ (class "navbar-nav"))
(li (@ (class "nav-item"))
(a (@ (class "nav-link" ,(if (null? navigation)
" active" ""))
(href "/"))
Home))
,@(navigation-items navigation))))
(main (@ (role "main") (class "container pt-4 px-1"))
,body
(hr)))))