branch: master
commit 675cd04a8530fdc16f68758a410b91ce10d46b18
Author: TSholokhova <tanja201...@gmail.com>
Date: Sat Jul 21 15:39:10 2018 +0200
Add a web interface.
* Makefile.am (dist_sql_DATA): Add static files.
* src/cuirass/database.scm (assqx-ref): Export it.
(db-get-builds): Add 'evaluation' filter and filters for pagination.
(db-get-evaluations-build-summary, db-get-evaluations-id-min,
db-get-evaluations-id-max, db-get-builds-min, db-get-builds-max): New
exported
procedures.
* src/cuirass/http.scm (%static-directory): New parameter.
(%page-size, %file-mime-types, %file-white-list): New variables.
(handle-build-request, handle-builds-request): Move the
WITH-CRITICAL-SECTION
call out.
(url-handler): Add RESPOND-HTML, RESPOND-STATIC-FILE and RESPOND-NOT-FOUND
procedures. Call WITH-CRITICAL-SECTION sooner for the '/build',
'/api/latestbuilds' and '/api/queue' routes. Add '/', '/jobset/<name>',
'/eval/<id>', '/static/<path>' routes. Use RESPOND-NOT-FOUND when the route
isn't found.
* src/cuirass/templates.scm: New file.
(html-page, specifications-table, evaluation-info-table,
build-eval-table): New exported procedures.
(pagination): New procedure.
Signed-off-by: Clément Lassieur <clem...@lassieur.org>
---
Makefile.am | 20 ++++-
src/cuirass/database.scm | 174 +++++++++++++++++++++++++++---------
src/cuirass/http.scm | 158 +++++++++++++++++++++++++++------
src/cuirass/templates.scm | 222 ++++++++++++++++++++++++++++++++++++++++++++++
4 files changed, 505 insertions(+), 69 deletions(-)
diff --git a/Makefile.am b/Makefile.am
index 4f6c089..ac22601 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -4,6 +4,7 @@
# Copyright © 2016, 2017 Mathieu Lirzin <m...@gnu.org>
# Copyright © 2018 Ludovic Courtès <l...@gnu.org>
# Copyright © 2018 Clément Lassieur <clem...@lassieur.org>
+# Copyright © 2018 Tatiana Sholokhova <tanja201...@gmail.com>
#
# This file is part of Cuirass.
#
@@ -34,6 +35,10 @@ pkgobjectdir = $(guileobjectdir)/$(PACKAGE)
webmoduledir = $(guilesitedir)/web/server
webobjectdir = $(guileobjectdir)/web/server
sqldir = $(pkgdatadir)/sql
+staticdir = $(pkgdatadir)/static
+cssdir = $(staticdir)/css
+fontsdir = $(staticdir)/fonts
+imagesdir = $(staticdir)/images
dist_pkgmodule_DATA = \
src/cuirass/base.scm \
@@ -41,7 +46,8 @@ dist_pkgmodule_DATA = \
src/cuirass/http.scm \
src/cuirass/logging.scm \
src/cuirass/ui.scm \
- src/cuirass/utils.scm
+ src/cuirass/utils.scm \
+ src/cuirass/templates.scm
nodist_pkgmodule_DATA = \
src/cuirass/config.scm
@@ -61,6 +67,18 @@ dist_pkgdata_DATA = src/schema.sql
dist_sql_DATA = \
src/sql/upgrade-1.sql
+dist_css_DATA = \
+ src/static/css/bootstrap.css \
+ src/static/css/open-iconic-bootstrap.css
+dist_fonts_DATA = \
+ src/static/fonts/open-iconic.eot \
+ src/static/fonts/open-iconic.otf \
+ src/static/fonts/open-iconic.svg \
+ src/static/fonts/open-iconic.ttf \
+ src/static/fonts/open-iconic.woff
+dist_images_DATA = \
+ src/static/images/logo.png
+
TEST_EXTENSIONS = .scm .sh
AM_TESTS_ENVIRONMENT = \
env GUILE_AUTO_COMPILE='0' \
diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm
index df41d75..9b442c1 100644
--- a/src/cuirass/database.scm
+++ b/src/cuirass/database.scm
@@ -3,6 +3,7 @@
;;; Copyright © 2017 Mathieu Othacehe <m.othac...@gmail.com>
;;; Copyright © 2018 Ludovic Courtès <l...@gnu.org>
;;; Copyright © 2018 Clément Lassieur <clem...@lassieur.org>
+;;; Copyright © 2018 Tatiana Sholokhova <tanja201...@gmail.com>
;;;
;;; This file is part of Cuirass.
;;;
@@ -48,10 +49,16 @@
db-update-build-status!
db-get-build
db-get-builds
+ db-get-builds-min
+ db-get-builds-max
db-get-evaluations
+ db-get-evaluations-build-summary
+ db-get-evaluations-id-min
+ db-get-evaluations-id-max
read-sql-file
read-quoted-string
sqlite-exec
+ assqx-ref
;; Parameters.
%package-database
%package-schema-file
@@ -454,20 +461,20 @@ log file for DRV."
(#:repo-name . ,repo-name)
(#:outputs . ,(db-get-outputs db id))))))
+;; XXX Change caller and remove
+(define (assqx-ref filters key)
+ (match filters
+ (()
+ #f)
+ (((xkey xvalue) rest ...)
+ (if (eq? key xkey)
+ xvalue
+ (assqx-ref rest key)))))
+
(define (db-get-builds db filters)
"Retrieve all builds in database DB which are matched by given FILTERS.
-FILTERS is an assoc list which possible keys are 'jobset | 'job | 'system |
-'nr | 'order | 'status."
-
- ;; XXX Change caller and remove
- (define (assqx-ref filters key)
- (match filters
- (()
- #f)
- (((xkey xvalue) rest ...)
- (if (eq? key xkey)
- xvalue
- (assqx-ref rest key)))))
+FILTERS is an assoc list whose possible keys are 'id | 'jobset | 'job |
+'system | 'nr | 'order | 'status | 'evaluation."
(define (format-output name path)
`(,name . ((#:path . ,path))))
@@ -540,41 +547,57 @@ Assumes that if group id stays the same the group headers
stay the same."
(collect-outputs x-builds-id x-repeated-row '() rows)))))
(let* ((order (match (assq 'order filters)
- (('order 'build-id) "Builds.id ASC")
- (('order 'decreasing-build-id) "Builds.id DESC")
- (('order 'finish-time) "Builds.stoptime DESC")
- (('order 'start-time) "Builds.starttime DESC")
- (('order 'submission-time) "Builds.timestamp DESC")
+ (('order 'build-id) "id ASC")
+ (('order 'decreasing-build-id) "id DESC")
+ (('order 'finish-time) "stoptime DESC")
+ (('order 'finish-time+build-id) "stoptime DESC, id DESC")
+ (('order 'start-time) "starttime DESC")
+ (('order 'submission-time) "timestamp DESC")
(('order 'status+submission-time)
;; With this order, builds in 'running' state (-1) appear
;; before those in 'scheduled' state (-2).
- "Builds.status DESC, Builds.timestamp DESC")
- (_ "Builds.id DESC")))
- (stmt-text (format #f "\
-SELECT Builds.id, Outputs.name, Outputs.path, Builds.timestamp,
Builds.starttime, Builds.stoptime, Builds.log, Builds.status,
Builds.derivation,\
-Derivations.job_name, Derivations.system, Derivations.nix_name,\
-Specifications.name \
-FROM Builds \
-INNER JOIN Derivations ON Builds.derivation = Derivations.derivation AND
Builds.evaluation = Derivations.evaluation \
-INNER JOIN Evaluations ON Derivations.evaluation = Evaluations.id \
-INNER JOIN Specifications ON Evaluations.specification = Specifications.name \
-LEFT JOIN Outputs ON Outputs.build = Builds.id \
-WHERE (:id IS NULL OR (:id = Builds.id)) \
-AND (:jobset IS NULL OR (:jobset = Specifications.name)) \
-AND (:job IS NULL OR (:job = Derivations.job_name)) \
-AND (:system IS NULL OR (:system = Derivations.system)) \
-AND (:status IS NULL OR (:status = 'done' AND Builds.status >= 0) OR (:status
= 'pending' AND Builds.status < 0)) \
-ORDER BY ~a, Builds.id ASC LIMIT :nr;" order))
+ "status DESC, timestamp DESC")
+ (_ "id DESC")))
+ (stmt-text (format #f "SELECT * FROM (
+SELECT Builds.id, Outputs.name, Outputs.path, Builds.timestamp,
+Builds.starttime, Builds.stoptime, Builds.log, Builds.status,
+Builds.derivation, Derivations.job_name, Derivations.system,
+Derivations.nix_name,Specifications.name
+FROM Builds
+INNER JOIN Derivations ON Builds.derivation = Derivations.derivation
+AND Builds.evaluation = Derivations.evaluation
+INNER JOIN Evaluations ON Derivations.evaluation = Evaluations.id
+INNER JOIN Specifications ON Evaluations.specification = Specifications.name
+LEFT JOIN Outputs ON Outputs.build = Builds.id
+WHERE (:id IS NULL OR (:id = Builds.id))
+AND (:jobset IS NULL OR (:jobset = Specifications.name))
+AND (:job IS NULL OR (:job = Derivations.job_name))
+AND (:system IS NULL OR (:system = Derivations.system))
+AND (:evaluation IS NULL OR (:evaluation = Builds.evaluation))
+AND (:status IS NULL OR (:status = 'done' AND Builds.status >= 0) OR (:status
= 'pending' AND Builds.status < 0))
+AND (:borderlowtime IS NULL OR :borderlowid IS NULL OR ((:borderlowtime,
:borderlowid) < (Builds.stoptime, Builds.id)))
+AND (:borderhightime IS NULL OR :borderhighid IS NULL OR ((:borderhightime,
:borderhighid) > (Builds.stoptime, Builds.id)))
+ORDER BY
+CASE WHEN :borderlowtime IS NULL OR :borderlowid IS NULL THEN Builds.stoptime
ELSE -Builds.stoptime END DESC,
+CASE WHEN :borderlowtime IS NULL OR :borderlowid IS NULL THEN Builds.id ELSE
-Builds.id END DESC
+LIMIT :nr)
+ORDER BY ~a, id ASC;" order))
(stmt (sqlite-prepare db stmt-text #:cache? #t)))
- (sqlite-bind-arguments stmt #:id (assqx-ref filters 'id)
- #:jobset (assqx-ref filters 'jobset)
- #:job (assqx-ref filters 'job)
- #:system (assqx-ref filters 'system)
- #:status (and=> (assqx-ref filters 'status)
- object->string)
- #:nr (match (assqx-ref filters 'nr)
- (#f -1)
- (x x)))
+ (sqlite-bind-arguments
+ stmt
+ #:id (assqx-ref filters 'id)
+ #:jobset (assqx-ref filters 'jobset)
+ #:job (assqx-ref filters 'job)
+ #:evaluation (assqx-ref filters 'evaluation)
+ #:system (assqx-ref filters 'system)
+ #:status (and=> (assqx-ref filters 'status) object->string)
+ #:borderlowid (assqx-ref filters 'border-low-id)
+ #:borderhighid (assqx-ref filters 'border-high-id)
+ #:borderlowtime (assqx-ref filters 'border-low-time)
+ #:borderhightime (assqx-ref filters 'border-high-time)
+ #:nr (match (assqx-ref filters 'nr)
+ (#f -1)
+ (x x)))
(sqlite-reset stmt)
(group-outputs (sqlite-fold-right cons '() stmt))))
@@ -631,3 +654,68 @@ FROM Evaluations ORDER BY id DESC LIMIT " limit ";"))
(#:specification . ,specification)
(#:commits . ,(string-tokenize commits)))
evaluations))))))
+
+(define (db-get-evaluations-build-summary db spec limit border-low border-high)
+ (let loop ((rows (sqlite-exec db "
+SELECT E.id, E.commits, B.succeeded, B.failed, B.scheduled
+FROM (SELECT id, evaluation, SUM(status=0) as succeeded,
+SUM(status>0) as failed, SUM(status<0) as scheduled
+FROM Builds
+GROUP BY evaluation) B
+JOIN
+(SELECT id, commits
+FROM Evaluations
+WHERE (specification=" spec ")
+AND (" border-low "IS NULL OR (id >" border-low "))
+AND (" border-high "IS NULL OR (id <" border-high "))
+ORDER BY CASE WHEN " border-low "IS NULL THEN id ELSE -id END DESC
+LIMIT " limit ") E
+ON B.evaluation=E.id
+ORDER BY E.id ASC;"))
+ (evaluations '()))
+ (match rows
+ (() evaluations)
+ ((#(id commits succeeded failed scheduled) . rest)
+ (loop rest
+ (cons `((#:id . ,id)
+ (#:commits . ,commits)
+ (#:succeeded . ,succeeded)
+ (#:failed . ,failed)
+ (#:scheduled . ,scheduled))
+ evaluations))))))
+
+(define (db-get-evaluations-id-min db spec)
+ "Return the min id of evaluations for the given specification SPEC."
+ (let ((rows (sqlite-exec db "
+SELECT MIN(id) FROM Evaluations
+WHERE specification=" spec)))
+ (vector-ref (car rows) 0)))
+
+(define (db-get-evaluations-id-max db spec)
+ "Return the max id of evaluations for the given specification SPEC."
+ (let ((rows (sqlite-exec db "
+SELECT MAX(id) FROM Evaluations
+WHERE specification=" spec)))
+ (vector-ref (car rows) 0)))
+
+(define (db-get-builds-min db eval)
+ "Return the min build (stoptime, id) pair for
+ the given evaluation EVAL."
+ (let ((rows (sqlite-exec db "
+SELECT stoptime, MIN(id) FROM
+(SELECT id, stoptime FROM Builds
+WHERE evaluation=" eval " AND
+stoptime = (SELECT MIN(stoptime)
+FROM Builds WHERE evaluation=" eval "))")))
+ (vector->list (car rows))))
+
+(define (db-get-builds-max db eval)
+ "Return the max build (stoptime, id) pair for
+ the given evaluation EVAL."
+ (let ((rows (sqlite-exec db "
+SELECT stoptime, MAX(id) FROM
+(SELECT id, stoptime FROM Builds
+WHERE evaluation=" eval " AND
+stoptime = (SELECT MAX(stoptime)
+FROM Builds WHERE evaluation=" eval "))")))
+ (vector->list (car rows))))
diff --git a/src/cuirass/http.scm b/src/cuirass/http.scm
index a45e6b1..5a5eb52 100644
--- a/src/cuirass/http.scm
+++ b/src/cuirass/http.scm
@@ -3,6 +3,7 @@
;;; Copyright © 2017 Mathieu Othacehe <m.othac...@gmail.com>
;;; Copyright © 2018 Ludovic Courtès <l...@gnu.org>
;;; Copyright © 2018 Clément Lassieur <clem...@lassieur.org>
+;;; Copyright © 2018 Tatiana Sholokhova <tanja201...@gmail.com>
;;;
;;; This file is part of Cuirass.
;;;
@@ -20,11 +21,14 @@
;;; along with Cuirass. If not, see <http://www.gnu.org/licenses/>.
(define-module (cuirass http)
+ #:use-module (cuirass config)
#:use-module (cuirass database)
#:use-module (cuirass utils)
#:use-module (cuirass logging)
+ #:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
+ #:use-module (ice-9 binary-ports)
#:use-module (ice-9 match)
#:use-module (json)
#:use-module (web request)
@@ -33,8 +37,37 @@
#:use-module (web uri)
#:use-module (fibers)
#:use-module (fibers channels)
+ #:use-module (sxml simple)
+ #:use-module (cuirass templates)
+ #:use-module (guix utils)
+ #:use-module (guix build union)
#:export (run-cuirass-server))
+(define %static-directory
+ ;; Define to the static file directory.
+ (make-parameter (string-append
+ (or (getenv "CUIRASS_DATADIR")
+ (string-append %datadir "/" %package))
+ "/static")))
+
+(define %page-size 10)
+
+(define %file-mime-types
+ '(("css" . (text/css))
+ ("otf" . (font/otf))
+ ("woff" . (font/woff))
+ ("js" . (text/javascript))
+ ("png" . (image/png))
+ ("gif" . (image/gif))
+ ("html" . (text/html))))
+
+(define %file-white-list
+ '("css/bootstrap.css"
+ "css/open-iconic-bootstrap.css"
+ "fonts/open-iconic.otf"
+ "fonts/open-iconic.woff"
+ "images/logo.png"))
+
(define (build->hydra-build build)
"Convert BUILD to an assoc list matching hydra API format."
(define (bool->int bool)
@@ -70,19 +103,17 @@
(#:releasename . #nil)
(#:buildinputs_builds . #nil)))
-(define (handle-build-request db-channel build-id)
- "Retrieve build identified by BUILD-ID over DB-CHANNEL and convert it to
-hydra format. Return #f is not build was found."
- (let ((build (with-critical-section db-channel (db)
- (db-get-build db build-id))))
+(define (handle-build-request db build-id)
+ "Retrieve build identified by BUILD-ID over DB and convert it
+ to hydra format. Return #f is not build was found."
+ (let ((build (db-get-build db build-id)))
(and=> build build->hydra-build)))
-(define (handle-builds-request db-channel filters)
- "Retrieve all builds matched by FILTERS in DB-CHANNEL and convert them to
-Hydra format."
- (let ((builds (with-critical-section db-channel (db)
- (with-time-logging "builds request"
- (db-get-builds db filters)))))
+(define (handle-builds-request db filters)
+ "Retrieve all builds matched by FILTERS in DB and convert them
+ to Hydra format."
+ (let ((builds (with-time-logging "builds request"
+ (db-get-builds db filters))))
(map build->hydra-build builds)))
(define (request-parameters request)
@@ -136,6 +167,28 @@ 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-static-file path)
+ ;; PATH is a list of path components
+ (let ((file-name (string-join path "/"))
+ (file-path (string-join (cons* (%static-directory) path) "/")))
+ (if (and (member file-name %file-white-list)
+ (file-exists? file-path)
+ (not (file-is-directory? file-path)))
+ (respond `((content-type . ,(assoc-ref %file-mime-types
+ (file-extension file-path))))
+ #:body (call-with-input-file file-path get-bytevector-all))
+ (respond-not-found file-name))))
+
(define (respond-build-not-found build-id)
(respond-json-with-error
404
@@ -147,6 +200,11 @@ Hydra format."
404
(format #f "The build log of derivation ~a is not available." drv))))
+ (define (respond-not-found resource_name)
+ (respond (build-response #:code 404)
+ #:body (string-append "Resource not found: "
+ resource_name)))
+
(log-message "~a ~a" (request-method request)
(uri-path (request-uri request)))
@@ -159,8 +217,9 @@ Hydra format."
(with-critical-section db-channel (db)
(db-get-specifications db)))))
(("build" build-id)
- (let ((hydra-build (handle-build-request db-channel
- (string->number build-id))))
+ (let ((hydra-build
+ (with-critical-section db-channel (db)
+ (handle-build-request db (string->number build-id)))))
(if hydra-build
(respond-json (object->json-string hydra-build))
(respond-build-not-found build-id))))
@@ -203,11 +262,12 @@ Hydra format."
(valid-params? (assq-ref params 'nr)))
(if valid-params?
;; Limit results to builds that are "done".
- (respond-json (object->json-string
- (handle-builds-request db-channel
- `((status done)
- ,@params
- (order finish-time)))))
+ (respond-json
+ (object->json-string
+ (with-critical-section db-channel (db)
+ (handle-builds-request db `((status done)
+ ,@params
+ (order finish-time))))))
(respond-json-with-error 500 "Parameter not defined!"))))
(("api" "queue")
(let* ((params (request-parameters request))
@@ -218,18 +278,66 @@ Hydra format."
(object->json-string
;; Use the 'status+submission-time' order so that builds in
;; 'running' state appear before builds in 'scheduled' state.
- (handle-builds-request db-channel
- `((status pending)
- ,@params
- (order status+submission-time)))))
+ (with-critical-section db-channel (db)
+ (handle-builds-request db `((status pending)
+ ,@params
+ (order status+submission-time))))))
(respond-json-with-error 500 "Parameter not defined!"))))
+ ('()
+ (respond-html (html-page
+ "Cuirass"
+ (specifications-table
+ (with-critical-section db-channel (db)
+ (db-get-specifications db))))))
+
+ (("jobset" name)
+ (respond-html
+ (with-critical-section db-channel (db)
+ (let* ((evaluation-id-max (db-get-evaluations-id-max db name))
+ (evaluation-id-min (db-get-evaluations-id-min db name))
+ (params (request-parameters request))
+ (border-high (assqx-ref params 'border-high))
+ (border-low (assqx-ref params 'border-low))
+ (evaluations (db-get-evaluations-build-summary db
+ name
+ %page-size
+ border-low
+ border-high)))
+ (html-page name (evaluation-info-table name
+ evaluations
+ evaluation-id-min
+ evaluation-id-max))))))
+
+ (("eval" id)
+ (respond-html
+ (with-critical-section db-channel (db)
+ (let* ((builds-id-max (db-get-builds-max db id))
+ (builds-id-min (db-get-builds-min db id))
+ (params (request-parameters request))
+ (border-high-time (assqx-ref params 'border-high-time))
+ (border-low-time (assqx-ref params 'border-low-time))
+ (border-high-id (assqx-ref params 'border-high-id))
+ (border-low-id (assqx-ref params 'border-low-id)))
+ (html-page
+ "Evaluation"
+ (build-eval-table
+ (handle-builds-request db `((evaluation ,id)
+ (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))))))
+
+ (("static" path ...)
+ (respond-static-file path))
('method-not-allowed
;; 405 "Method Not Allowed"
(values (build-response #:code 405) #f db-channel))
(_
- (respond (build-response #:code 404)
- #:body (string-append "Resource not found: "
- (uri->string (request-uri request)))))))
+ (respond-not-found (uri->string (request-uri request))))))
(define* (run-cuirass-server db #:key (host "localhost") (port 8080))
(let* ((host-info (gethostbyname host))
diff --git a/src/cuirass/templates.scm b/src/cuirass/templates.scm
new file mode 100644
index 0000000..6ba3a06
--- /dev/null
+++ b/src/cuirass/templates.scm
@@ -0,0 +1,222 @@
+;;; templates.scm -- HTTP API
+;;; Copyright © 2018 Tatiana Sholokhova <tanja201...@gmail.com>
+;;;
+;;; This file is part of Cuirass.
+;;;
+;;; Cuirass is free software: you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation, either version 3 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; Cuirass 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 General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with Cuirass. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (cuirass templates)
+ #:use-module (ice-9 format)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #:export (html-page
+ specifications-table
+ evaluation-info-table
+ build-eval-table))
+
+(define (html-page title body)
+ "Return HTML page with given TITLE and BODY."
+ `(html (@ (xmlns "http://www.w3.org/1999/xhtml";)
+ (xml:lang "en")
+ (lang "en"))
+ (head
+ (meta (@ (charset "utf-8")))
+ (meta (@ (name "viewport")
+ (content ,(string-join '("width=device-width"
+ "initial-scale=1"
+ "shrink-to-fit=no")
+ ", "))))
+ (link (@ (rel "stylesheet")
+ (href "/static/css/bootstrap.css")))
+ (link (@ (rel "stylesheet")
+ (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 "/"))
+ (img (@ (src "/static/images/logo.png")
+ (alt "logo")
+ (height "25")))))
+ (main (@ (role "main") (class "container pt-4 px-1"))
+ ,body
+ (hr)))))
+
+(define (specifications-table specs)
+ "Return HTML for the SPECS table."
+ `((p (@ (class "lead")) "Specifications")
+ (table
+ (@ (class "table table-sm table-hover"))
+ ,@(if (null? specs)
+ `((th (@ (scope "col")) "No elements here."))
+ `((thead (tr (th (@ (scope "col")) Name)
+ (th (@ (scope "col")) Inputs)))
+ (tbody
+ ,@(map
+ (lambda (spec)
+ `(tr (td (a (@ (href "/jobset/" ,(assq-ref spec #:name)))
+ ,(assq-ref spec #:name)))
+ (td ,(string-join
+ (map (lambda (input)
+ (format #f "~a (on ~a)"
+ (assq-ref input #:name)
+ (assq-ref input #:branch)))
+ (assq-ref spec #:inputs)) ", "))))
+ specs)))))))
+
+(define (pagination first-link prev-link next-link last-link)
+ "Return html page navigation buttons with LINKS."
+ `(div (@ (class row))
+ (nav
+ (@ (class "mx-auto") (aria-label "Page navigation"))
+ (ul (@ (class "pagination"))
+ (li (@ (class "page-item"))
+ (a (@ (class "page-link")
+ (href ,first-link))
+ "<< First"))
+ (li (@ (class "page-item"
+ ,(if (string-null? prev-link) " disabled")))
+ (a (@ (class "page-link")
+ (href ,prev-link))
+ "< Previous"))
+ (li (@ (class "page-item"
+ ,(if (string-null? next-link) " disabled")))
+ (a (@ (class "page-link")
+ (href ,next-link))
+ "Next >"))
+ (li (@ (class "page-item"))
+ (a (@ (class "page-link")
+ (href ,last-link))
+ "Last >>"))))))
+
+(define (evaluation-info-table name evaluations id-min id-max)
+ "Return HTML for the EVALUATION table NAME. ID-MIN and ID-MAX are
+ global minimal and maximal id."
+ `((p (@ (class "lead")) "Evaluations of " ,name)
+ (table
+ (@ (class "table table-sm table-hover table-striped"))
+ ,@(if (null? evaluations)
+ `((th (@ (scope "col")) "No elements here."))
+ `((thead
+ (tr
+ (th (@ (scope "col")) "#")
+ (th (@ (scope "col")) Commits)
+ (th (@ (scope "col")) Success)))
+ (tbody
+ ,@(map
+ (lambda (row)
+ `(tr (th (@ (scope "row"))
+ (a (@ (href "/eval/" ,(assq-ref row #:id)))
+ ,(assq-ref row #:id)))
+ (td ,(string-join
+ (map (cut substring <> 0 7)
+ (string-tokenize (assq-ref row #:commits)))
+ ", "))
+ (td (a (@ (href "#") (class "badge badge-success"))
+ ,(assq-ref row #:succeeded))
+ (a (@ (href "#") (class "badge badge-danger"))
+ ,(assq-ref row #:failed))
+ (a (@ (href "#") (class "badge badge-secondary"))
+ ,(assq-ref row #:scheduled)))))
+ evaluations)))))
+ ,(if (null? evaluations)
+ (pagination "" "" "" "")
+ (let* ((eval-ids (map (cut assq-ref <> #:id) evaluations))
+ (page-id-min (last eval-ids))
+ (page-id-max (first eval-ids)))
+ (pagination
+ (format #f "?border-high=~d" (1+ id-max))
+ (if (= page-id-max id-max)
+ ""
+ (format #f "?border-low=~d" page-id-max))
+ (if (= page-id-min id-min)
+ ""
+ (format #f "?border-high=~d" page-id-min))
+ (format #f "?border-low=~d" (1- id-min)))))))
+
+(define (build-eval-table builds build-min build-max)
+ "Return HTML for the BUILDS table NAME. BUILD-MIN and BUILD-MAX are
+ global minimal and maximal (stoptime, id) pairs."
+ (define (table-header)
+ `(thead
+ (tr
+ (th (@ (scope "col")) '())
+ (th (@ (scope "col")) ID)
+ (th (@ (scope "col")) Specification)
+ (th (@ (scope "col")) "Finished at")
+ (th (@ (scope "col")) Job)
+ (th (@ (scope "col")) Nixname)
+ (th (@ (scope "col")) System))))
+
+ (define (table-row build)
+ `(tr
+ (td ,(case (assq-ref build #:buildstatus)
+ ((0) `(span (@ (class "oi oi-check text-success")
+ (title "Succeeded")
+ (aria-hidden "true"))
+ ""))
+ ((1 2 3 4) `(span (@ (class "oi oi-x text-danger")
+ (title "Failed")
+ (aria-hidden "true"))
+ ""))
+ (else `(span (@ (class "oi oi-clock text-warning")
+ (title "Scheduled")
+ (aria-hidden "true"))
+ ""))))
+ (th (@ (scope "row")),(assq-ref build #:id))
+ (td ,(assq-ref build #:jobset))
+ (td ,(strftime "%c" (localtime (assq-ref build #:stoptime))))
+ (td ,(assq-ref build #:job))
+ (td ,(assq-ref build #:nixname))
+ (td ,(assq-ref build #:system))))
+
+ (define (build-id build)
+ (match build
+ ((stoptime id) id)))
+
+ (define (build-stoptime build)
+ (match build
+ ((stoptime id) stoptime)))
+
+ `((table
+ (@ (class "table table-sm table-hover table-striped"))
+ ,@(if (null? builds)
+ `((th (@ (scope "col")) "No elements here."))
+ `(,(table-header)
+ (tbody ,@(map table-row builds)))))
+ ,(if (null? builds)
+ (pagination "" "" "" "")
+ (let* ((build-time-ids (map (lambda (row)
+ (list (assq-ref row #:stoptime)
+ (assq-ref row #:id)))
+ builds))
+ (page-build-min (last build-time-ids))
+ (page-build-max (first build-time-ids)))
+ (pagination
+ (format #f "?border-high-time=~d&border-high-id=~d"
+ (build-stoptime build-max)
+ (1+ (build-id build-max)))
+ (if (equal? page-build-max build-max)
+ ""
+ (format #f "?border-low-time=~d&border-low-id=~d"
+ (build-stoptime page-build-max)
+ (build-id page-build-max)))
+ (if (equal? page-build-min build-min)
+ ""
+ (format #f "?border-high-time=~d&border-high-id=~d"
+ (build-stoptime page-build-min)
+ (build-id page-build-min)))
+ (format #f "?border-low-time=~d&border-low-id=~d"
+ (build-stoptime build-min)
+ (1- (build-id build-min))))))))
