Index: cgisetup/pages/index_ctrl.scm ================================================================== --- cgisetup/pages/index_ctrl.scm +++ cgisetup/pages/index_ctrl.scm @@ -1,8 +1,28 @@ -;; Copyright 2007-2008, Matthew Welland. Kiatoa.com All rights reserved. +;;====================================================================== +;; 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 gets read for ALL pages. Don't weigh it down excessively! +;; 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 (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))) + (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))))) (define index:kickstart-junk #< Index: cgisetup/pages/index_view.scm ================================================================== --- cgisetup/pages/index_view.scm +++ cgisetup/pages/index_view.scm @@ -1,26 +1,58 @@ -;; Copyright 2007-2008, Matthew Welland. Megatest All rights reserved. +;;====================================================================== +;; 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. +;;====================================================================== + ;; index -(let ((dbh (s:db))) +(let* ((dbh (s:db)) + (ttypes (pgdb:get-target-types dbh)) + (selected (string->number (or (s:session-var-get "target-type") "0"))) + (tfilter (or (s:session-var-get "target-filter") "%")) + (targets (pgdb:get-targets-of-type dbh selected tfilter)) + (target (s:session-var-get "target"))) (list "" (s:html - (s:title (conc "Megatest ")) + (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" ;; BEGINNING OF HEADER (s:div 'class "col_12" - (map (lambda (area) - (s:p "data=" (conc area))) - ;; (pgdb:get-tests dbh "%") - (pgdb:get-stats-given-target dbh "v1.63/%") - ) - index:jquery - index:javascript - )))))) + (s:form + 'action "index.filter" 'method "post" + (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:select (map (lambda (x) + (let ((t (vector-ref x 0))) + (list t t t (equal? t target)))) + targets) + 'name 'target) + (s:input 'type "submit" 'name "set-filter-vals" 'value "Submit" 'class "col_3") + ;; (s:h1 (s:session-var-get "target-type")) + (map (lambda (area) + (s:p "data=" (conc area))) + ;; (pgdb:get-tests dbh (or target "%")) + (pgdb:get-stats-given-target dbh (or target "%")) + ) + index:jquery + index:javascript + ))))))) Index: pgdb.scm ================================================================== --- pgdb.scm +++ pgdb.scm @@ -172,6 +172,26 @@ (define (pgdb:get-stats-given-target dbh target-patt) (dbi:get-rows dbh "SELECT COUNT(t.id),t.status,r.target FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id WHERE t.state='COMPLETED' AND r.target LIKE ? GROUP BY t.status,r.target;" target-patt)) - + +(define (pgdb:get-target-types dbh) + (dbi:get-rows dbh "SELECT id,target_spec FROM ttype;")) + +;; +(define (pgdb:get-targets dbh target-patt) + (let ((ttypes (pgdb:get-target-types dbh))) + (map + (lambda (ttype-dat) + (let ((tt-id (vector-ref ttype-dat 0)) + (ttype (vector-ref ttype-dat 1))) + (cons ttype + (dbi:get-rows + dbh + "SELECT DISTINCT target FROM runs WHERE target LIKE ? AND ttype_id=?;" target-patt tt-id)) + )) + ttypes))) + +(define (pgdb:get-targets-of-type dbh ttype-id target-patt) + (dbi:get-rows dbh "SELECT DISTINCT target FROM runs WHERE target LIKE ? AND ttype_id=?;" target-patt ttype-id)) +