guix-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[no subject]


From: Clément Lassieur
Date: Tue, 24 Jul 2018 18:51:49 -0400 (EDT)

branch: web-interface-rebased
commit 3d0c80985c2ed2db1d5721cc6be51faedf1beb10
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.
    
      Fix with-critical-section wrapping.
    
          * /src/cuirass/http.scm: Use one critical-section per function.
    
      Fix pagination for builds.
          * src/cuirass/templates.scm: Rewrite pagination template.
          * src/cuirass/database.scm: Change build filtering for pagination.
          * src/cuirass/http.scm: Add parameters for tuple-pagination.
          * tests/database.scm: Fix test.
---
 Makefile.am               |  19 +++-
 src/cuirass/database.scm  | 149 +++++++++++++++++++++++------
 src/cuirass/http.scm      | 190 ++++++++++++++++++++++++++++++-------
 src/cuirass/templates.scm | 234 ++++++++++++++++++++++++++++++++++++++++++++++
 4 files changed, 530 insertions(+), 62 deletions(-)

diff --git a/Makefile.am b/Makefile.am
index 4f6c089..549713a 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -34,6 +34,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 +45,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 +66,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..f6b78a0 100644
--- a/src/cuirass/database.scm
+++ b/src/cuirass/database.scm
@@ -3,6 +3,7 @@
 ;;; Copyright © 2017 Mathieu Othacehe <address@hidden>
 ;;; Copyright © 2018 Ludovic Courtès <address@hidden>
 ;;; Copyright © 2018 Clément Lassieur <address@hidden>
+;;; Copyright © 2018 Tatiana Sholokhova <address@hidden>
 ;;;
 ;;; This file is part of Cuirass.
 ;;;
@@ -48,10 +49,17 @@
             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-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
@@ -454,20 +462,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)))))
+'nr | 'order | 'status | 'evaluation."
 
   (define (format-output name path)
     `(,name . ((#:path . ,path))))
@@ -539,18 +547,26 @@ 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 '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")))
+        "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 \
@@ -563,15 +579,31 @@ 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)) \
-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 (: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)
+                           #: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)))
@@ -631,3 +663,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..a1343aa 100644
--- a/src/cuirass/http.scm
+++ b/src/cuirass/http.scm
@@ -1,8 +1,10 @@
+
 ;;;; 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 Clément Lassieur <address@hidden>
+;;; Copyright © 2018 Tatiana Sholokhova <address@hidden>
 ;;;
 ;;; This file is part of Cuirass.
 ;;;
@@ -20,11 +22,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,28 +38,51 @@
   #: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))
     (#:jobset . ,(assq-ref build #:repo-name))
     (#: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.
+    ;; 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))
@@ -70,19 +98,20 @@
     (#: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))))
-    (and=> build build->hydra-build)))
+(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)
@@ -99,11 +128,11 @@ Hydra format."
                           (match key-symbol
                             ('id (string->number param))
                             ('nr (string->number param))
+                            ('page (string->number param))
                             (_   param)))))))
              (string-split query #\&))
         '())))
 
-
 ;;;
 ;;; Web server.
 ;;;
@@ -136,6 +165,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 +197,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,11 +214,15 @@ 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))))
+         (respond-json (object->json-string hydra-build))
+         (respond-build-not-found build-id))))
     (("build" build-id "log" "raw")
      (let ((build (with-critical-section db-channel (db)
                     (db-get-build db (string->number build-id)))))
@@ -204,10 +263,12 @@ 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)))))
+                           (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 +279,77 @@ 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)))))
-           (respond-json-with-error 500 "Parameter not defined!"))))
+             (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)))
+           (html-page
+             name
+             (evaluation-info-table
+               name
+               (db-get-evaluations-build-summary
+                 db
+                 name
+                 (%pagesize)
+                 border-low
+                 border-high)
+               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 ,(%pagesize))
+                    (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..6ca65f1
--- /dev/null
+++ b/src/cuirass/templates.scm
@@ -0,0 +1,234 @@
+
+;;;; 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)
+  #:use-module (ice-9 format)
+  #:use-module (srfi srfi-1)
+  #:export (html-page
+            specifications-table
+            build-table
+            evaluation-info-table
+            build-eval-table
+            %pagesize))
+
+(define %pagesize
+  ;; Maximal number of items for a page.
+  (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")) "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."
+  (let*
+    ((eval-id-list
+       (map (lambda (row) (assq-ref row #:id)) evaluations))
+     (page-id-min (last eval-id-list))
+     (page-id-max (car eval-id-list)))
+    `((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 (lambda (commit)
+                                 (substring commit 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)))))
+      ,(pagination
+        (format #f "?border-high=~d" (+ id-max 1))
+        (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" (- id-min 1))))))
+
+(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))))
+  (let*
+    ((builds-time-id-list
+      (map (lambda (row) `(,(assq-ref row #:stoptime)
+                           ,(assq-ref row #:id)))
+           builds))
+     (page-build-min (last builds-time-id-list))
+     (page-build-max (car builds-time-id-list)))
+    `((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
+        (format
+          #f
+          "?border-high-time=~d&border-high-id=~d"
+          (car build-max)
+          (+ (last build-max) 1))
+        (if (equal? page-build-max build-max)
+            ""
+            (format
+              #f
+              "?border-low-time=~d&border-low-id=~d"
+              (car page-build-max)
+              (last page-build-max)))
+        (if (equal? page-build-min build-min)
+            ""
+            (format
+              #f
+              "?border-high-time=~d&border-high-id=~d"
+              (car page-build-min)
+              (last page-build-min)))
+        (format
+          #f
+          "?border-low-time=~d&border-low-id=~d"
+          (car build-min)
+          (- (last build-min) 1))))))



reply via email to

[Prev in Thread] Current Thread [Next in Thread]