ADDED cgisetup/pages/home.scm Index: cgisetup/pages/home.scm ================================================================== --- /dev/null +++ cgisetup/pages/home.scm @@ -0,0 +1,16 @@ +;;====================================================================== +;; Copyright 2017, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. +;;====================================================================== + +(use regex) +(load "models/pgdb.scm") +(include "pages/home_ctrl.scm") +(include "pages/home_view.scm") + ADDED cgisetup/pages/home_ctrl.scm Index: cgisetup/pages/home_ctrl.scm ================================================================== --- /dev/null +++ cgisetup/pages/home_ctrl.scm @@ -0,0 +1,31 @@ +;;====================================================================== +;; Copyright 2017, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. +;;====================================================================== + +;; a function -action is called on POST + +(define (home-action action) + (case (string->symbol action) + ((filter) + (let ((target-type (s:get-input 'target-type)) + (target-filter (s:get-input 'tfilter)) + (target (s:get-input 'target)) + (row-or-col (s:get-input 'row-or-col))) + ;; + ;; s:set! is a page local var. Better than s:session-var-set! but still not a good idea. + ;; + (s:set! "row-or-col" (if (list? row-or-col) + (string-intersperse row-or-col ",") + row-or-col)) + (s:set! "target-type" target-type) + (s:set! "tfilter" target-filter) + (s:set! "target" target) + (s:set! "target-filter" target-filter))))) + ADDED cgisetup/pages/home_view.scm Index: cgisetup/pages/home_view.scm ================================================================== --- /dev/null +++ cgisetup/pages/home_view.scm @@ -0,0 +1,121 @@ +;;====================================================================== +;; Copyright 2017, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. +;;====================================================================== + +(define (pages:home session db shared) + (let* ((dbh (s:db)) + (ttypes (pgdb:get-target-types dbh)) + (selected (string->number (or (s:get "target-type") "0"))) + (curr-trec (filter (lambda (x)(eq? selected (vector-ref x 0))) ttypes)) + (curr-ttype (if (and selected + (not (null? curr-trec))) + (vector-ref (car curr-trec) 1) #f)) + (all-parts (if curr-ttype (append (string-split curr-ttype "/") '("runname" "testname")) '())) + (tfilter (or (s:get "target-filter") "%")) + (targets (pgdb:get-targets-of-type dbh selected tfilter)) + ;; (target (s:session-var-get "target")) + ;; (target-patt (or target "%")) + (row-or-col (string-split (or (s:get "row-or-col") "") ",")) + (all-data (if selected (pgdb:get-stats-given-target dbh selected tfilter) + '())) + ;; (all-data (pgdb:get-tests dbh tfilter)) + (ordered-data (pgdb:coalesce-runs dbh all-data all-parts row-or-col 0))) + + (s:div 'class "col_12" + (s:fieldset + "Area type and target filter" + (s:form + 'action "home.filter" 'method "post" + (s:div 'class "col_12" + (s:div 'class "col_6" + (s:select (map (lambda (x) + (let ((tt-id (vector-ref x 0)) + (ttype (vector-ref x 1))) + (if (eq? tt-id selected) + (list ttype tt-id ttype #t) + (list ttype tt-id ttype #f)))) + ttypes) + 'name 'target-type)) + (s:div 'class "col_4" + (s:input-preserve 'name "tfilter" 'placeholder "Filter targets")) + (s:div 'class "col_2" + (s:input 'type "submit" 'name "set-filter-vals" 'value "Submit"))) + ;; use radio buttons to select whether to put this identifier in row or column. + ;; this seems clumsly and takes up a lot of screen realestate + ;; (s:div 'class "col_12" + ;; (s:div 'class "col_1" "identifier") + ;; (map (lambda (target-var) + ;; (s:div 'class "col_1" target-var)) + ;; all-parts)) + ;; (s:div 'class "col_12" + ;; (s:div 'class "col_1" "row") + ;; (map (lambda (target-var) + ;; (s:div 'class "col_1" (s:input 'type "checkbox" 'name "row-or-col" 'value target-var + ;; ;; this silly trick preserves the checkmark + ;; (if (member target-var row-or-col) 'checked "") + ;; ""))) + ;; all-parts)) + )) + (s:fieldset + (conc "Runs data for " tfilter) + ;; + ;; A very basic display + ;; + (let* ((a-keys (sort (hash-table-keys ordered-data) string>=?)) + (b-keys (sort (apply + append + (map (lambda (sub-key) + (let ((subdat (hash-table-ref ordered-data sub-key))) + (hash-table-keys subdat))) + a-keys)) + string>=?))) + (if #f ;; swap rows/cols + (s:table + (s:tr (s:td "")(map s:tr b-keys)) + (map + (lambda (row-key) + (let ((subdat (hash-table-ref ordered-data row-key))) + (s:tr (s:td row-key) + (map + (lambda (col-key) + (s:td (let ((dat (hash-table-ref/default subdat col-key #f))) + (s:td (if dat + (list (vector-ref dat 0)(vector-ref dat 1)) + ""))))) + b-keys)))) + a-keys)) + (s:table + (s:tr (s:td "")(map s:td a-keys)) + (map + (lambda (row-key) + (s:tr (s:td row-key) + (map + (lambda (col-key) + (let ((val (let* ((ht (hash-table-ref/default ordered-data col-key #f))) + (if ht (hash-table-ref/default ht row-key #f))))) + (if val + (let* ((total (vector-ref val 1)) + (pass (vector-ref val 2)) + (fail (vector-ref val 3)) + (other (vector-ref val 4)) + (passper (round (* (/ pass total) 100))) + (failper (- 100 passper)) + (run-key ;; (string-substitute ;; %2F = / + ;; "-" "%2D" + ;;(string-substitute "/" "%2F" (conc col-key "/" row-key) 'all) + (string-substitute "[/]" "_x_" (conc col-key "/" row-key) 'all) + ;; 'all))) + )) + (s:td 'style (conc "background: linear-gradient(to right, green " passper "%, red " failper "%);") + (s:a 'href (s:link-to "run" 'target run-key) + (conc total "/" pass "/" fail "/" other)))) + (s:td "")))) + a-keys))) + b-keys)))))))) Index: cgisetup/pages/index.scm ================================================================== --- cgisetup/pages/index.scm +++ cgisetup/pages/index.scm @@ -7,9 +7,10 @@ ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== -(load "models/pgdb.scm") +(use regex) +;; (load "models/pgdb.scm") (include "pages/index_ctrl.scm") (include "pages/index_view.scm") Index: cgisetup/pages/index_ctrl.scm ================================================================== --- cgisetup/pages/index_ctrl.scm +++ cgisetup/pages/index_ctrl.scm @@ -11,24 +11,11 @@ ;; a function -action is called on POST (define (index-action action) (case (string->symbol action) - ((filter) - (let ((target-type (s:get-input 'target-type)) - (target-filter (s:get-input 'tfilter)) - (target (s:get-input 'target)) - (row-or-col (s:get-input 'row-or-col))) - ;; should not be using session vars for these, session vars are not multi-tab - ;; resistant (thinking of you Jeff!) - (s:session-var-set! "row-or-col" (if (list? row-or-col) - (string-intersperse row-or-col ",") - row-or-col)) - (s:session-var-set! "target-type" target-type) - (s:set! "tfilter" target-filter) - (s:session-var-set! "target" target) - (s:session-var-set! "target-filter" target-filter))))) + (else #f))) ;;====================================================================== ;; Below are the raw chunks of html, css and jquery stuff needed to make ;; html kickstart and other useful things work ;;====================================================================== Index: cgisetup/pages/index_view.scm ================================================================== --- cgisetup/pages/index_view.scm +++ cgisetup/pages/index_view.scm @@ -9,149 +9,24 @@ ;; PURPOSE. ;;====================================================================== (define (pages:index session db shared) (let* ((dbh (s:db)) - (ttypes (pgdb:get-target-types dbh)) - (selected (string->number (or (s:session-var-get "target-type") "0"))) - (curr-trec (filter (lambda (x)(eq? selected (vector-ref x 0))) ttypes)) - (curr-ttype (if (and selected - (not (null? curr-trec))) - (vector-ref (car curr-trec) 1) #f)) - (all-parts (if curr-ttype (append (string-split curr-ttype "/") '("runname" "testname")) '())) - (tfilter (or (s:session-var-get "target-filter") "%")) - (targets (pgdb:get-targets-of-type dbh selected tfilter)) - ;; (target (s:session-var-get "target")) - ;; (target-patt (or target "%")) - (row-or-col (string-split (or (s:session-var-get "row-or-col") "") ",")) - (all-data (if selected (pgdb:get-stats-given-target dbh selected tfilter) - '())) - ;; (all-data (pgdb:get-tests dbh tfilter)) - (ordered-data (pgdb:coalesce-runs dbh all-data all-parts row-or-col 0))) - - (list - "" - (s:html - (s:title (conc "Megatest")) - (s:head - index:kickstart-junk - ) - (s:body - ;; (s:session-var-get "target-type") - ;; (conc " selected = " selected ", ttypes = " ttypes ", curr-ttype = " curr-ttype ", curr-trec = " curr-trec) - ;; (conc (hash-table->alist ordered-data)) - (s:div 'class "grid flex" 'id "top_of_page" - ;; add visible to columns to help visualize them e.g. "col_12 visible" - ;; BEGINNING OF HEADER - (s:div 'class "col_12" - (s:fieldset - "Area type and target filter" - (s:form - 'action "index.filter" 'method "post" - (s:div 'class "col_12" - (s:select (map (lambda (x) - (let ((tt-id (vector-ref x 0)) - (ttype (vector-ref x 1))) - (if (eq? tt-id selected) - (list ttype tt-id ttype #t) - (list ttype tt-id ttype #f)))) - ttypes) - 'name 'target-type) - (s:input-preserve 'name "tfilter" 'placeholder "Filter targets") - (s:input 'type "submit" 'name "set-filter-vals" 'value "Submit" 'class "col_3")) - ;; use radio buttons to select whether to put this identifier in row or column. - ;; this seems clumsly and takes up a lot of screen realestate - ;; (s:div 'class "col_12" - ;; (s:div 'class "col_1" "identifier") - ;; (map (lambda (target-var) - ;; (s:div 'class "col_1" target-var)) - ;; all-parts)) - ;; (s:div 'class "col_12" - ;; (s:div 'class "col_1" "row") - ;; (map (lambda (target-var) - ;; (s:div 'class "col_1" (s:input 'type "checkbox" 'name "row-or-col" 'value target-var - ;; ;; this silly trick preserves the checkmark - ;; (if (member target-var row-or-col) 'checked "") - ;; ""))) - ;; all-parts)) - )) - (s:fieldset - (conc "Runs data for " tfilter) - ;; - ;; A very basic display - ;; - (let* ((a-keys (sort (hash-table-keys ordered-data) string>=?)) - (b-keys (sort (apply - append - (map (lambda (sub-key) - (let ((subdat (hash-table-ref ordered-data sub-key))) - (hash-table-keys subdat))) - a-keys)) - string>=?))) - (if #f ;; swap rows/cols - (s:table - (s:tr (s:td "")(map s:tr b-keys)) - (map - (lambda (row-key) - (let ((subdat (hash-table-ref ordered-data row-key))) - (s:tr (s:td row-key) - (map - (lambda (col-key) - (s:td (let ((dat (hash-table-ref/default subdat col-key #f))) - (s:td (if dat - (list (vector-ref dat 1) (vector-ref dat 0)) - ""))))) - b-keys)))) - a-keys)) - (s:table - (s:tr (s:td "")(map s:td a-keys)) - (map - (lambda (row-key) - (s:tr (s:td row-key) - (map - (lambda (col-key) - (let ((val (let* ((ht (hash-table-ref/default ordered-data col-key #f))) - (if ht (hash-table-ref/default ht row-key #f))))) - (if val - (let* ((total (vector-ref val 1)) - (pass (vector-ref val 2)) - (fail (vector-ref val 3)) - (other (vector-ref val 4)) - (passper (round (* (/ pass total) 100))) - (failper (- 100 passper))) - (s:td 'style (conc "background: linear-gradient(to right, green " passper "%, red " failper "%);") - (conc total "/" pass "/" fail "/" other))) - (s:td "")))) - a-keys))) - b-keys)))))) - - ;;(map (lambda (area) - ;; (s:p "data=" (conc area))) - ;; ;; (pgdb:get-tests dbh tfilter)) - ;; (pgdb:get-stats-given-target dbh tfilter)) - - - - - index:jquery - index:javascript - )))))) - - - ;; (s:div 'class "col_12" - ;; (s:div 'class "col_1" "row") - ;; (map (lambda (target-var) - ;; (s:div 'class "col_1" (s:input 'type "radio" 'name target-var 'value "row"))) - ;; all-parts)) - ;; (s:div 'class "col_12" - ;; (s:div 'class "col_1" "col") - ;; (map (lambda (target-var) - ;; (s:div 'class "col_1" (s:input 'type "radio" 'name target-var 'value "col"))) - ;; all-parts))) - ;; '()) - ;; (s:h1 (s:session-var-get "target-type")) - - ;; (s:select (map (lambda (x) - ;; (let ((t (vector-ref x 0))) - ;; (list t t t (equal? t target)))) - ;; targets) - ;; 'name 'target) + (page-name (sdat-get-page s:session))) + (if (equal? page-name "api") + (s:call page-name) ;; go straight to the api + (list + "" + (s:html + (s:title (conc "Megatest")) + (s:head + index:kickstart-junk + ) + (s:body + (s:div 'class "grid flex" 'id "top_of_page" + ;; add visible to columns to help visualize them e.g. "col_12 visible" + (case (string->symbol page-name) + ((index) (s:call "home")) + (else (s:call page-name)))) + index:jquery + index:javascript + )))))) ADDED cgisetup/pages/run.scm Index: cgisetup/pages/run.scm ================================================================== --- /dev/null +++ cgisetup/pages/run.scm @@ -0,0 +1,15 @@ +;;====================================================================== +;; Copyright 2017, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. +;;====================================================================== + +(load "models/pgdb.scm") +(include "pages/run_ctrl.scm") +(include "pages/run_view.scm") + ADDED cgisetup/pages/run_ctrl.scm Index: cgisetup/pages/run_ctrl.scm ================================================================== --- /dev/null +++ cgisetup/pages/run_ctrl.scm @@ -0,0 +1,19 @@ +;;====================================================================== +;; Copyright 2017, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. +;;====================================================================== + +;; a function -action is called on POST + +(define (run-action action) + (case (string->symbol action) + ((dosomething) + (dosomething)))) + + ADDED cgisetup/pages/run_view.scm Index: cgisetup/pages/run_view.scm ================================================================== --- /dev/null +++ cgisetup/pages/run_view.scm @@ -0,0 +1,20 @@ +;;====================================================================== +;; Copyright 2017, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. +;;====================================================================== + +(define (pages:run session db shared) + (let* ((dbh (s:db)) + (target (s:get-param 'target))) + + (s:div 'class "col_12" + (s:fieldset + "Show a run" + target)))) +