aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorTSholokhova <tanja201396@gmail.com>2018-08-05 21:25:37 +0200
committerClément Lassieur <clement@lassieur.org>2018-09-30 17:08:15 +0200
commitcbf8e138354ab24b597e16b1a10d9d472d63bc53 (patch)
tree6c93e92aea3bc320bf88bf5c87f2c99bb50884e2
parent3b08d6ea9872e0649ccc5805538c6f9425a55f9a (diff)
downloadcuirass-cbf8e138354ab24b597e16b1a10d9d472d63bc53.tar
cuirass-cbf8e138354ab24b597e16b1a10d9d472d63bc53.tar.gz
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>
Diffstat
-rw-r--r--src/cuirass/database.scm11
-rw-r--r--src/cuirass/http.scm90
-rw-r--r--src/cuirass/templates.scm28
3 files changed, 91 insertions, 38 deletions
diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm
index e17d4f0..e949d1b 100644
--- a/src/cuirass/database.scm
+++ b/src/cuirass/database.scm
@@ -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)))))
diff --git a/src/cuirass/http.scm b/src/cuirass/http.scm
index 7878452..62294d3 100644
--- a/src/cuirass/http.scm
+++ b/src/cuirass/http.scm
@@ -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))
diff --git a/src/cuirass/templates.scm b/src/cuirass/templates.scm
index 3017880..fda3b48 100644
--- a/src/cuirass/templates.scm
+++ b/src/cuirass/templates.scm
@@ -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)))))
generated by cgit v1.2.3 (git 2.45.0) at 2024-11-21 17:53:30 +0000