Megatest

   ods.scm runconfig.scm server.scm configf.scm \
   db.scm keys.scm margs.scm megatest-version.scm \
   process.scm runs.scm tasks.scm tests.scm genexample.scm \
   http-transport.scm filedb.scm \
   client.scm synchash.scm daemon.scm mt.scm \
   ezsteps.scm lock-queue.scm sdb.scm \
   rmt.scm api.scm tdb.scm rpc-transport.scm \
   portlogger.scm archive.scm env.scm diff-report.scm cgisetup/models/pgdb.scm

# Eggs to install (straightforward ones)
EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \
dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \
json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars \
spiffy-directory-listing ssax sxml-serializer sxml-modifications iup canvas-draw sqlite3

;;======================================================================
;; 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.
;;======================================================================

(declare (unit pgdb))
(declare (uses configf))

;; I don't know how to mix compilation units and modules, so no module here.
;;
;; (module pgdb
;;     (
;;      open-pgdb
;;      )
;; 
;; (import scheme)
;; (import data-structures)
;; (import chicken)

(use typed-records (prefix dbi dbi:))

;; given a configdat lookup the connection info and open the db
;;
(define (pgdb:open configdat #!key (dbname #f))  
  (let ((pgconf (configf:lookup configdat "ext-sync" (or dbname "pgdb"))))
    (if pgconf
	(let* ((confdat (map (lambda (conf-item)
			       (let ((parts (string-split conf-item ":")))
				 (if (> (length parts) 1)
				     (let ((key (car parts))
					   (val (cadr parts)))
				       (cons (string->symbol key) val))
				     (begin
				       (print "ERROR: Bad config setting " conf-item ", should be key:val")
				       `(,(string->symbol (car parts)) . #f)))))
			     (string-split pgconf)))
	       (dbtype   (string->symbol (or (alist-ref 'dbtype confdat) "pg"))))
	  (if (alist-ref 'dbtype confdat)
	      (dbi:open dbtype (alist-delete 'dbtype confdat))))
	#f)))

;;======================================================================
;;  A R E A S
;;======================================================================

(defstruct area id area-name area-path last-update)

(define (pgdb:add-area dbh area-name area-path)
  (dbi:exec dbh "INSERT INTO areas (area_name,area_path) VALUES (?,?)" area-name area-path))

(define (pgdb:get-areas dbh)
  ;; (map
  ;;  (lambda (row)
  ;;    (print "row: " row))
  (dbi:get-rows dbh "SELECT id,area_name,area_path,last_sync FROM areas;")) ;; )

;; given an area_path get the area info
;;
(define (pgdb:get-area-by-path dbh area-path)
  (dbi:get-one-row dbh "SELECT id,area_name,area_path,last_sync FROM areas WHERE area_path=?;" area-path))

(define (pgdb:write-sync-time dbh area-info new-sync-time)
  (let ((area-id (vector-ref area-info 0)))
    (dbi:exec dbh "UPDATE areas SET last_sync=? WHERE id=?;" new-sync-time area-id)))

;;======================================================================
;;  T A R G E T S
;;======================================================================

;; Given a target-spec, return the id. Should probably handle this with a join...
;; if target-spec not found, create a record for it.
;;
(define (pgdb:get-ttype dbh target-spec)
  (let ((spec-id (dbi:get-one dbh "SELECT id FROM ttype WHERE target_spec=?;" target-spec)))
    (or spec-id
	(if (handle-exceptions
		exn
		(begin
		  (print-call-chain)
		  (debug:print 0 *default-log-port* "ERROR: cannot create ttype entry, " ((condition-property-accessor 'exn 'message) exn))
		  #f)
	      (dbi:exec dbh "INSERT INTO ttype (target_spec) VALUES (?);" target-spec))
	    (pgdb:get-ttype dbh target-spec)))))

;;======================================================================
;;  R U N S
;;======================================================================

;; given a target spec id, target and run-name return the run-id
;; if no run found return #f
;;
(define (pgdb:get-run-id dbh spec-id target run-name)
  (dbi:get-one dbh "SELECT id FROM runs WHERE ttype_id=? AND target=? AND run_name=?;"
	       spec-id target run-name))

;; given a run-id return all the run info
;;
(define (pgdb:get-run-info dbh run-id) ;; to join ttype or not?
  (dbi:get-one-row
   dbh   ;; 0    1       2       3      4     5      6       7        8         9         10          11         12
   "SELECT id,target,ttype_id,run_name,state,status,owner,event_time,comment,fail_count,pass_count,last_update,area_id
       FROM runs WHERE id=?;" run-id))

;; refresh the data in a run record
;;
(define (pgdb:refresh-run-info dbh run-id state status owner event-time comment fail-count pass-count) ;; area-id)
  (dbi:exec
   dbh
   "UPDATE runs SET
      state=?,status=?,owner=?,event_time=?,comment=?,fail_count=?,pass_count=?
     WHERE id=?;"
   state status owner event-time comment fail-count pass-count run-id))

;; given all needed info create run record
;;
(define (pgdb:insert-run dbh ttype-id target run-name state status owner event-time comment fail-count pass-count)
  (dbi:exec
   dbh
   "INSERT INTO runs (ttype_id,target,run_name,state,status,owner,event_time,comment,fail_count,pass_count)
      VALUES (?,?,?,?,?,?,?,?,?,?);"
    ttype-id target run-name state status owner event-time comment fail-count pass-count))

;;======================================================================
;;  T E S T S
;;======================================================================

;; given run-id, test_name and item_path return test-id
;;
(define (pgdb:get-test-id dbh run-id test-name item-path)
  (dbi:get-one
   dbh
   "SELECT id FROM tests WHERE run_id=? AND test_name=? AND item_path=?;"
   run-id test-name item-path))

;; create new test record
;;
(define (pgdb:insert-test dbh run-id test-name item-path state status host cpuload diskfree uname run-dir log-file run-duration comment event-time archived)
  (dbi:exec
   dbh
   "INSERT INTO tests (run_id,test_name,item_path,state,status,host,cpuload,diskfree,uname,rundir,final_logf,run_duration,comment,event_time,archived)
       VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?);"

   run-id  test-name item-path    state   status     host  cpuload diskfree uname
   run-dir log-file  run-duration comment event-time archived))

;; update existing test record
;;
(define (pgdb:update-test dbh test-id run-id test-name item-path state status host cpuload diskfree uname run-dir log-file run-duration comment event-time archived)
  (dbi:exec
   dbh
   "UPDATE tests SET
      run_id=?,test_name=?,item_path=?,state=?,status=?,host=?,cpuload=?,diskfree=?,uname=?,rundir=?,final_logf=?,run_duration=?,comment=?,event_time=?,archived=?
    WHERE id=?;"

   run-id  test-name item-path    state   status     host  cpuload diskfree uname
   run-dir log-file  run-duration comment event-time archived test-id))

(define (pgdb:get-tests dbh target-patt)
  (dbi:get-rows
   dbh
   "SELECT t.id,t.run_id,t.test_name,t.item_path,t.state,t.status,t.host,t.cpuload,t.diskfree,t.uname,t.rundir,t.final_logf,t.run_duration,t.comment,t.event_time,t.archived,
           r.id,r.target,r.ttype_id,r.run_name,r.state,r.status,r.owner,r.event_time,r.comment
     FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id
      WHERE r.target LIKE ?;" target-patt))

(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))

;;======================================================================
;;  V A R I O U S   D A T A   M A S S A G E   R O U T I N E S
;;======================================================================

;; probably want to move these to a different model file

;; create a hash of hashes with keys extracted from all-parts
;; using row-or-col to choose row or column
;;   ht{row key}=>ht{col key}=>data
;;
(define (pgdb:coalesce-runs dbh runs all-parts row-or-col)
  (let* ((data  (make-hash-table)))
    ;;	 (rnums (
    ;; for now just do first => remainder
    (for-each
     (lambda (run)
       (let* ((target (vector-ref run 2))
	      (parts  (string-split target "/"))
	      (first  (car parts))
	      (rest   (string-intersperse (cdr parts) "/"))
	      (coldat (hash-table-ref/default data first #f)))
	 (if (not coldat)(let ((newht (make-hash-table)))
			   (hash-table-set! data first newht)
			   (set! coldat newht)))
	 (hash-table-set! coldat rest run)))
     runs)
    data))

;;======================================================================
;; 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/index_ctrl.scm")


(include "pages/index_view.scm")

;; a function <pagename>-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)))))

;;======================================================================
;; Below are the raw chunks of html, css and jquery stuff needed to make
;; html kickstart and other useful things work
;;======================================================================

(define index:kickstart-junk
#<<EOF
<meta charset="UTF-8">
<meta name="viewport" content="width=device-width, initial-scale=1.0"/>
<meta name="description" content="" />

EOF

#<<EOF
<script type="text/javascript" src="https://ajax.googleapis.com/ajax/libs/jquery/1.6.4/jquery.min.js"></script>
<!--[if lt IE 9]><script src="http://html5shiv.googlecode.com/svn/trunk/html5.js"></script><![endif]-->
EOF
))


(define index:javascript
#<<EOF
<script type="text/javascript" src="/js/prettify.js"></script>                                   <!-- PRETTIFY -->
<script type="text/javascript" src="/js/kickstart.js"></script>                                  <!-- KICKSTART -->
EOF
)

;;======================================================================
;; 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: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    (pgdb:get-stats-given-target dbh tfilter))
	 ;; (all-data    (pgdb:get-tests dbh tfilter))
	 (ordered-data (pgdb:coalesce-runs dbh all-data all-parts row-or-col)))
    
    (list
     "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">"
     (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)
		      ;;
		      ;; This is completely wrong!!! However it may provide some ideas!
		      ;;
		      (s:table
		       (map
			(lambda (key)
			  (let ((subdat (hash-table-ref ordered-data key)))
			    (s:tr (s:td key)
				  (map
				   (lambda (remkey)
				     (s:td remkey
					   (let ((dat (hash-table-ref subdat remkey)))
					     (s:td (vector-ref dat 1) (vector-ref dat 0)))))
				   (sort (hash-table-keys subdat) string>=?)))))
			(sort (hash-table-keys ordered-data) string>=?)))
		      
		;;(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)