[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[no subject]
|
From: |
Tatiana |
|
Date: |
Sat, 21 Jul 2018 09:45:42 -0400 (EDT) |
branch: web-interface
commit 6a540b1ad4716525f5671251d4e54965e642415f
Author: TSholokhova <address@hidden>
Date: Sat Jul 21 15:39:10 2018 +0200
Add web-interface.
Add basic HTML templates, main and specification builds pages.
* src/cuirass/templates.scm: New file. Add main page template. Add
builds tables (latest and queue). Add hyperref from the main page to the builds
pages.
* Makefile.am (dist_pkgmodule_DATA): Add it.
* src/cuirass/http.scm (url-handler): Add handler for “status”
endpoint. (%static-directory, file-mime-types): New variables. (url-handler):
Add handler for “/status/<repo_name>”; add handler for static files.
Implement first feature. Add bootstrap style.
* src/cuirass/templates.scm: Bootstrap based html templates. New
functions: evaluation-info-table, build-eval-table, pagination.
* src/cuirass/database.scm: Add new requests to database:
db-get-evaluations-info, db-get-evaluations-count. Add evaluation filter to
db-get-builds.
* src/cuirass/http.scm (url-handler): Change "status" endpoint to
"/". Add endpoints: ("jobset" name), ("eval" id).
Change HTML5 to XHTML. Fix codestyle.
* src/cuirass/http.scm (respond-html): Add XHTML preamble and
content-type.
* src/cuirass/templates.scm (html-page): Add XHTML preamble; fix
codestyle.
* src/cuirass/database.scm: Fix codestyle.
Add white-list.
* src/cuirass/http.scm (respond-static-file, file-white-list): Add
white list check.
Update id pagination.
* src/cuirass/http.scm: Change parameters.
* src/cuirass/templates.scm: Fix pagination function. Added min and
max functions for lists.
* src/cuirass/database.scm: Add borders parameters to evaluation
request.
Update id pagination (previous+last buttons).
* src/cuirass/templates.scm: Add buttons for pagination.
* src/cuirass/database.scm(db-get-evaluations-build-summary):
Implement different order for low and high borders.
Add pagination for each evaluation page.
* src/cuirass/templates.scm (build-eval-table): Add pagination.
* src/cuirass/database.scm: Add border filters for pagination in
db-get-builds. Add functions for searching max and min stoptimes.
* src/cuirass/http.scm: Add pagination parameters in "eval" query.
Fix codestyle.
* src/cuirass/templates.scm: Fix codestyle.
* src/cuirass/database.scm: Fix codestyle.
* src/cuirass/http.scm: Fix codestyle.
* tests/database.scm: Fix test.
* Makefile.am: Add static files paths.
---
Makefile.am | 19 +++++-
src/cuirass/database.scm | 149 +++++++++++++++++++++++++++++++---------
src/cuirass/http.scm | 153 ++++++++++++++++++++++++++++++++++++-----
src/cuirass/templates.scm | 171 ++++++++++++++++++++++++++++++++++++++++++++++
tests/database.scm | 2 +-
5 files changed, 443 insertions(+), 51 deletions(-)
diff --git a/Makefile.am b/Makefile.am
index d372b9e..ed38317 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -32,6 +32,10 @@ pkgmoduledir = $(guilesitedir)/$(PACKAGE)
pkgobjectdir = $(guileobjectdir)/$(PACKAGE)
webmoduledir = $(guilesitedir)/web/server
webobjectdir = $(guileobjectdir)/web/server
+staticdir = $(pkgdatadir)/static
+cssdir = $(staticdir)/css
+fontsdir = $(staticdir)/fonts
+imagesdir = $(staticdir)/images
dist_pkgmodule_DATA = \
src/cuirass/base.scm \
@@ -39,7 +43,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
@@ -56,6 +61,18 @@ nodist_webobject_DATA = \
dist_pkgdata_DATA = src/schema.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 a1398bc..dda808c 100644
--- a/src/cuirass/database.scm
+++ b/src/cuirass/database.scm
@@ -2,6 +2,7 @@
;;; Copyright © 2016, 2017 Mathieu Lirzin <address@hidden>
;;; Copyright © 2017 Mathieu Othacehe <address@hidden>
;;; Copyright © 2018 Ludovic Courtès <address@hidden>
+;;; Copyright © 2018 Tatiana Sholokhova <address@hidden>
;;;
;;; This file is part of Cuirass.
;;;
@@ -45,10 +46,17 @@
db-update-build-status!
db-get-build
db-get-builds
+ db-get-builds-id-min
+ db-get-builds-id-max
db-get-evaluations
+ db-get-evaluations-build-summary
+ db-get-evaluations-count
+ 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
@@ -376,20 +384,20 @@ log file for DRV."
(#:outputs . ,(db-get-outputs db id))
(#:branch . ,branch)))))
+;; 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 'project | '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)))))
+'system | 'nr | 'order | 'status | 'evaluation "
(define (format-output name path)
`(,name . ((#:path . ,path))))
@@ -448,12 +456,11 @@ Assumes that if group id stays the same the group headers
stay the same."
(let ((outputs (cons-output x-output-name x-output-path outputs)))
(collect-outputs repeated-builds-id repeated-row outputs rest)))
((#(x-builds-id x-output-name x-output-path other-cells ...) . rest)
- (cons (finish-group) ;finish current group
-
+ (cons (finish-group);finish current group
;; Start new group.
(let* ((outputs (cons-output x-output-name x-output-path '()))
(x-repeated-row (list->vector other-cells)))
- (collect-outputs x-builds-id x-repeated-row outputs rest))))))
+ (collect-outputs x-builds-id x-repeated-row outputs
rest))))))
(define (group-outputs rows)
(match rows
@@ -462,18 +469,25 @@ Assumes that if group id stays the same the group headers
stay the same."
(let ((x-repeated-row (list->vector other-cells)))
(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 '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 "\
+ (let*
+ ((order
+ (match
+ (assq 'order filters)
+ (('order 'build-id) "id ASC")
+ (('order 'decreasing-build-id) "id DESC")
+ (('order 'finish-time) "stoptime 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")))
+ "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.repo_name, Specifications.branch \
@@ -487,19 +501,28 @@ AND (:project IS NULL OR (:project =
Specifications.repo_name)) \
AND (:jobset IS NULL OR (:jobset = Specifications.branch)) \
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)) \
-ORDER BY ~a, Builds.id ASC LIMIT :nr;" order))
- (stmt (sqlite-prepare db stmt-text #:cache? #t)))
- (sqlite-bind-arguments stmt #:id (assqx-ref filters 'id)
+AND (:borderlow IS NULL OR (:borderlow < Builds.stoptime)) \
+AND (:borderhigh IS NULL OR (:borderhigh > Builds.stoptime))
+ORDER BY CASE WHEN :borderlow IS NULL THEN Builds.stoptime ELSE
-Builds.stoptime 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)
#:project (assqx-ref filters 'project)
#: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)
+ #:borderlow (assqx-ref filters 'border-low)
+ #:borderhigh (assqx-ref filters 'border-high)
#:nr (match (assqx-ref filters 'nr)
- (#f -1)
- (x x)))
+ (#f -1)
+ (x x)))
(sqlite-reset stmt)
(group-outputs (sqlite-fold-right cons '() stmt))))
@@ -556,3 +579,67 @@ FROM Evaluations ORDER BY id DESC LIMIT " limit ";"))
(#:specification . ,specification)
(#:revision . ,revision))
evaluations))))))
+
+(define (db-get-evaluations-build-summary db spec limit border-low border-high)
+ (let loop
+ ((rows (sqlite-exec db
+"SELECT E.id, E.revision, 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, revision \
+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 revision succeeded failed scheduled) . rest)
+ (loop rest
+ (cons `((#:id . ,id)
+ (#:revision . ,revision)
+ (#:succeeded . ,succeeded)
+ (#:failed . ,failed)
+ (#:scheduled . ,scheduled))
+ evaluations))))))
+
+(define (db-get-evaluations-count db spec)
+ "Return the number of evaluations of the given specification SPEC."
+ (let ((rows (sqlite-exec db
+"SELECT COUNT(id) FROM Evaluations \
+WHERE specification=" spec)))
+ (array-ref (list-ref rows 0) 0)))
+
+(define (db-get-evaluations-id-max db spec)
+ "Return the max id of evaluations of the given specification SPEC."
+ (let ((rows (sqlite-exec db
+"SELECT MAX(id) FROM Evaluations
+WHERE specification=" spec)))
+ (array-ref (list-ref rows 0) 0)))
+
+(define (db-get-evaluations-id-min db spec)
+ "Return the min id of evaluations of the given specification SPEC."
+ (let ((rows (sqlite-exec db
+"SELECT MIN(id) FROM Evaluations
+WHERE specification=" spec)))
+ (array-ref (list-ref rows 0) 0)))
+
+(define (db-get-builds-id-max db eval)
+ "Return the min id of build of the given evaluation EVAL."
+ (let ((rows (sqlite-exec db
+"SELECT MAX(stoptime) FROM Builds \
+WHERE evaluation=" eval)))
+ (array-ref (list-ref rows 0) 0)))
+
+(define (db-get-builds-id-min db eval)
+ "Return the max id of build of the given evaluation EVAL."
+ (let ((rows (sqlite-exec db
+"SELECT MIN(stoptime) FROM Builds \
+WHERE evaluation=" eval)))
+ (array-ref (list-ref rows 0) 0)))
diff --git a/src/cuirass/http.scm b/src/cuirass/http.scm
index e911b9b..dcf1641 100644
--- a/src/cuirass/http.scm
+++ b/src/cuirass/http.scm
@@ -1,7 +1,9 @@
+
;;;; http.scm -- HTTP API
;;; Copyright © 2016 Mathieu Lirzin <address@hidden>
;;; Copyright © 2017 Mathieu Othacehe <address@hidden>
;;; Copyright © 2018 Ludovic Courtès <address@hidden>
+;;; Copyright © 2018 Tatiana Sholokhova <address@hidden>
;;;
;;; This file is part of Cuirass.
;;;
@@ -22,8 +24,10 @@
#: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)
@@ -32,29 +36,52 @@
#: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 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)
(if bool 1 0))
-
(define finished?
(not (memv (assq-ref build #:status)
(list (build-status scheduled)
(build-status started)))))
-
`((#:id . ,(assq-ref build #:id))
(#:project . ,(assq-ref build #:repo-name))
(#:jobset . ,(assq-ref build #:branch))
(#:job . ,(assq-ref build #:job-name))
-
;; Hydra's API uses "timestamp" as the time of the last useful event for
;; that build: evaluation or completion.
(#:timestamp . ,(if finished?
(assq-ref build #:stoptime)
(assq-ref build #:timestamp)))
-
(#:starttime . ,(assq-ref build #:starttime))
(#:stoptime . ,(assq-ref build #:stoptime))
(#:derivation . ,(assq-ref build #:derivation))
@@ -71,15 +98,15 @@
(#: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."
+ "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))))
(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."
+ "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)))))
@@ -99,11 +126,11 @@ Hydra format."
(match key-symbol
('id (string->number param))
('nr (string->number param))
+ ('page (string->number param))
(_ param)))))))
(string-split query #\&))
'())))
-
;;;
;;; Web server.
;;;
@@ -115,6 +142,11 @@ Hydra format."
(define (request-path-components request)
(split-and-decode-uri-path (uri-path (request-uri request))))
+(define (normalize-parameter parameter)
+ (if parameter
+ (list-ref parameter 0)
+ #f))
+
(define (url-handler request body db-channel)
(define* (respond response #:key body (db-channel db-channel))
@@ -136,6 +168,27 @@ 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 \"-//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 (handle-build-request
+ db-channel
+ (string->number build-id))))
(if hydra-build
(respond-json (object->json-string hydra-build))
(respond-build-not-found build-id))))
@@ -204,10 +263,11 @@ Hydra format."
(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)))))
+ (handle-builds-request
+ db-channel
+ `((status done)
+ ,@params
+ (order finish-time)))))
(respond-json-with-error 500 "Parameter not defined!"))))
(("api" "queue")
(let* ((params (request-parameters request))
@@ -223,13 +283,70 @@ Hydra format."
,@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)
+ (let*
+ ((evaluation-id-max
+ (with-critical-section db-channel (db)
+ (db-get-evaluations-id-max db name)))
+ (evaluation-id-min
+ (with-critical-section db-channel (db)
+ (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)))
+ (respond-html
+ (html-page
+ name
+ (evaluation-info-table
+ name
+ (with-critical-section db-channel (db)
+ (db-get-evaluations-build-summary
+ db
+ name
+ (%pagesize)
+ border-low
+ border-high))
+ evaluation-id-min
+ evaluation-id-max)))))
+
+ (("eval" id)
+ (let*
+ ((builds-id-max (with-critical-section db-channel (db)
+ (db-get-builds-id-max db id)))
+ (builds-id-min (with-critical-section db-channel (db)
+ (db-get-builds-id-min db id)))
+ (params (request-parameters request))
+ (border-high (normalize-parameter (assq-ref params 'border-high)))
+ (border-low (normalize-parameter (assq-ref params 'border-low))))
+ (respond-html
+ (html-page
+ "Evaluations"
+ (build-eval-table
+ (handle-builds-request db-channel
+ `((evaluation ,id)
+ (nr ,(%pagesize))
+ (order finish-time)
+ (border-high ,border-high)
+ (border-low ,border-low)))
+ 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..d9f1e23
--- /dev/null
+++ b/src/cuirass/templates.scm
@@ -0,0 +1,171 @@
+
+;;;; http.scm -- HTTP API
+;;; Copyright © 2018 Tatiana Sholokhova <address@hidden>
+;;;
+;;; 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)
+ #:export (html-page
+ specifications-table
+ build-table
+ evaluation-info-table
+ build-eval-table
+ %pagesize))
+
+(define %pagesize
+ ;; description
+ (make-parameter 10))
+
+(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 "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")) "Projects")
+ (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")) Branch)))
+ (tbody
+ ,@(map
+ (lambda (spec)
+ `(tr
+ (td (a (@ (href "/jobset/" ,(assq-ref spec #:name)))
,(assq-ref spec #:name)))
+ (td ,(assq-ref spec #:branch))))
+ specs)))))))
+
+(define (pagination page-id-min page-id-max id-min id-max)
+ "Return page navigation buttons."
+ `(div (@ (class row))
+ (nav
+ (@ (class "mx-auto") (aria-label "Page navigation"))
+ (ul (@ (class "pagination"))
+ (li (@ (class "page-item"))
+ (a (@ (class "page-link")
+ (href "?border-high=" ,(number->string (+ id-max 1))))
+ "<< First"))
+ (li (@ (class "page-item" ,(if (= page-id-max id-max) " disabled"
"")))
+ (a (@ (class "page-link")
+ (href "?border-low=" ,(number->string page-id-max)))
+ "< Previous"))
+ (li (@ (class "page-item" ,(if (= page-id-min id-min) " disabled"
"")))
+ (a (@ (class "page-link")
+ (href "?border-high=" ,(number->string page-id-min)))
+ "Next >"))
+ (li (@ (class "page-item"))
+ (a (@ (class "page-link")
+ (href "?border-low=" ,(number->string (- id-min 1))))
+ "Last >>"))))))
+
+(define (minimum lst current-min)
+ "Return MINIMUM value in LST (list). Initial value is current-min."
+ (cond ((null? lst) current-min)
+ ((< (car lst) current-min) (minimum (cdr lst) (car lst)))
+ (else (minimum (cdr lst) current-min))))
+
+(define (maximum lst current-max)
+ "Return MAXIMUM value in LST (list). Initial value is current-max."
+ (cond ((null? lst) current-max)
+ ((> (car lst) current-max) (maximum (cdr lst) (car lst)))
+ (else (maximum (cdr lst) current-max))))
+
+(define (evaluation-info-table name evaluations evaluation-id-min
evaluation-id-max)
+ "Return HTML for the EVALUATION table NAME from EVALUATION-ID-MIN to
+ EVALUATION-ID-MAX."
+ (let ((id-min (minimum (map (lambda (row) (assq-ref row #:id)) evaluations)
evaluation-id-max))
+ (id-max (maximum (map (lambda (row) (assq-ref row #:id)) evaluations)
evaluation-id-min)))
+ `((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")) Revision)
+ (th (@ (scope "col")) Success)))
+ (tbody
+ ,@(map
+ (lambda (row)
+ `(tr
+ (th (@ (scope "row")) (a (@ (href "/eval/" ,(assq-ref row
#:id))) ,(assq-ref row #:id)))
+ (td ,(assq-ref row #:revision))
+ (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)))))
+ ,(pagination id-min id-max evaluation-id-min evaluation-id-max))))
+
+(define (build-eval-table builds build-id-min build-id-max)
+ "Return HTML for the BUILDS table NAME from BUILD-ID-MIN to
+ BUILD-ID-MAX."
+ (define (table-header)
+ `(thead
+ (tr
+ (th (@ (scope "col")) '())
+ (th (@ (scope "col")) ID)
+ (th (@ (scope "col")) Project)
+ (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 #:project))
+ (td ,(strftime "%c" (localtime (assq-ref build #:stoptime))))
+ (td ,(assq-ref build #:job))
+ (td ,(assq-ref build #:nixname))
+ (td ,(assq-ref build #:system))))
+ (let ((id-min (minimum (map (lambda (row) (assq-ref row #:stoptime)) builds)
build-id-max))
+ (id-max (maximum (map (lambda (row) (assq-ref row #:stoptime)) builds)
build-id-min)))
+ `((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)))))
+ ,(pagination id-min id-max build-id-min build-id-max))))
diff --git a/tests/database.scm b/tests/database.scm
index 847c8a6..a396299 100644
--- a/tests/database.scm
+++ b/tests/database.scm
@@ -157,7 +157,7 @@ INSERT INTO Evaluations (specification, revision) VALUES
(3, 3);")
((3 "/baz.drv") (2 "/bar.drv") (1 "/foo.drv")) ;descending order
((3 "/baz.drv") (2 "/bar.drv") (1 "/foo.drv")) ;ditto
((3 "/baz.drv") (2 "/bar.drv") (1 "/foo.drv")) ;ditto
- ((3 "/baz.drv")) ;nr = 1
+ ((1 "/foo.drv")) ;nr = 1
((2 "/bar.drv") (1 "/foo.drv") (3 "/baz.drv"))) ;status+submission-time
(with-temporary-database db
;; Populate the 'Builds', 'Derivations', 'Evaluations', and