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 "" - "-//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 "" + "-//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)))))