Megatest

           subrun.scm archive.scm env.scm		\
           diff-report.scm cgisetup/models/pgdb.scm

# module source files
MSRCFILES = dbfile.scm debugprint.scm mtargs.scm commonmod.scm dbmod.scm \
            tcp-transportmod.scm rmtmod.scm portlogger.scm apimod.scm \
	    configfmod.scm processmod.scm servermod.scm megatestmod.scm \
	    stml2.scm fsmod.scm cpumod.scm mtmod.scm odsmod.scm tasksmod.scm

transport-mode.scm : transport-mode.scm.template
	cp transport-mode.scm.template transport-mode.scm

dashboard-transport-mode.scm : dashboard-transport-mode.scm.template
	cp dashboard-transport-mode.scm.template dashboard-transport-mode.scm

mtest : transport-mode.scm
dboard : dashboard-transport-mode.scm

# dbmod.import.o is just a hack here

process.o            : mofiles/processmod.o
mofiles/configfmod.o : mofiles/processmod.o
mofiles/processmod.o : mofiles/commonmod.o
mofiles/servermod.o  : mofiles/commonmod.o
mofiles/rmtmod.o     : mofiles/mtmod.o mofiles/apimod.o
mofiles/dbmod.o      : mofiles/mtmod.o
# mofiles/mtmod.o      : mofiles/tcp-transportmod.o

mofiles/dbfile.o     : \
       mofiles/debugprint.o mofiles/commonmod.o  mofiles/configfmod.o
mofiles/apimod.o : mofiles/commonmod.o mofiles/tcp-transportmod.o mofiles/configfmod.o mofiles/megatestmod.o
mofiles/rmtmod.o :  mofiles/tasksmod.o
mofiles/dbmod.o : mofiles/dbfile.o
mofiles/api.o : mofiles/apimod.o
mofiles/commonmod.o : mofiles/debugprint.o mofiles/stml2.o
configf.o : commonmod.import.o
mofiles/dbfile.o : mofiles/debugprint.o
mofiles/rmtmod.o mofiles/dbmod.o : mofiles/dbfile.o mofiles/commonmod.o mofiles/debugprint.o
db.o : mofiles/dbmod.o mofiles/dbfile.o

	fi

# portlogger-example : portlogger-example.scm api.o archive.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o genexample.o gutils.o items.o keys.o launch.o lock-queue.o margs.o mt.o ods.o portlogger.o process.o rmt.o runconfig.o runs.o server.o synchash.o tasks.o tdb.o tests.o tree.o
#	csc $(CSCOPTS) portlogger-example.scm api.o archive.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o genexample.o gutils.o items.o keys.o launch.o lock-queue.o margs.o mt.o ods.o portlogger.o process.o rmt.o runconfig.o runs.o server.o sync-hash.o tasks.o tdb.o tests.o tree.o

unitdeps.dot : *scm ./utils/plot-uses Makefile
	./utils/plot-uses todot commonmod.import,mtargs.import,mtargs,debugprint *.scm > unitdeps.dot

# ./utils/plot-uses todot commonmod,portlogger,stml2,debugprint,mtargs apimod.scm commonmod.scm configfmod.scm dbmod.scm megatestmod.scm mtmod.scm processmod.scm rmtmod.scm servermod.scm tcp-transportmod.scm > uses.dot ; dot uses.dot -Tpdf -o uses.pdf

unitdeps.pdf : unitdeps.dot
	dot unitdeps.dot -Tpdf -o unitdeps.pdf

./utils/plot-uses : utils/plot-uses.scm
	csc utils/plot-uses.scm

      ;; (serialize payload)
     
      (api:unregister-thread (current-thread))
      result)))

(define api:tcp-dispatch-request-make-handler api:tcp-dispatch-request-make-handler-old) ;; choose -old or -new

(declare (unit apimod))
(declare (uses commonmod))
(declare (uses debugprint))
(declare (uses dbmod))
(declare (uses dbfile))
(declare (uses tcp-transportmod))
(declare (uses megatestmod))

(module apimod
	*
	
(import scheme chicken data-structures extras)
(import (prefix sqlite3 sqlite3:) posix matchable typed-records srfi-1 srfi-18 srfi-69 )
(import commonmod)
(import debugprint)
(import dbmod)
(import dbfile)
(import tcp-transportmod)
(import megatestmod)


(define *api-halt-writes* #f)

;; allow these queries through without starting a server
;;
(define api:read-only-queries
  '(get-key-val-pairs
    get-var
    get-keys

		(errmsg "")
		(payload (list status errmsg result meta)))
	   ;; (cmd run-id params meta)
	   (db:add-stats cmd run-id params (- (current-milliseconds) start-t))
	   payload))
	(else
	 (assert #f "FATAL: failed to deserialize indat "indat))))))


(define (api:dispatch-request dbstruct cmd run-id params)
  (if (not *no-sync-db*)
      (db:open-no-sync-db))
  (let* ((start-time (current-milliseconds)))
    (if (member cmd api:write-queries)
	(let loop ()
	  (if *api-halt-writes*
	      (begin
		(thread-sleep! 0.2)
		(if (< (- (current-milliseconds) start-time)
		       5000) ;; hope it don't take more than five seconds to sync
		    (loop)
		    #;(debug:print 0 *default-log-port* "ERROR: writes halted for more than 5 seconds, sync might be taking too long"))))))
    (db:add-stats 'api-write-blocking-for-sync run-id params (- (current-milliseconds) start-time)))
  (case cmd
    ;;===============================================
    ;; READ/WRITE QUERIES
    ;;===============================================

    ((get-keys-write)                        (db:get-keys dbstruct)) ;; force a dummy "write" query to force server; for debug in -repl
    
    ;; SERVERS
    ((start-server)                    (apply tt:server-process-run params))
    ((kill-server)                     (set! *server-run* #f))

    ;; TESTS

    ;;((test-set-state-status-by-id)     (apply mt:test-set-state-status-by-id dbstruct params))
    ;;BB - commented out above because it was calling below, eventually, incorrectly (dbstruct passed to mt:test-set-state-status-by-id, which previosly did more, but now only passes thru to db:set-state-status-and-roll-up-items.
    ((test-set-state-status-by-id)

     ;; (define (db:set-state-status-and-roll-up-items dbstruct run-id test-name item-path state status comment)
     (db:set-state-status-and-roll-up-items
      dbstruct
      (list-ref params 0) ; run-id
      (list-ref params 1) ; test-name
      #f                  ; item-path
      (list-ref params 2) ; state
      (list-ref params 3) ; status
      (list-ref params 4) ; comment
      ))
    
    ((delete-test-records)             (apply db:delete-test-records dbstruct params))
    ((delete-old-deleted-test-records) (apply db:delete-old-deleted-test-records dbstruct params))
    ((test-set-state-status)           (apply db:test-set-state-status dbstruct params))
    ((test-set-top-process-pid)        (apply db:test-set-top-process-pid dbstruct params))
    ((set-state-status-and-roll-up-items) (apply db:set-state-status-and-roll-up-items dbstruct params))
    ((set-state-status-and-roll-up-run) (apply db:set-state-status-and-roll-up-run dbstruct params)) 
    ((top-test-set-per-pf-counts)       (apply db:top-test-set-per-pf-counts dbstruct params))
    ((test-set-archive-block-id)        (apply db:test-set-archive-block-id dbstruct params))

    ((insert-test)                      (db:insert-test dbstruct run-id params))

    ;; RUNS
    ((register-run)                 (apply db:register-run dbstruct params))
    ((set-tests-state-status)       (apply db:set-tests-state-status dbstruct params))
    ((delete-run)                   (apply db:delete-run dbstruct params))
    ((lock/unlock-run)              (apply db:lock/unlock-run dbstruct params))
    ((update-run-event_time)        (apply db:update-run-event_time dbstruct params))
    ((update-run-stats)             (apply db:update-run-stats dbstruct params))
    ((set-var)                      (apply db:set-var dbstruct params))
    ((inc-var)                      (apply db:inc-var dbstruct params))
    ((dec-var)                      (apply db:dec-var dbstruct params))
    ((del-var)                      (apply db:del-var dbstruct params))
    ((add-var)                      (apply db:add-var dbstruct params))

    ((insert-run)                   (apply db:insert-run dbstruct params))

    ;; STEPS
    ((teststep-set-status!)         (apply db:teststep-set-status! dbstruct params))
    ((delete-steps-for-test!)       (apply db:delete-steps-for-test! dbstruct params))
    
    ;; TEST DATA
    ((test-data-rollup)             (apply db:test-data-rollup dbstruct params))
    ((csv->test-data)               (apply db:csv->test-data dbstruct params))

    ;; MISC
    ((sync-cachedb->db)               (let ((run-id (car params)))
                                      (db:sync-touched dbstruct run-id db:initialize-main-db force-sync: #t)))
    ((get-toplevels-and-incompletes) (apply db:get-toplevels-and-incompletes dbstruct params))
    ((mark-incomplete)              #f);;(thread-start! (make-thread (lambda () ;; no need to block on this one
					;;			  (apply db:find-and-mark-incomplete dbstruct params)
					;;			  #t)))) 
    ((create-all-triggers)          (db:create-all-triggers dbstruct))
    ((drop-all-triggers)            (db:drop-all-triggers dbstruct)) 

    ;; TESTMETA
    ((testmeta-add-record)       (apply db:testmeta-add-record dbstruct params))
    ((testmeta-update-field)     (apply db:testmeta-update-field dbstruct params))
    ((get-tests-tags)            (db:get-tests-tags dbstruct))

    ;; TASKS
    ((tasks-add)                 (apply tasks:add dbstruct params))   
    ((tasks-set-state-given-param-key) (apply tasks:set-state-given-param-key dbstruct params))
    ((tasks-get-last)            (apply tasks:get-last dbstruct params))

    ;; NO SYNC DB
    ((no-sync-set)               (apply db:no-sync-set         *no-sync-db* params))
    ((no-sync-get/default)       (apply db:no-sync-get/default *no-sync-db* params))
    ((no-sync-del!)              (apply db:no-sync-del!        *no-sync-db* params))
    ((no-sync-get-lock)          (apply db:no-sync-get-lock    *no-sync-db* params))

    ;; NO SYNC DB PROCESSES
    ((register-process)          (apply dbfile:register-process *no-sync-db* params))
    ((set-process-done)          (apply dbfile:set-process-done *no-sync-db* params))
    ((set-process-status)        (apply dbfile:set-process-status *no-sync-db* params))
    ((get-process-options)       (apply dbfile:get-process-options *no-sync-db* params))
    
    ;; ARCHIVES
    ;; ((archive-get-allocations)   
    ((archive-register-disk)     (apply db:archive-register-disk dbstruct params))
    ((archive-register-block-name)(apply db:archive-register-block-name dbstruct params))
    ;; ((archive-allocate-testsuite/area-to-block)(apply db:archive-allocate-testsuite/area-to-block dbstruct block-id testsuite-name areakey))

    ;;======================================================================
    ;; READ ONLY QUERIES
    ;;======================================================================

    ;; KEYS
    ((get-key-val-pairs)               (apply db:get-key-val-pairs dbstruct params))
    ((get-keys)                        (db:get-keys dbstruct))
    ((get-key-vals)                    (apply db:get-key-vals dbstruct params))
    ((get-target)                      (apply db:get-target dbstruct params))
    ((get-targets)                     (db:get-targets dbstruct))

    ;; ARCHIVES
    ((test-get-archive-block-info)     (apply db:test-get-archive-block-info dbstruct params))
    
    ;; TESTS
    ((test-toplevel-num-items)         (apply db:test-toplevel-num-items dbstruct params))
    ((get-test-info-by-id)	       (apply db:get-test-info-by-id dbstruct params))
    ((get-test-state-status-by-id)     (apply db:get-test-state-status-by-id dbstruct params))
    ((test-get-rundir-from-test-id)    (apply db:test-get-rundir-from-test-id dbstruct params))
    ((get-count-tests-running-for-testname) (apply db:get-count-tests-running-for-testname dbstruct params))
    ((get-count-tests-running)         (apply db:get-count-tests-running dbstruct params))
    ((get-count-tests-running-in-jobgroup) (apply db:get-count-tests-running-in-jobgroup dbstruct params))
    ;; ((delete-test-step-records)        (apply db:delete-test-step-records dbstruct params))
    ;; ((get-previous-test-run-record)    (apply db:get-previous-test-run-record dbstruct params))
    ((get-matching-previous-test-run-records)(apply db:get-matching-previous-test-run-records dbstruct params))
    ((test-get-logfile-info)           (apply db:test-get-logfile-info dbstruct params))
    ((test-get-records-for-index-file)  (apply db:test-get-records-for-index-file dbstruct params))
    ((get-testinfo-state-status)       (apply db:get-testinfo-state-status dbstruct params))
    ((test-get-top-process-pid)        (apply db:test-get-top-process-pid dbstruct params))
    ((test-get-paths-matching-keynames-target-new) (apply db:test-get-paths-matching-keynames-target-new dbstruct params))
    ((get-prereqs-not-met)             (apply db:get-prereqs-not-met dbstruct params))
    ((get-count-tests-running-for-run-id) (apply db:get-count-tests-running-for-run-id dbstruct params))
    ((get-not-completed-cnt)           (apply db:get-not-completed-cnt  dbstruct params)) 
    ((get-raw-run-stats)               (apply db:get-raw-run-stats dbstruct params))
    ((get-test-times)                  (apply db:get-test-times dbstruct params))

    ;; RUNS
    ((get-run-info)                 (apply db:get-run-info dbstruct params))
    ((get-run-status)               (apply db:get-run-status dbstruct params))
    ((get-run-state)                (apply db:get-run-state dbstruct params))
    ((get-run-state-status)         (apply db:get-run-state-status dbstruct params))
    ((set-run-status)               (apply db:set-run-status dbstruct params))
    ((set-run-state-status)  			 (apply db:set-run-state-status dbstruct params))
    ((update-tesdata-on-repilcate-db) (apply db:update-tesdata-on-repilcate-db  dbstruct params)) 
    ((get-tests-for-run)            (apply db:get-tests-for-run dbstruct params))
    ((get-tests-for-run-state-status) (apply db:get-tests-for-run-state-status dbstruct params))
    ((get-test-id)                  (apply db:get-test-id dbstruct params))
    ((get-tests-for-run-mindata)    (apply db:get-tests-for-run-mindata dbstruct params))
    ;; ((get-tests-for-runs-mindata)   (apply db:get-tests-for-runs-mindata dbstruct params))
    ((get-runs)                     (apply db:get-runs dbstruct params))
    ((simple-get-runs)              (apply db:simple-get-runs dbstruct params))
    ((get-num-runs)                 (apply db:get-num-runs dbstruct params))
    ((get-runs-cnt-by-patt)         (apply db:get-runs-cnt-by-patt dbstruct params))
    ((get-all-run-ids)              (db:get-all-run-ids dbstruct))
    ((get-prev-run-ids)             (apply db:get-prev-run-ids dbstruct params))
    ((get-run-ids-matching-target)  (apply db:get-run-ids-matching-target dbstruct params))
    ((get-runs-by-patt)             (apply db:get-runs-by-patt dbstruct params))
    ((get-run-name-from-id)         (apply db:get-run-name-from-id dbstruct params))
    ((get-main-run-stats)           (apply db:get-main-run-stats dbstruct params))
    ((get-var)                      (apply db:get-var dbstruct params))
    ((get-run-stats)                (apply db:get-run-stats dbstruct params))
    ((get-run-times)                (apply db:get-run-times dbstruct params)) 

    ;; STEPS
    ((get-steps-data)               (apply db:get-steps-data dbstruct params))
    ((get-steps-for-test)           (apply db:get-steps-for-test dbstruct params))
    ((get-steps-info-by-id)         (apply db:get-steps-info-by-id dbstruct params))

    ;; TEST DATA
    ((read-test-data)               (apply db:read-test-data dbstruct params))
    ((read-test-data-varpatt)       (apply db:read-test-data-varpatt dbstruct params))
    ((get-data-info-by-id)          (apply db:get-data-info-by-id dbstruct params)) 

    ;; MISC
    ((get-latest-host-load)         (apply db:get-latest-host-load dbstruct params))
    ((have-incompletes?)            (apply db:have-incompletes? dbstruct params))
    ((login)                        (apply db:login dbstruct params))
    ((general-call)                 (let ((stmtname   (car params))
                                          (run-id     (cadr params))
                                          (realparams (cddr params)))
                                      (db:general-call dbstruct run-id stmtname realparams)))
    ((sdb-qry)                      (apply sdb:qry params))
    ((ping)                         (current-process-id))
    ((get-changed-record-ids)       (apply db:get-changed-record-ids dbstruct params))
    ((get-changed-record-test-ids)  (apply db:get-changed-record-test-ids dbstruct params))
    ((get-changed-record-run-ids)  (apply db:get-changed-record-run-ids dbstruct params))
    ((get-run-record-ids) 	    (apply db:get-run-record-ids dbstruct params))
    ((get-all-runids)               (apply db:get-all-runids dbstruct))	
    ;; TESTMETA
    ((testmeta-get-record)       (apply db:testmeta-get-record dbstruct params))

    ;; TASKS 
    ((find-task-queue-records)   (apply tasks:find-task-queue-records dbstruct params))
    (else
     (debug:print 0 *default-log-port* "ERROR: bad api call " cmd)
     (conc "ERROR: BAD api call " cmd))))



)

;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

;;======================================================================
;; dbstruct
;;======================================================================

(define (make-db:test)(make-vector 20))
(define (db:test-get-id           vec) (vector-ref vec 0))
(define (db:test-get-run_id       vec) (vector-ref vec 1))
(define (db:test-get-testname     vec) (vector-ref vec 2))
(define (db:test-get-state        vec) (vector-ref vec 3))
(define (db:test-get-status       vec) (vector-ref vec 4))
(define (db:test-get-event_time   vec) (vector-ref vec 5))
(define (db:test-get-host         vec) (vector-ref vec 6))
(define (db:test-get-cpuload      vec) (vector-ref vec 7))
(define (db:test-get-diskfree     vec) (vector-ref vec 8))
(define (db:test-get-uname        vec) (vector-ref vec 9))
;; (define (db:test-get-rundir       vec) (sdb:qry 'getstr (vector-ref vec 10)))
(define (db:test-get-rundir       vec) (vector-ref vec 10))
(define (db:test-get-item-path    vec) (vector-ref vec 11))
(define (db:test-get-run_duration vec) (vector-ref vec 12))
(define (db:test-get-final_logf   vec) (vector-ref vec 13))
(define (db:test-get-comment      vec) (vector-ref vec 14))
(define (db:test-get-process_id   vec) (vector-ref vec 16))
(define (db:test-get-archived     vec) (vector-ref vec 17))
(define (db:test-get-last_update     vec) (vector-ref vec 18))

;; (define (db:test-get-pass_count   vec) (vector-ref vec 15))
;; (define (db:test-get-fail_count   vec) (vector-ref vec 16))
(define (db:test-get-fullname     vec)
  (conc (db:test-get-testname vec) "/" (db:test-get-item-path vec)))

;; replace runs:make-full-test-name with this routine
(define (db:test-make-full-name testname itempath)
  (if (equal? itempath "") testname (conc testname "/" itempath)))

;; (define (db:test-get-first_err    vec) (printable (vector-ref vec 15)))
;; (define (db:test-get-first_warn   vec) (printable (vector-ref vec 16))) ;; RADT => reference 16 is repeated

(define (db:test-set-cpuload!  vec val)(vector-set! vec 7 val))
(define (db:test-set-diskfree! vec val)(vector-set! vec 8 val))
(define (db:test-set-testname! vec val)(vector-set! vec 2 val))
(define (db:test-set-state!    vec val)(vector-set! vec 3 val))
(define (db:test-set-status!   vec val)(vector-set! vec 4 val))
(define (db:test-set-run_duration! vec val)(vector-set! vec 12 val))
(define (db:test-set-final_logf! vec val)(vector-set! vec 13 val))

;; Test record utility functions

;; Is a test a toplevel?
;;
(define (db:test-get-is-toplevel vec)
  (and (equal? (db:test-get-item-path vec) "")      ;; test is not an item
       (equal? (db:test-get-uname vec)     "n/a"))) ;; test has never been run

;; make-vector-record "" db mintest id run_id testname state status event_time item_path
;; RADT => purpose of mintest??
;;
(define (make-db:mintest)(make-vector 7))
(define (db:mintest-get-id           vec)    (vector-ref  vec 0))
(define (db:mintest-get-run_id       vec)    (vector-ref  vec 1))
(define (db:mintest-get-testname     vec)    (vector-ref  vec 2))
(define (db:mintest-get-state        vec)    (vector-ref  vec 3))
(define (db:mintest-get-status       vec)    (vector-ref  vec 4))
(define (db:mintest-get-event_time   vec)    (vector-ref  vec 5))
(define (db:mintest-get-item_path    vec)    (vector-ref  vec 6))

;; make-vector-record db testmeta id testname author owner description reviewed iterated avg_runtime avg_disk
(define (make-db:testmeta)(make-vector 10 ""))
(define (db:testmeta-get-id            vec)    (vector-ref  vec 0))
(define (db:testmeta-get-testname      vec)    (vector-ref  vec 1))
(define (db:testmeta-get-author        vec)    (vector-ref  vec 2))
(define (db:testmeta-get-owner         vec)    (vector-ref  vec 3))
(define (db:testmeta-get-description   vec)    (vector-ref  vec 4))
(define (db:testmeta-get-reviewed      vec)    (vector-ref  vec 5))
(define (db:testmeta-get-iterated      vec)    (vector-ref  vec 6))
(define (db:testmeta-get-avg_runtime   vec)    (vector-ref  vec 7))
(define (db:testmeta-get-avg_disk      vec)    (vector-ref  vec 8))
(define (db:testmeta-get-tags          vec)    (vector-ref  vec 9))
(define (db:testmeta-set-id!           vec val)(vector-set! vec 0 val))
(define (db:testmeta-set-testname!     vec val)(vector-set! vec 1 val))
(define (db:testmeta-set-author!       vec val)(vector-set! vec 2 val))
(define (db:testmeta-set-owner!        vec val)(vector-set! vec 3 val))
(define (db:testmeta-set-description!  vec val)(vector-set! vec 4 val))
(define (db:testmeta-set-reviewed!     vec val)(vector-set! vec 5 val))
(define (db:testmeta-set-iterated!     vec val)(vector-set! vec 6 val))
(define (db:testmeta-set-avg_runtime!  vec val)(vector-set! vec 7 val))
(define (db:testmeta-set-avg_disk!     vec val)(vector-set! vec 8 val))

;;======================================================================
;; S I M P L E   R U N
;;======================================================================

;; (defstruct id  "runname" "state" "status" "owner" "event_time"

;;======================================================================
;; T E S T   D A T A 
;;======================================================================
(define (make-db:test-data)(make-vector 10))
(define (db:test-data-get-id               vec)    (vector-ref  vec 0))
(define (db:test-data-get-test_id          vec)    (vector-ref  vec 1))
(define (db:test-data-get-category         vec)    (vector-ref  vec 2))
(define (db:test-data-get-variable         vec)    (vector-ref  vec 3))
(define (db:test-data-get-value            vec)    (vector-ref  vec 4))
(define (db:test-data-get-expected         vec)    (vector-ref  vec 5))
(define (db:test-data-get-tol              vec)    (vector-ref  vec 6))
(define (db:test-data-get-units            vec)    (vector-ref  vec 7))
(define (db:test-data-get-comment          vec)    (vector-ref  vec 8))
(define (db:test-data-get-status           vec)    (vector-ref  vec 9))
(define (db:test-data-get-type             vec)    (vector-ref  vec 10))
(define (db:test-data-get-last_update      vec)    (vector-ref  vec 11))

(define (db:test-data-set-id!              vec val)(vector-set!  vec 0  val))
(define (db:test-data-set-test_id!         vec val)(vector-set!  vec 1  val))
(define (db:test-data-set-category!        vec val)(vector-set!  vec 2  val))
(define (db:test-data-set-variable!        vec val)(vector-set!  vec 3  val))
(define (db:test-data-set-value!           vec val)(vector-set!  vec 4  val))
(define (db:test-data-set-expected!        vec val)(vector-set!  vec 5  val))
(define (db:test-data-set-tol!             vec val)(vector-set!  vec 6  val))
(define (db:test-data-set-units!           vec val)(vector-set!  vec 7  val))
(define (db:test-data-set-comment!         vec val)(vector-set!  vec 8  val))
(define (db:test-data-set-status!          vec val)(vector-set!  vec 9  val))
(define (db:test-data-set-type!            vec val)(vector-set!  vec 10 val))

;;======================================================================
;; S T E P S 
;;======================================================================
;; Run steps
;; make-vector-record "Run steps" db step id test_id stepname step_complete step_pass event_time    
(define (make-db:step)(make-vector 9))
(define (tdb:step-get-id              vec)    (vector-ref  vec 0))
(define (tdb:step-get-test_id         vec)    (vector-ref  vec 1))
(define (tdb:step-get-stepname        vec)    (vector-ref  vec 2))
(define (tdb:step-get-state           vec)    (vector-ref  vec 3))
(define (tdb:step-get-status          vec)    (vector-ref  vec 4))
(define (tdb:step-get-event_time      vec)    (vector-ref  vec 5))
(define (tdb:step-get-logfile         vec)    (vector-ref  vec 6))
(define (tdb:step-get-comment         vec)    (vector-ref  vec 7))
(define (tdb:step-get-last_update     vec)    (vector-ref  vec 8))
(define (tdb:step-set-id!             vec val)(vector-set! vec 0 val))
(define (tdb:step-set-test_id!        vec val)(vector-set! vec 1 val))
(define (tdb:step-set-stepname!       vec val)(vector-set! vec 2 val))
(define (tdb:step-set-state!          vec val)(vector-set! vec 3 val))
(define (tdb:step-set-status!         vec val)(vector-set! vec 4 val))
(define (tdb:step-set-event_time!     vec val)(vector-set! vec 5 val))
(define (tdb:step-set-logfile!        vec val)(vector-set! vec 6 val))
(define (tdb:step-set-comment!        vec val)(vector-set! vec 7 val))


;; The steps table
(define (make-db:steps-table)(make-vector 5))
(define (tdb:steps-table-get-stepname   vec)    (vector-ref  vec 0))
(define (tdb:steps-table-get-start      vec)    (vector-ref  vec 1))
(define (tdb:steps-table-get-end        vec)    (vector-ref  vec 2))
(define (tdb:steps-table-get-status     vec)    (vector-ref  vec 3))
(define (tdb:steps-table-get-runtime    vec)    (vector-ref  vec 4))
(define (tdb:steps-table-get-lxsog-file   vec)    (vector-ref  vec 5))

(define (tdb:step-stable-set-stepname!  vec val)(vector-set! vec 0 val))
(define (tdb:step-stable-set-start!     vec val)(vector-set! vec 1 val))
(define (tdb:step-stable-set-end!       vec val)(vector-set! vec 2 val))
(define (tdb:step-stable-set-status!    vec val)(vector-set! vec 3 val))
(define (tdb:step-stable-set-runtime!   vec val)(vector-set! vec 4 val))

;; The data structure for handing off requests via wire
(define (make-cdb:packet)(make-vector 6))
(define (cdb:packet-get-client-sig   vec)    (vector-ref  vec 0))
(define (cdb:packet-get-qtype        vec)    (vector-ref  vec 1))
(define (cdb:packet-get-immediate    vec)    (vector-ref  vec 2))
(define (cdb:packet-get-query-sig    vec)    (vector-ref  vec 3))
(define (cdb:packet-get-params       vec)    (vector-ref  vec 4))
(define (cdb:packet-get-qtime        vec)    (vector-ref  vec 5))
(define (cdb:packet-set-client-sig!  vec val)(vector-set! vec 0 val))
(define (cdb:packet-set-qtype!       vec val)(vector-set! vec 1 val))
(define (cdb:packet-set-immediate!   vec val)(vector-set! vec 2 val))
(define (cdb:packet-set-query-sig!   vec val)(vector-set! vec 3 val))
(define (cdb:packet-set-params!      vec val)(vector-set! vec 4 val))
(define (cdb:packet-set-qtime!       vec val)(vector-set! vec 5 val))

	    (set! curr (make-hash-table))))))
     runs-info)
    (for-each (lambda (state)
		(set! res (cons (list "Totals" state (hash-table-ref totals state)) res)))
	      (sort (hash-table-keys totals) string>=))
    res))

(define (mt:get-run-stats dbstruct run-id)
;;  Get run stats from local access, move this ... but where?
  (db:get-run-stats dbstruct run-id))

;; db:get-runs-by-patt
;; get runs by list of criteria
;; register a test run with the db
;;
;; Use: (db:get-value-by-header (db:get-header runinfo)(db:get-rows runinfo))
;;  to extract info from the structure returned
;;

       (delproc db)))
    (if (and (file-exists? mtdbfile)
	     (file-write-access? mtdbfile))
	(let* ((db (sqlite3:open-database mtdbfile)))
	  (delproc db)
	  (sqlite3:finalize! db)))))




































;; ;; speed up for common cases with a little logic
;; ;; NB// Ultimately this will be deprecated in deference to mt:test-set-state-status-by-id
;;
;;      NOTE: run-id is not used
;; ;;
(define (db:test-set-state-status dbstruct run-id test-id newstate newstatus newcomment)
  (db:with-db

	 (begin
	   (debug:print-error 0 *default-log-port* "reception failed. Received \"" msg "\" but cannot translate it.")
           (print-call-chain (current-error-port))
	   msg))) ;; crude reply for when things go awry
    ((zmq nmsg)(with-input-from-string msg (lambda ()(deserialize))))
    (else msg))) ;; rpc












































































(define (db:roll-up-rules state-status-counts state status)
  (if (null? state-status-counts)
      '(#f #f)
      (let* ((running     (length (filter (lambda (x)
					    (member (dbr:counts-state x) *common:running-states*))
					  state-status-counts)))

	)))


;; traps to catch usage of functions that need to be tracked down

(define (db:get-subdb . params)
  (assert #f "FATAL: Call to db:get-subdb - needs to be fixed."))

(define (tasks:find-task-queue-records dbstruct target run-name test-patt state-patt action-patt)
  (db:with-db
   dbstruct
   #f #f
   (lambda (dbdat db)
     (let ((res '()))
       (sqlite3:for-each-row 
	(lambda (a . b)
	  (set! res (cons (cons a b) res)))
	db "SELECT id,action,owner,state,target,name,testpatt,keylock,params FROM tasks_queue 
           WHERE
              target = ? AND name = ? AND state LIKE ? AND action LIKE ? AND testpatt LIKE ?;"
	target run-name state-patt action-patt test-patt)
       res))))

(define (tasks:get-last dbstruct target runname)
  (let ((res #f))
    (db:with-db
     dbstruct #f #f
     (lambda (dbdat db)
       (sqlite3:for-each-row
	(lambda (id . rem)
	  (set! res (apply vector id rem)))
	db
	(conc "SELECT id,action,owner,state,target,name,testpatt,keylock,params,creation_time,execution_time 
                  FROM tasks_queue 
 	       WHERE  
	        target = ? AND name =?
	       ORDER BY creation_time DESC LIMIT 1;")
	target runname)
       res))))

(define (tasks:set-state-given-param-key dbstruct param-key new-state)
  (db:with-db
   dbstruct #f #t
   (lambda (dbdat db)
     (sqlite3:execute db "UPDATE tasks_queue SET state=? WHERE params LIKE ?;" new-state param-key))))


;; register a task
(define (tasks:add dbstruct action owner target runname testpatt params)
  (db:with-db 
   dbstruct #f #t
   (lambda (dbdat db)
     (sqlite3:execute db "INSERT INTO tasks_queue (action,owner,state,target,name,testpatt,params,creation_time,execution_time)
                             VALUES (?,?,'new',?,?,?,?,strftime('%s','now'),0);" 
		      action
		      owner
		      target
		      runname
		      testpatt
		      (if params params "")))))



)

(declare (uses debugprint))

(import commonmod
	configfmod
	debugprint)

(include "common_records.scm")

;;
;;   Put things here don't fit anywhere else
;;======================================================================

(declare (unit megatestmod))
(declare (uses debugprint))
(declare (uses mtargs))
(declare (uses dbmod))
(declare (uses dbfile))
(declare (uses commonmod))
(declare (uses configfmod))

(use srfi-69)

(module megatestmod
	*

(import scheme)

(define (runconfigs-get config var)
  (let ((targ (common:args-get-target))) ;; (or (args:get-arg "-reqtarg")(args:get-arg "-target")(getenv "MT_TARGET"))))
    (if targ
	(or (configf:lookup config targ var)
	    (configf:lookup config "default" var))
	(configf:lookup config "default" var))))

;;;======================================================================
;;  S T A T E   A N D   S T A T U S   F O R   T E S T S 
;;======================================================================

;; speed up for common cases with a little logic
(define (mt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment)
  (if (not (and run-id test-id))
      (begin
	(debug:print-error 0 *default-log-port* "bad data handed to mt:test-set-state-status-by-id, run-id=" run-id ", test-id=" test-id ", newstate=" newstate)
	(print-call-chain (current-error-port))
	#f)
      (begin
	;; cond
	;; ((and newstate newstatus newcomment)
	;;  (rmt:general-call 'state-status-msg run-id newstate newstatus newcomment test-id))
	;; ((and newstate newstatus)
	;;  (rmt:general-call 'state-status run-id newstate newstatus test-id))
	;; (else
	;;  (if newstate   (rmt:general-call 'set-test-state   run-id newstate   test-id))
	;;  (if newstatus  (rmt:general-call 'set-test-status  run-id newstatus  test-id))
	;;  (if newcomment (rmt:general-call 'set-test-comment run-id newcomment test-id))))
	(rmt:set-state-status-and-roll-up-items run-id test-id #f newstate newstatus newcomment)
	;; (mt:process-triggers run-id test-id newstate newstatus)
	#t)))

(define (mt:test-set-state-status-by-testname-unless-completed run-id test-name item-path new-state new-status new-comment)
  (let ((test-id (rmt:get-test-id run-id test-name item-path)))
    (mt:test-set-state-status-by-id-unless-completed run-id test-id new-state new-status new-comment)))
    
(define (mt:test-set-state-status-by-id-unless-completed run-id test-id newstate newstatus newcomment)
  (let* ((test-vec   (rmt:get-testinfo-state-status run-id test-id))
         (state     (vector-ref test-vec 3)))
    (if (equal? state "COMPLETED")
        #t
        (rmt:set-state-status-and-roll-up-items run-id test-id #f newstate newstatus newcomment))))


  
(define (mt:test-set-state-status-by-testname run-id test-name item-path new-state new-status new-comment)
  ;(let ((test-id (rmt:get-test-id run-id test-name item-path)))
  (rmt:set-state-status-and-roll-up-items run-id test-name item-path new-state new-status new-comment)
  ;; (mt:process-triggers run-id test-id new-state new-status)
  #t);)
	;;(mt:test-set-state-status-by-id run-id test-id new-state new-status new-comment)))

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

;; runs:get-runs-by-patt
;; get runs by list of criteria
;; register a test run with the db
;;
;; Use: (db-get-value-by-header (db:get-header runinfo)(db:get-rows runinfo))
;;  to extract info from the structure returned
;;
(define (mt:get-runs-by-patt keys runnamepatt targpatt)
  (let loop ((runsdat  (rmt:get-runs-by-patt keys runnamepatt targpatt 0 500 #f 0))
	     (res      '())
	     (offset   0)
	     (limit    500))
    ;; (print "runsdat: " runsdat)
    (let* ((header    (vector-ref runsdat 0))
	   (runslst   (vector-ref runsdat 1))
	   (full-list (append res runslst))
	   (have-more (eq? (length runslst) limit)))
      ;; (debug:print 0 *default-log-port* "header: " header " runslst: " runslst " have-more: " have-more)
      (if have-more 
	  (let ((new-offset (+ offset limit))
		(next-batch (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit #f 0)))
	    (debug:print-info 4 *default-log-port* "More than " limit " runs, have " (length full-list) " runs so far.")
	    (debug:print-info 0 *default-log-port* "next-batch: " next-batch)
	    (loop next-batch
		  full-list
		  new-offset
		  limit))
	 (vector header full-list)))))

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

(define (mt:get-tests-for-run run-id testpatt states status #!key (not-in #t) (sort-by 'event_time) (sort-order "ASC") (qryvals #f)(last-update #f))
  (let loop ((testsdat (rmt:get-tests-for-run run-id testpatt states status 0 500 not-in sort-by sort-order qryvals last-update 'normal))
	     (res      '())
	     (offset   0)
	     (limit    500))
    (let* ((full-list (append res testsdat))
	   (have-more (eq? (length testsdat) limit)))
      (if have-more 
	  (let ((new-offset (+ offset limit)))
	    (debug:print-info 4 *default-log-port* "More than " limit " tests, have " (length full-list) " tests so far.")
	    (loop (rmt:get-tests-for-run run-id testpatt states status new-offset limit not-in sort-by sort-order qryvals last-update 'normal)
		  full-list
		  new-offset
		  limit))
	  full-list))))

(define (mt:lazy-get-prereqs-not-met run-id waitons ref-item-path #!key (mode '(normal))(itemmaps #f) )
  (let* ((key    (list run-id waitons ref-item-path mode))
	 (res    (hash-table-ref/default *pre-reqs-met-cache* key #f))
	 (useres (let ((last-time (if (vector? res) (vector-ref res 0) #f)))
		   (if last-time
		       (< (current-seconds)(+ last-time 5))
		       #f))))
    (if useres
	(let ((result (vector-ref res 1)))
	  (debug:print 4 *default-log-port* "Using lazy value res: " result)
	  result)
	(let ((newres (rmt:get-prereqs-not-met run-id waitons ref-item-path mode: mode itemmaps: itemmaps)))
	  (hash-table-set! *pre-reqs-met-cache* key (vector (current-seconds) newres))
	  newres))))

;; set tests with state currstate and status currstatus to newstate and newstatus
;; use currstate = #f and or currstatus = #f to apply to any state or status respectively
;; WARNING: SQL injection risk. NB// See new but not yet used "faster" version below
;;
;;  AND NOT (item_path='' AND testname in (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));")))
;;  (debug:print 0 *default-log-port* "QRY: " qry)
;;  (db:delay-if-busy)
;;
;; NB// This call only operates on toplevel tests. Consider replacing it with more general call
;;
(define (db:set-tests-state-status dbstruct run-id testnames currstate currstatus newstate newstatus)
  (let ((test-ids '()))
    (for-each
     (lambda (testname)
       (let ((qry (conc "UPDATE tests SET state=?,status=? WHERE "
			(if currstate  (conc "state='" currstate "' AND ") "")
			(if currstatus (conc "status='" currstatus "' AND ") "")
			" run_id=? AND testname LIKE ?;"))
	     (test-id (db:get-test-id dbstruct run-id testname "")))
	 (db:with-db
	  dbstruct
	  run-id
	  #t
	  (lambda (dbdat db)
	    (sqlite3:execute db qry
			     (or newstate  currstate "NOT_STARTED")
			     (or newstatus currstate "UNKNOWN")
			     run-id testname)))
	 (if test-id
	     (begin
	       (set! test-ids (cons test-id test-ids))
	       (mt:process-triggers dbstruct run-id test-id newstate newstatus)))))
     testnames)
    test-ids))

;; ; This is to be the big daddy call NOPE: Replaced by db:set-state-status-and-roll-up-items
;; ;
;; define (db:test-set-state-status dbstruct run-id test-id state status msg)
;;  (let ((dbdat  (db:get-subdb dbstruct run-id)))
;;    (if (member state '("LAUNCHED" "REMOTEHOSTSTART"))
;; 	(db:general-call dbdat 'set-test-start-time (list test-id)))
;;    ;; (if msg
;;    ;; 	(db:general-call dbdat 'state-status-msg (list state status msg test-id))
;;    ;; 	(db:general-call dbdat 'state-status     (list state status test-id)))
;;    (db:set-state-status-and-roll-up-items dbstruct run-id test-id #f state status msg)
;;    ;; process the test_data table
;;    (if (and test-id state status (equal? status "AUTO")) 
;; 	(db:test-data-rollup dbstruct run-id test-id status))
;;    (mt:process-triggers dbstruct run-id test-id state status)))

;; state is the priority rollup of all states
;; status is the priority rollup of all completed statesfu
;;
;; if test-name is an integer work off that as test-id instead of test-name test-path
;;
(define (db:set-state-status-and-roll-up-items dbstruct run-id test-name item-path state status comment)
  ;; establish info on incoming test followed by info on top level test
  ;; BBnote - for mode itemwait, linkage between upstream test & matching item status is propagated to run queue in db:prereqs-not-met
  (let* ((testdat      (if (number? test-name)
			   (db:get-test-info-by-id dbstruct run-id test-name) ;; test-name is actually a test-id
			   (db:keep-trying-until-true ;; in our threaded stuff this call could happen before the test is registered (maybe?)
			    db:get-test-info
			    (list dbstruct run-id test-name item-path)
			    10)))
	 (test-id      (db:test-get-id testdat))
	 (test-name    (if (number? test-name)
			   (db:test-get-testname testdat)
			   test-name))
	 (item-path    (db:test-get-item-path testdat))
         (tl-testdat   (db:get-test-info dbstruct run-id test-name ""))
         (tl-test-id   (if tl-testdat
			   (db:test-get-id tl-testdat)
			   #f))
	 (new-state-eh #f)
	 (new-status-eh #f))
    (if (member state '("LAUNCHED" "REMOTEHOSTSTART")) 
	(db:general-call dbstruct run-id 'set-test-start-time (list test-id)))
    (mutex-lock! *db-transaction-mutex*)
    (db:with-db
     dbstruct run-id #t
     (lambda (dbdat db)
       (let ((tr-res
              (sqlite3:with-transaction
               db
               (lambda ()
                 ;; NB// Pass the db so it is part fo the transaction
                 (db:test-set-state-status-db db run-id test-id state status comment) ;; this call sets the item state/status
                 (if (not (equal? item-path "")) ;; only roll up IF incoming test is an item
                     (let* ((state-status-counts (db:get-all-state-status-counts-for-test db run-id test-name item-path state status)) ;; item-path is used to exclude current state/status of THIS test
			    (state-statuses      (db:roll-up-rules state-status-counts state status))
                            (newstate            (car state-statuses))
                            (newstatus           (cadr state-statuses)))
		       (set! new-state-eh newstate)
		       (set! new-status-eh newstatus)
                       (debug:print 4 *default-log-port* "BB> tl-test-id="tl-test-id" ; "test-name":"item-path" newstate="newstate" newstatus="newstatus" len(sscs)="(length state-status-counts)  " state-status-counts: "
				    (apply conc
					   (map (lambda (x)
						  (conc
                     				   (with-output-to-string (lambda () (pp (dbr:counts->alist x)))) " | "))
						state-status-counts))); end debug:print
		       (if tl-test-id
			   (db:test-set-state-status-db db run-id tl-test-id newstate newstatus #f)) ;; we are still in the transaction - must access the db and not the dbstruct
		       ))))))
         (mutex-unlock! *db-transaction-mutex*)
         (if (and test-id state status (equal? status "AUTO")) 
             (db:test-data-rollup dbstruct run-id test-id status))
	 (if new-state-eh ;; moved from db:test-set-state-status
	      (mt:process-triggers dbstruct run-id test-id new-state-eh new-status-eh))
         tr-res)))))


)

(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")

;; This is the Megatest API. All generally "useful" routines will be wrapped or extended
;; here.




(define (mt:lazy-read-test-config test-name)


















  (let ((tconf (hash-table-ref/default *testconfigs* test-name #f)))
    (if tconf
	tconf
	(let ((test-dirs (tests:get-tests-search-path *configdat*)))



	  (let loop ((hed (car test-dirs))


		     (tal (cdr test-dirs)))

	    ;; Setting MT_LINKTREE here is almost certainly unnecessary. 



	    (let ((tconfig-file (conc hed "/" test-name "/testconfig")))
	      (if (and (common:file-exists? tconfig-file)
		       (file-read-access? tconfig-file))








		  (let ((link-tree-path (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree"))






			(old-link-tree  (get-environment-variable "MT_LINKTREE")))




		    (if link-tree-path (setenv "MT_LINKTREE" link-tree-path))



		    (let ((newtcfg (read-config tconfig-file #f #f))) ;; NOTE: Does NOT run [system ...]



		      (hash-table-set! *testconfigs* test-name newtcfg)
		      (if old-link-tree 
			  (setenv "MT_LINKTREE" old-link-tree)



			  (unsetenv "MT_LINKTREE"))

		      newtcfg))
		  (if (null? tal)

		      (begin
			(debug:print-error 0 *default-log-port* "No readable testconfig found for " test-name)






			#f)



		      (loop (car tal)(cdr tal))))))))))




























































(define (mt:process-triggers dbstruct run-id test-id newstate newstatus)
  (if test-id 
      (let* ((test-dat      (db:get-test-info-by-id dbstruct run-id test-id)))
	(if test-dat
	    (let* ((test-rundir   (db:test-get-rundir       test-dat)) ;; ) ;; )
		   (test-name     (db:test-get-testname     test-dat))

                                 (conc state "/")
                                 (conc "/" status)))
		     (pop-directory))
                    )) ;; )
	      ;; (mutex-unlock! *triggers-mutex*)
	      )))))

;;======================================================================

(declare (unit mtmod))
(declare (uses debugprint))
(declare (uses mtargs))
(declare (uses commonmod))
(declare (uses configfmod))
;; (declare (uses tcp-transportmod)) ;; we don't want mtmod depending on tcp

(use srfi-69)

(module mtmod
	*

(import scheme)
(cond-expand
 (chicken-4
  
  (import chicken
	  ports
	  (prefix base64 base64:)

	  (prefix sqlite3 sqlite3:)
	  data-structures 
	  directory-utils
	  extras
	  files
	  matchable
	  md5
	  message-digest
	  pathname-expand
	  posix
	  posix-extras
	  regex
	  regex-case
	  sparse-vectors
	  srfi-1
	  srfi-18
	  srfi-69
	  typed-records
	  z3
	  
	  debugprint
	  commonmod
	  configfmod
	  ;; tcp-transportmod
	  (prefix mtargs args:)
	  )
  (use srfi-69))
 (chicken-5
  (import (prefix sqlite3 sqlite3:)
	  ;; data-structures
	  ;; extras

	  srfi-18
	  srfi-69
	  typed-records
	  system-information

	  debugprint
  )))

;; imports common to chk5 and ck4
(import srfi-13)

(include "db_records.scm")

(define (common:get-fields cfgdat)
  (let ((fields (hash-table-ref/default cfgdat "fields" '())))
    (map car fields)))

;;======================================================================
;; stuff from keys that can't be in commonmod. Maybe move all from commonmod to here?

		      (create-directory dbarea)))
		;; ensure tmp area has .mtdb
		(let ((dbarea (conc dbpath "/.mtdb")))
		  (if (not (file-exists? dbarea))
		      (create-directory dbarea)))
		dbpath))
	  #f)))

;======================================================================
;;  T R I G G E R S
;;======================================================================

(define (mt:run-trigger cmd test-id test-rundir trigger logname test-name item-path event-time actual-state actual-status target runname)
  ;; Putting the commandline into ( )'s means no control over the shell. 
  ;; stdout and stderr will be caught in the NBFAKE or mt_launch.log files
  ;; or equivalent. No need to do this. Just run it?
  (let* ((new-trigger-format (configf:lookup *configdat* "setup" "new-trigger-format"))
         (fullcmd 
          (if (and new-trigger-format (string=? new-trigger-format "yes"))
            (conc "nbfake "
			cmd           " "
			test-id       " "
			test-rundir   " "
			trigger       " "
			actual-state  " "
			actual-status " "
			event-time    " "
                        target        " "
                        runname       " "
			test-name     " "
			item-path
			)
            (conc "nbfake "
			cmd           " "
			test-id       " "
			test-rundir   " "
			trigger       " "
			test-name     " "
			item-path     " " 
			actual-state  " "
			actual-status " "
			event-time
			)
          ))
	 (prev-nbfake-log (get-environment-variable "NBFAKE_LOG")))
    (setenv "NBFAKE_LOG" (conc (cond
				((and (directory-exists? test-rundir)
				      (file-write-access? test-rundir))
				 test-rundir)
				((and (directory-exists? *toppath*)
				      (file-write-access? *toppath*))
				 *toppath*)
				(else (conc "/tmp/" (current-user-name))))
			       "/" logname))
    (debug:print-info 0 *default-log-port* "TRIGGERED on " trigger ", running command " fullcmd " output at " (get-environment-variable "NBFAKE_LOG"))
    (process-run fullcmd)
    (if prev-nbfake-log
	(setenv "NBFAKE_LOG" prev-nbfake-log)
	(unsetenv "NBFAKE_LOG"))
    ))


(define (mt:discard-blocked-tests run-id failed-test tests test-records)
  (if (null? tests)
      tests
      (begin
	(debug:print-info 1 *default-log-port* "Discarding tests from " tests " that are waiting on " failed-test)
	(let loop ((testn (car tests))
		   (remt  (cdr tests))
		   (res   '()))
	  (let* ((test-dat (hash-table-ref/default test-records testn (vector #f #f '())))
		 (waitons  (vector-ref test-dat 2)))
	    ;; (print "mt:discard-blocked-tests run-id: " run-id " failed-test: " failed-test " testn: " testn " with waitons: " waitons)
	    (if (null? remt)
		(let ((new-res (reverse res)))
		  ;; (print "       new-res: " new-res)
		  new-res)
		(loop (car remt)
		      (cdr remt)
		      (if (member failed-test waitons)
			  (begin
			    (debug:print 0 *default-log-port* "Discarding test " testn "(" test-dat ") due to " failed-test)
			    res)
			  (cons testn res)))))))))


;; Puts out all combinations
(define (process-itemlist hierdepth curritemkey itemlist)
  (let ((res '()))
    (if (not hierdepth)
	(set! hierdepth (length itemlist)))
    (let loop ((hed (car itemlist))
	       (tal (cdr itemlist)))
      (if (null? tal)
	  (for-each (lambda (item)
		      (if (> (length curritemkey) (- hierdepth 2))
			  (set! res (append res (list (append curritemkey (list (list (car hed) item))))))))
		    (cadr hed))
	  (begin
	    (for-each (lambda (item)
			(set! res (append res (process-itemlist hierdepth (append curritemkey (list (list (car hed) item))) tal))))
		      (cadr hed))
	    (loop (car tal)(cdr tal)))))
    res))

;; (item-assoc->item-list '(("ANIMAL" "Elephant Lion")("SEASON" "Spring Fall")))
;;   => ((("ANIMAL" "Elephant") ("SEASON" "Spring")) 
;;       (("ANIMAL" "Elephant") ("SEASON" "Fall")) 
;;       (("ANIMAL" "Lion")     ("SEASON" "Spring"))
;;       (("ANIMAL" "Lion")     ("SEASON" "Fall")))
(define (item-assoc->item-list itemsdat)
  (if (and itemsdat (not (null? itemsdat)))
      (let ((itemlst (filter (lambda (x)
			       (list? x))
			     (map (lambda (x)
				    (debug:print 6 *default-log-port* "item-assoc->item-list x: " x)
				    (if (< (length x) 2)
					(begin
					  (debug:print-error 0 *default-log-port* "malformed items spec " (string-intersperse x " "))
					  (list (car x)'()))
					(let* ((name (car x))
					       (items (cadr x))
					       (ilist (list name (if (string? items)
								     (string-split items)
								     '()))))
					  (if (null? ilist)
					      (debug:print-error 0 *default-log-port* "No items specified for " name))
					  ilist)))
				  itemsdat))))
	(let ((debuglevel 5))
	  (debug:print 5 *default-log-port* "item-assoc->item-list: itemsdat => itemlst ")
	  (if (debug:debug-mode 5)
	      (begin
		(pp itemsdat)
		(print " => ")
		(pp itemlst))))
	(if (> (length itemlst) 0)
	    (process-itemlist #f '() itemlst)
	    '()))
      '())) ;; return a list consisting on a single null list for non-item runs
            ;; Nope, not now, return null as of 6/6/2011

;; (item-table->item-list '(("ANIMAL" "Elephant Lion")("SEASON" "Spring Winter")))
;;   => ((("ANIMAL" "Elephant")("SEASON" "Spring"))
;;       (("ANIMAL" "Lion")    ("SEASON" "Winter")))
(define (item-table->item-list itemtable)
  (let ((newlst (map (lambda (x)
		       (if (> (length x) 1)
			   (list (car x)
				 (string-split (cadr x)))
			   (list x '())))
		     itemtable))
	(res     '())) ;; a list of items
    (let loop ((indx    0)
	       (item   '()) ;; an item will be ((KEYNAME1 VAL1)(KEYNAME2 VAL2) ...)
	       (elflag  #f))
      (for-each (lambda (row)
		  (let ((rowname (car row))
			(rowdat  (cadr row)))
		    (set! item (append item 
				       (list 
					(if (< indx (length rowdat))
					    (let ((new (list rowname (list-ref rowdat indx))))
					      ;; (debug:print 0 *default-log-port* "New: " new)
					      (set! elflag #t)
					      new
					      ) ;; i.e. had at least on legit value to use
					    (list rowname "-")))))))
		newlst)
      (if elflag
	  (begin
	    (set! res (append res (list item)))
	    (loop (+ indx 1)
		  '()
		  #f)))
      res)))
            ;; Nope, not now, return null as of 6/6/2011
		
(define (items:check-valid-items class item)
  (let ((valid-values (let ((s (configf:lookup *configdat* "validvalues" class)))
			(if s (string-split s) #f))))
    (if valid-values
	(if (member item valid-values)
	    item #f)
	item)))

;;  '(("k1" "k2" "k3")
;;    ("a" "b" "c")
;;    ("d" "e" "f"))
;;
;;    => '((("k1" "a")("k2" "b")("k3" "c"))
;;         (("k1" "d")("k2" "e")("k3" "f")))
;;
(define (items:first-row-intersperse data)
  (if (< (length data) 2)
      '()
      (let ((header (car data))
	    (rows   (cdr data)))
	(map (lambda (row)
	       (map list header row))
	     rows))))

;; k1/k2/k3
;; a/b/c
;; d/e/f
;;    => '(("k1" "k2" "k3")
;;         ("a" "b" "c")
;;         ("d" "e" "f"))
;;
;;    => '((("k1" "a")("k2" "b")("k3" "c"))
;;         (("k1" "d")("k2" "e")("k3" "f")))
;;
(define (items:read-items-file fname ftype) ;; 'sxml 'slash 'space 
  (if (and fname (file-exists? fname))
      (items:first-row-intersperse (case ftype
				     ((slash space)
				      (let ((splitter (case ftype
							((slash) (lambda (x)(string-split x "/")))
							(else    string-split))))
					(debug:print 0 *default-log-port* "Reading " fname " of type " ftype)
					(with-input-from-file fname
					  (lambda ()
					    (let loop ((inl (read-line))
						       (res '()))
					      (if (eof-object? inl)
						  res
						  (loop (read-line)(cons (splitter inl) res))))))))
				     ((sxml)(with-input-from-file fname read))
				     (else (debug:print 0 *default-log-port* "items file type " ftype " not recognised"))))
      (begin
	(if fname (debug:print 0 *default-log-port* "no items file " fname " found"))
	'())))

(define (items:get-items-from-config tconfig)
  (let* ((slashf      (configf:lookup tconfig "itemopts" "slash")) ;; a/b/c\nd/e/f\n ...
	 (sxmlf       (configf:lookup tconfig "itemopts" "sxml"))  ;; '(("a" "b" "c")("d" "e" "f") ...)
	 (spacef      (configf:lookup tconfig "itemopts" "space")) ;; a b c\nd e f\n ...
	 (have-items  (hash-table-ref/default tconfig "items"      #f))
	 (have-itable (hash-table-ref/default tconfig "itemstable" #f))
	 (items       (hash-table-ref/default tconfig "items"      '()))
	 (itemstable  (hash-table-ref/default tconfig "itemstable" '())))
    (debug:print 5 *default-log-port* "items: " items " itemstable: " itemstable)
    (set! items (map (lambda (item)
		       (if (procedure? (cadr item))
			   (list (car item)((cadr item)))  ;; evaluate the proc
			   item))
		     items))
    (set! itemstable (map (lambda (item)
			    (if (procedure? (cadr item))
				(list (car item)((cadr item)))  ;; evaluate the proc
				item))
			  itemstable))
    (if (and have-items  (null? items))     (debug:print 0 *default-log-port* "WARNING:[items] section in testconfig but no entries defined"))
    (if (and have-itable (null? itemstable))(debug:print 0 *default-log-port* "WARNNG:[itemstable] section in testconfig but no entries defined"))
    (if (or (not (null? items))
	    (not (null? itemstable))
	    slashf
	    sxmlf
	    spacef)
	(append (item-assoc->item-list items)
		(item-table->item-list itemstable)
		(items:read-items-file slashf 'slash)
		(items:read-items-file sxmlf  'sxml)
		(items:read-items-file spacef 'space))
	'(()))))

;; (pp (item-assoc->item-list itemdat))


	

)

(declare (unit rmtmod))
(declare (uses debugprint))
(declare (uses commonmod))
(declare (uses dbfile))    ;; needed for records
(declare (uses dbmod))
(declare (uses mtmod))
(declare (uses tcp-transportmod))
(declare (uses apimod))

(module rmtmod
	*
	
(import scheme chicken data-structures extras matchable srfi-1 srfi-69)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18)
(import commonmod
	tcp-transportmod
	dbfile
	dbmod
	debugprint
	apimod
	mtmod)

(include "db_records.scm")

(defstruct alldat
  (areapath #f)
  (ulexdat  #f)

			     (if (> tot 10)
				 (cons newmax-cmd currmax)
				 (cons 'none 0))
			     (loop (car tal)(cdr tal) newmax-cmd currmax)))))))
    (mutex-unlock! *db-stats-mutex*)
    res))

;; =not-used= (define (rmt:open-qry-close-locally cmd run-id params #!key (remretries 5))
;; =not-used=   (let* ((qry-is-write    (not (member cmd api:read-only-queries)))
;; =not-used= 	 (db-file-path    (common:make-tmpdir-name *toppath* "")) ;;  0))
;; =not-used= 	 (dbstructs-local (db:setup))
;; =not-used= 	 (read-only       (not (file-write-access? db-file-path)))
;; =not-used= 	 (start           (current-milliseconds))
;; =not-used= 	 (resdat          (if (not (and read-only qry-is-write))
;; =not-used= 			      (let ((v (api:execute-requests dbstructs-local (vector (symbol->string cmd) params))))
;; =not-used= 			;;	(handle-exceptions ;; there has been a long history of receiving strange errors from values returned by the client when things go wrong..
;; =not-used= 			;;	 exn               ;;  This is an attempt to detect that situation and recover gracefully
;; =not-used= 			;;	 (begin
;; =not-used= 			;;	   (debug:print 0 *default-log-port* "ERROR: bad data from server " v " message: "  ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)
;; =not-used= 			;;	   (vector #t '())) ;; should always get a vector but if something goes wrong return a dummy
;; =not-used= 				 (if (and (vector? v)
;; =not-used= 					  (> (vector-length v) 1))
;; =not-used= 				     (let ((newvec (vector (vector-ref v 0)(vector-ref v 1))))
;; =not-used= 				       newvec)           ;; by copying the vector while inside the error handler we should force the detection of a corrupted record
;; =not-used= 				     (vector #t '()))) ;; )  ;; we could also check that the returned types are valid
;; =not-used= 			      (vector #t '())))
;; =not-used= 	 (success        (vector-ref resdat 0))
;; =not-used= 	 (res            (vector-ref resdat 1))
;; =not-used= 	 (duration       (- (current-milliseconds) start)))
;; =not-used=     (if (and read-only qry-is-write)
;; =not-used=         (debug:print 0 *default-log-port* "ERROR: attempt to write to read-only database ignored. cmd=" cmd))
;; =not-used=     (if (not success)
;; =not-used= 	(if (> remretries 0)
;; =not-used= 	    (begin
;; =not-used= 	      (debug:print-error 0 *default-log-port* "local query failed. Trying again.")
;; =not-used= 	      (thread-sleep! (/ (random 5000) 1000)) ;; some random delay 
;; =not-used= 	      (rmt:open-qry-close-locally cmd run-id params remretries: (- remretries 1)))
;; =not-used= 	    (begin
;; =not-used= 	      (debug:print-error 0 *default-log-port* "too many retries in rmt:open-qry-close-locally, giving up")
;; =not-used= 	      #f))
;; =not-used= 	(begin
;; =not-used= 	  ;; (rmt:update-db-stats run-id cmd params duration)
;; =not-used= 	  ;; mark this run as dirty if this was a write, the watchdog is responsible for syncing it
;; =not-used= 	  (if qry-is-write
;; =not-used= 	      (let ((start-time (current-seconds)))
;; =not-used= 		(mutex-lock! *db-multi-sync-mutex*)
;; =not-used= 		(set! *db-last-access* start-time)  ;; THIS IS PROBABLY USELESS? (we are on a client)
;; =not-used=                 (mutex-unlock! *db-multi-sync-mutex*)))))
;; =not-used=     res))

;;======================================================================
;;
;; A C T U A L   A P I   C A L L S  
;;
;;======================================================================

	dbmod
	rmtmod
	(prefix mtargs args:))

(import dbfile)
;; (import pgdb) ;; pgdb is a module

;;======================================================================
;; Copyright 2017, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest 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.
;; 
;;     Megatest 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 Megatest.  If not, see <http://www.gnu.org/licenses/>.

;;======================================================================

;;======================================================================
;; Cpumod:
;;
;;   Put things here don't fit anywhere else
;;======================================================================

(declare (unit tasksmod))
(declare (uses debugprint))
(declare (uses mtargs))
(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses dbfile))
(declare (uses dbmod))
(declare (uses rmtmod))

(use srfi-69)

(module tasksmod
	*

(import scheme)
(cond-expand
 (chicken-4
  
  (import chicken
	  ports
	  data-structures
	  extras
	  files
	  matchable
	  pathname-expand
	  posix
	  posix-extras
	  regex
	  regex-case
	  sparse-vectors
	  
	  )
  (use srfi-69))
 (chicken-5
  (import (prefix sqlite3 sqlite3:)
	  ;; data-structures
	  ;; extras
	  ;; files
	  ;; posix
	  ;; posix-extras
	  chicken.base
	  chicken.condition
	  chicken.file
	  chicken.file.posix
	  chicken.io
	  chicken.pathname
	  chicken.port
	  chicken.process
	  chicken.process-context
	  chicken.process-context.posix
	  chicken.sort
	  chicken.string
	  chicken.time
	  chicken.time.posix
	  
	  matchable
	  md5
	  message-digest
	  pathname-expand
	  regex
	  regex-case
	  system-information

  )))

;; imports common to ck4 and ck5
(import srfi-1
	srfi-13
	srfi-18
	srfi-69
	typed-records
	(prefix base64 base64:)
	(prefix sqlite3 sqlite3:)
	md5
	message-digest
	z3
	
	debugprint
	commonmod
	configfmod
	(prefix mtargs args:)
	dbmod
	dbfile
	rmtmod
	)

(include "task_records.scm")
(include "db_records.scm")

;;======================================================================
;; Tasks db
;;======================================================================

(define (tasks:get-task-db-path)
  (let ((dbdir  (or (configf:lookup *configdat* "setup" "monitordir")
		    (configf:lookup *configdat* "setup" "dbdir")
		    (conc (common:get-linktree) "/.db"))))
    (handle-exceptions
     exn
     (begin
       (debug:print-error 0 *default-log-port* "Couldn't create path to " dbdir ", exn=" exn)
       (exit 1))
     (if (not (directory? dbdir))(create-directory dbdir #t)))
    dbdir))

;; If file exists AND
;;    file readable
;;         ==> open it
;; If file exists AND
;;    file NOT readable
;;         ==> open in-mem version
;; If file NOT exists
;;    ==> open in-mem version
;;
(define (tasks:open-db #!key (numretries 4))
  (if *task-db*
      *task-db*
      (handle-exceptions
       exn
       (if (> numretries 0)
	   (begin
	     (print-call-chain (current-error-port))
	     (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
	     (debug:print 5 *default-log-port* " exn=" (condition->list exn))
	     (thread-sleep! 1)
	     (tasks:open-db numretries (- numretries 1)))
	   (begin
	     (print-call-chain (current-error-port))
	     (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
	     (debug:print 5 *default-log-port* " exn=" (condition->list exn))))
       (let* ((dbpath        (common:make-tmpdir-name *toppath* "")) ;; (tasks:get-task-db-path))
	      (dbfile       (conc dbpath "/monitor.db"))
	      (avail        (tasks:wait-on-journal dbpath 10)) ;; wait up to about 10 seconds for the journal to go away
	      (exists       (common:file-exists? dbpath))
	      (write-access (file-write-access? dbpath))
	      (mdb          (cond ;; what the hek is *toppath* doing here?
			     ((and (string? *toppath*)(file-write-access? *toppath*))
			      (sqlite3:open-database dbfile))
			     ((file-read-access? dbpath)    (sqlite3:open-database dbfile))
			     (else (sqlite3:open-database ":memory:")))) ;; (never-give-up-open-db dbpath))
	      (handler      (sqlite3:make-busy-timeout 36000)))
	 (if (and exists
		  (not write-access))
	     (set! *db-write-access* write-access)) ;; only unset so other db's also can use this control
	 (sqlite3:set-busy-handler! mdb handler)
	 (db:set-sync mdb) ;; (sqlite3:execute mdb (conc "PRAGMA synchronous = 0;"))
	 ;;  (if (or (and (not exists)
	 ;; 	      (file-write-access? *toppath*))
	 ;; 	 (not (file-read-access? dbpath)))
	 ;;      (begin
	 ;; 
	 ;; TASKS QUEUE MOVED TO main.db
	 ;;
	 ;; (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS tasks_queue (id INTEGER PRIMARY KEY,
         ;;                        action TEXT DEFAULT '',
         ;;                        owner TEXT,
         ;;                        state TEXT DEFAULT 'new',
         ;;                        target TEXT DEFAULT '',
         ;;                        name TEXT DEFAULT '',
         ;;                        testpatt TEXT DEFAULT '',
         ;;                        keylock TEXT,
         ;;                        params TEXT,
         ;;                        creation_time TIMESTAMP,
         ;;                        execution_time TIMESTAMP);")
	 (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS monitors (id INTEGER PRIMARY KEY,
                                pid INTEGER,
                                start_time TIMESTAMP,
                                last_update TIMESTAMP,
                                hostname TEXT,
                                username TEXT,
                               CONSTRAINT monitors_constraint UNIQUE (pid,hostname));")
	 (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS servers (id INTEGER PRIMARY KEY,
                                  pid INTEGER,
                                  interface TEXT,
                                  hostname TEXT,
                                  port INTEGER,
                                  pubport INTEGER,
                                  start_time TIMESTAMP,
                                  priority INTEGER,
                                  state TEXT,
                                  mt_version TEXT,
                                  heartbeat TIMESTAMP,
                                  transport TEXT,
                                  run_id INTEGER);")
	 ;;                               CONSTRAINT servers_constraint UNIQUE (pid,hostname,port));")
	 (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS clients (id INTEGER PRIMARY KEY,
                                  server_id INTEGER,
                                  pid INTEGER,
                                  hostname TEXT,
                                  cmdline TEXT,
                                  login_time TIMESTAMP,
                                  logout_time TIMESTAMP DEFAULT -1,
                                CONSTRAINT clients_constraint UNIQUE (pid,hostname));")
	       
	       ;))
	 (set! *task-db* (cons mdb dbpath))
	 *task-db*))))

;;======================================================================
;; Server and client management
;;======================================================================

;; make-vector-record tasks hostinfo id interface port pubport transport pid hostname
(define (tasks:hostinfo-get-id          vec)    (vector-ref  vec 0))
(define (tasks:hostinfo-get-interface   vec)    (vector-ref  vec 1))
(define (tasks:hostinfo-get-port        vec)    (vector-ref  vec 2))
(define (tasks:hostinfo-get-pubport     vec)    (vector-ref  vec 3))
(define (tasks:hostinfo-get-transport   vec)    (vector-ref  vec 4))
(define (tasks:hostinfo-get-pid         vec)    (vector-ref  vec 5))
(define (tasks:hostinfo-get-hostname    vec)    (vector-ref  vec 6))

(define (tasks:need-server run-id)
  (equal? (configf:lookup *configdat* "server" "required") "yes"))

;; no elegance here ...
;;
(define (tasks:kill-server hostname pid #!key (kill-switch ""))
  (debug:print-info 0 *default-log-port* "Attempting to kill server process " pid " on host " hostname)
  (setenv "TARGETHOST" hostname)
  (let* ((logdir (if (directory-exists? "logs")
                    "logs/"
                    ""))
         (logfile (if logdir (conc "logs/server-"pid"-"hostname".log") #f))
         (gzfile  (if logfile (conc logfile ".gz"))))
    (setenv "TARGETHOST_LOGF" (conc logdir "server-kills.log"))

    (system (conc "nbfake kill "kill-switch" "pid))

    (when logfile
      (thread-sleep! 0.5)
      (if (common:file-exists? gzfile) (delete-file gzfile))
      (system (conc "gzip " logfile))
      
      (unsetenv "TARGETHOST_LOGF")
      (unsetenv "TARGETHOST"))))
    
 
;;======================================================================
;; M O N I T O R S
;;======================================================================

(define (tasks:remove-monitor-record mdb)
  (sqlite3:execute mdb "DELETE FROM monitors WHERE pid=? AND hostname=?;"
		   (current-process-id)
		   (get-host-name)))

(define (tasks:get-monitors mdb)
  (let ((res '()))
    (sqlite3:for-each-row
     (lambda (a . rem)
       (set! res (cons (apply vector a rem) res)))
     mdb
     "SELECT id,pid,strftime('%m/%d/%Y %H:%M',datetime(start_time,'unixepoch'),'localtime'),strftime('%m/%d/%Y %H:%M:%S',datetime(last_update,'unixepoch'),'localtime'),hostname,username FROM monitors ORDER BY last_update ASC;")
    (reverse res)
    ))

(define (tasks:monitors->text-table monitors)
  (let ((fmtstr "~4a~8a~20a~20a~10a~10a"))
    (conc (format #f fmtstr "id" "pid" "start time" "last update" "hostname" "user") "\n"
	  (string-intersperse 
	   (map (lambda (monitor)
		  (format #f fmtstr
			  (tasks:monitor-get-id          monitor)
			  (tasks:monitor-get-pid         monitor)
			  (tasks:monitor-get-start_time  monitor)
			  (tasks:monitor-get-last_update monitor)
			  (tasks:monitor-get-hostname    monitor)
			  (tasks:monitor-get-username    monitor)))
		monitors)
	   "\n"))))
   
;; update the last_update field with the current time and
;; if any monitors appear dead, remove them
(define (tasks:monitors-update mdb)
  (sqlite3:execute mdb "UPDATE monitors SET last_update=strftime('%s','now') WHERE pid=? AND hostname=?;"
			  (current-process-id)
			  (get-host-name))
  (let ((deadlist '()))
    (sqlite3:for-each-row
     (lambda (id pid host last-update delta)
       (debug:print 0 *default-log-port* "Going to delete stale record for monitor with pid " pid " on host " host " last updated " delta " seconds ago")
       (set! deadlist (cons id deadlist)))
     mdb 
     "SELECT id,pid,hostname,last_update,strftime('%s','now')-last_update AS delta FROM monitors WHERE delta > 700;")
    (sqlite3:execute mdb (conc "DELETE FROM monitors WHERE id IN ('" (string-intersperse (map conc deadlist) "','") "');")))
  )
(define (tasks:register-monitor db port)
  (let* ((pid (current-process-id))
	 (hostname (get-host-name))
	 (userinfo (user-information (current-user-id)))
	 (username (car userinfo)))
    (debug:print 0 *default-log-port* "Register monitor, pid: " pid ", hostname: " hostname ", port: " port ", username: " username)
    (sqlite3:execute db "INSERT INTO monitors (pid,start_time,last_update,hostname,username) VALUES (?,strftime('%s','now'),strftime('%s','now'),?,?);"
		     pid hostname username)))

(define (tasks:get-num-alive-monitors mdb)
  (let ((res 0))
    (sqlite3:for-each-row 
     (lambda (count)
       (set! res count))
     mdb
     "SELECT count(id) FROM monitors WHERE last_update < (strftime('%s','now') - 300) AND username=?;"
     (car (user-information (current-user-id))))
    res))

;; 
#;(define (tasks:start-monitor db mdb)
  (if (> (tasks:get-num-alive-monitors mdb) 2) ;; have two running, no need for more
      (debug:print-info 1 *default-log-port* "Not starting monitor, already have more than two running")
      (let* ((megatestdb     (conc *toppath* "/megatest.db"))
	     (monitordbf     (conc (db:dbfile-path #f) "/monitor.db"))
	     (last-db-update 0)) ;; (file-modification-time megatestdb)))
	(task:register-monitor mdb)
	(let loop ((count      0)
		   (next-touch 0)) ;; next-touch is the time where we need to update last_update
	  ;; if the db has been modified we'd best look at the task queue
	  (let ((modtime (file-modification-time megatestdbpath )))
	    (if (> modtime last-db-update)
		(tasks:process-queue db)) ;; BROKEN. mdb last-db-update megatestdb next-touch))
	    ;; WARNING: Possible race conditon here!!
	    ;; should this update be immediately after the task-get-action call above?
	    (if (> (current-seconds) next-touch)
		(begin
		  (tasks:monitors-update mdb)
		  (loop (+ count 1)(+ (current-seconds) 240)))
		(loop (+ count 1) next-touch)))))))
      
;;======================================================================
;; T A S K S   Q U E U E
;;
;;   NOTE:: These operate on task_queue which is in main.db
;;
;;======================================================================

;; NOTE: It might be good to add one more layer of checking to ensure
;;       that no task gets run in parallel.

;; id INTEGER PRIMARY KEY,
;; action TEXT DEFAULT '',
;; owner TEXT,
;; state TEXT DEFAULT 'new',
;; target TEXT DEFAULT '',
;; name TEXT DEFAULT '',
;; testpatt TEXT DEFAULT '',
;; keylock TEXT,
;; params TEXT,
;; creation_time TIMESTAMP DEFAULT (strftime('%s','now')),
;; execution_time TIMESTAMP);

(define (keys:key-vals-hash->target keys key-params)
  (let ((tmp (hash-table-ref/default key-params (vector-ref (car keys) 0) "")))
    (if (> (length keys) 1)
	(for-each (lambda (key)
		    (set! tmp (conc tmp "/" (hash-table-ref/default key-params (vector-ref key 0) ""))))
		  (cdr keys)))
    tmp))
								
;; for use from the gui, not ported
;;
;; (define (tasks:add-from-params mdb action keys key-params var-params)
;;   (let ((target    (keys:key-vals-hash->target keys key-params))
;; 	(owner     (car (user-information (current-user-id))))
;; 	(runname   (hash-table-ref/default var-params "runname" #f))
;; 	(testpatts (hash-table-ref/default var-params "testpatts" "%"))
;; 	(params    (hash-table-ref/default var-params "params"    "")))
;;     (tasks:add mdb action owner target runname testpatts params)))

;; return one task from those who are 'new' OR 'waiting' AND more than 10sec old
;;
(define (tasks:snag-a-task dbstruct)
  (let ((res    #f)
	(keytxt (conc (current-process-id) "-" (get-host-name) "-" (car (user-information (current-user-id))))))
    (db:with-db
     dbstruct #f #t
     (lambda (dat db)
       ;; first randomly set a new to pid-hostname-hostname
       (sqlite3:execute
	db 
	"UPDATE tasks_queue SET keylock=? WHERE id IN
           (SELECT id FROM tasks_queue 
              WHERE state='new' OR 
                    (state='waiting' AND (strftime('%s','now')-execution_time) > 10) OR
                    state='reset'
              ORDER BY RANDOM() LIMIT 1);" keytxt)

       (sqlite3:for-each-row
	(lambda (id . rem)
	  (set! res (apply vector id rem)))
	db
	"SELECT id,action,owner,state,target,name,test,item,params,creation_time,execution_time FROM tasks_queue WHERE keylock=? ORDER BY execution_time ASC LIMIT 1;" keytxt)
       (if res ;; yep, have work to be done
	   (begin
	     (sqlite3:execute db "UPDATE tasks_queue SET state='inprogress',execution_time=strftime('%s','now') WHERE id=?;"
			      (tasks:task-get-id res))
	     res)
	   #f)))))

(define (tasks:reset-stuck-tasks dbstruct)
  (let ((res '()))
    (db:with-db
     dbstruct #f #t
     (lambda (dat db)
       (sqlite3:for-each-row
	(lambda (id delta)
	  (set! res (cons id res)))
	db
	"SELECT id,strftime('%s','now')-execution_time AS delta FROM tasks_queue WHERE state='inprogress' AND delta>700 ORDER BY delta DESC LIMIT 2;")
       (sqlite3:execute 
	db 
	(conc "UPDATE tasks_queue SET state='reset' WHERE id IN ('" (string-intersperse (map conc res) "','") "');")
	)))))

;; return all tasks in the tasks_queue table
;;
(define (tasks:get-tasks dbstruct types states)
  (let ((res '()))
    (db:with-db
     dbstruct #f #f
     (lambda (dbdat db)
       (sqlite3:for-each-row
	(lambda (id . rem)
	  (set! res (cons (apply vector id rem) res)))
	db
	(conc "SELECT id,action,owner,state,target,name,test,item,params,creation_time,execution_time 
                  FROM tasks_queue "
	      ;; WHERE  
	      ;;   state IN " statesstr " AND 
	      ;;   action IN " actionsstr 
	      " ORDER BY creation_time DESC;"))
       res))))

;; remove tasks given by a string of numbers comma separated
(define (tasks:remove-queue-entries dbstruct task-ids)
  (db:with-db
   dbstruct #f #t
   (lambda (dbdat db)
     (sqlite3:execute db (conc "DELETE FROM tasks_queue WHERE id IN (" task-ids ");")))))

;; (define (tasks:process-queue dbstruct)
;;   (let* ((task   (tasks:snag-a-task dbstruct))
;; 	 (action (if task (tasks:task-get-action task) #f)))
;;     (if action (print "tasks:process-queue task: " task))
;;     (if action
;; 	(case (string->symbol action)
;; 	  ((run)       (tasks:start-run     dbstruct task))
;; 	  ((remove)    (tasks:remove-runs   dbstruct task))
;; 	  ((lock)      (tasks:lock-runs     dbstruct task))
;; 	  ;; ((monitor)   (tasks:start-monitor db task))
;; 	  #;((rollup)    (tasks:rollup-runs   dbstruct task))
;; 	  ((updatemeta)(tasks:update-meta   dbstruct task))
;; 	  #;((kill)      (tasks:kill-monitors dbstruct task))))))

(define (tasks:tasks->text tasks)
  (let ((fmtstr "~10a~10a~10a~12a~20a~12a~12a~10a"))
    (conc (format #f fmtstr "id" "action" "owner" "state" "target" "runname" "testpatts" "params") "\n"
	  (string-intersperse 
	   (map (lambda (task)
		  (format #f fmtstr
			  (tasks:task-get-id     task)
			  (tasks:task-get-action task)
			  (tasks:task-get-owner  task)
			  (tasks:task-get-state  task)
			  (tasks:task-get-target task)
			  (tasks:task-get-name   task)
			  (tasks:task-get-testpatt task)
			  ;; (tasks:task-get-item   task)
			  (tasks:task-get-params task)))
		tasks) "\n"))))
   
(define (tasks:set-state dbstruct task-id state)
  (db:with-db 
   dbstruct #f #t
   (lambda (dbdat db)
     (sqlite3:execute db "UPDATE tasks_queue SET state=? WHERE id=?;" 
		      state 
		      task-id))))

;;======================================================================
;; Access using task key (stored in params; (hash-table->alist flags) hostname pid
;;======================================================================

(define (tasks:param-key->id dbstruct task-params)
  (db:with-db
   dbstruct #f #f
   (lambda (dbdat db)
     (handle-exceptions
      exn
      #f
      (sqlite3:first-result db "SELECT id FROM tasks_queue WHERE params LIKE ?;"
			    task-params)))))

(define (tasks:get-records-given-param-key dbstruct param-key state-patt action-patt test-patt)
  (db:with-db
   dbstruct #f #f
   (lambda (dbdat db)
     (handle-exceptions
      exn
      '()
      (sqlite3:first-row db "SELECT id,action,owner,state,target,name,testpatt,keylock,params WHERE
                               params LIKE ? AND state LIKE ? AND action LIKE ? AND testpatt LIKE ?;"
			 param-key state-patt action-patt test-patt)))))

;; kill any runner processes (i.e. processes handling -runtests) that match target/runname
;; 
;; do a remote call to get the task queue info but do the killing as self here.
;;
(define (tasks:kill-runner target run-name testpatt)
  (let ((records    (rmt:tasks-find-task-queue-records target run-name testpatt "running" "run-tests"))
	(hostpid-rx (regexp "\\s+(\\w+)\\s+(\\d+)$"))) ;; host pid is at end of param string
    (if (null? records)
	(debug:print 0 *default-log-port* "No run launching processes found for " target " / " run-name " with testpatt " (or testpatt "* no testpatt specified! *"))
	(debug:print 0 *default-log-port* "Found " (length records) " run(s) to kill."))
    (for-each 
     (lambda (record)
       (let* ((param-key (list-ref record 8))
	      (match-dat (string-search hostpid-rx param-key)))
	 (if match-dat
	     (let ((hostname  (cadr match-dat))
		   (pid       (string->number (caddr match-dat))))
	       (debug:print 0 *default-log-port* "Sending SIGINT to process " pid " on host " hostname)
	       (if (equal? (get-host-name) hostname)
		   (if (process:alive? pid)
		       (begin
			 (handle-exceptions
			  exn
			  (begin
			    (debug:print 0 *default-log-port* "Kill of process " pid " on host " hostname " failed.")
			    (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
			    #t)
			  (process-signal pid signal/int)
			  (thread-sleep! 5)
			  (if (process:alive? pid)
			      (process-signal pid signal/kill)))))
		   ;;  (call-with-environment-variables
		   (let ((old-targethost (getenv "TARGETHOST")))
		     (setenv "TARGETHOST" hostname)
		     (setenv "TARGETHOST_LOGF" "server-kills.log")
		     (system (conc "nbfake kill " pid))
		     (if old-targethost (setenv "TARGETHOST" old-targethost))
		     (unsetenv "TARGETHOST")
		     (unsetenv "TARGETHOST_LOGF"))))
	     (debug:print-error 0 *default-log-port* "no record or improper record for " target "/" run-name " in tasks_queue in main.db"))))
     records)))

;; (define (tasks:start-run dbstruct mdb task)
;;   (let ((flags (make-hash-table)))
;;     (hash-table-set! flags "-rerun" "NOT_STARTED")
;;     (if (not (string=? (tasks:task-get-params task) ""))
;; 	(hash-table-set! flags "-setvars" (tasks:task-get-params task)))
;;     (print "Starting run " task)
;;     ;; sillyness, just call the damn routine with the task vector and be done with it. FIXME SOMEDAY
;;     (runs:run-tests db
;; 		    (tasks:task-get-target task)
;; 		    (tasks:task-get-name   task)
;; 		    (tasks:task-get-test   task)
;; 		    (tasks:task-get-item   task)
;; 		    (tasks:task-get-owner  task)
;; 		    flags)
;;     (tasks:set-state mdb (tasks:task-get-id task) "waiting")))
;; 
;; (define (tasks:rollup-runs db mdb task)
;;   (let* ((flags (make-hash-table)) 
;; 	 (keys  (db:get-keys db))
;; 	 (keyvals (keys:target-keyval keys (tasks:task-get-target task))))
;;     ;; (hash-table-set! flags "-rerun" "NOT_STARTED")
;;     (print "Starting rollup " task)
;;     ;; sillyness, just call the damn routine with the task vector and be done with it. FIXME SOMEDAY
;;     (runs:rollup-run db
;; 		     keys 
;; 		     keyvals
;; 		     (tasks:task-get-name  task)
;; 		     (tasks:task-get-owner  task))
;;     (tasks:set-state mdb (tasks:task-get-id task) "waiting")))

;;======================================================================
;;  S Y N C   T O   P O S T G R E S Q L
;;======================================================================

;; In the spirit of "dump your junk in the tasks module" I'll put the
;; sync to postgres here for now.

;; attempt to automatically set up an area. call only if get area by path
;; returns naught of interest
;;
(define (tasks:set-area dbh configdat #!key (toppath #f)) ;; could I safely put *toppath* in for the default for toppath? when would it be evaluated?
  (let loop ((area-name (or (configf:lookup configdat "setup" "area-name")
			    (common:get-area-name)))
	     (modifier  'none))
    (let ((success (handle-exceptions
		       exn
		       (begin
			 (debug:print 0 *default-log-port* "ERROR: cannot create area entry, " ((condition-property-accessor 'exn 'message) exn))
			 #f) ;; FIXME: I don't care for now but I should look at *why* there was an exception
		     (pgdb:add-area dbh area-name (or toppath *toppath*)))))
      (or success
	  (case modifier
	    ((none)(loop (conc (current-user-name) "_" area-name) 'user))
	    ((user)(loop (conc (substring (common:get-area-path-signature) 0 4)
			       area-name) 'areasig))
	    (else #f)))))) ;; give up

(define (task:print-runtime run-times saperator)
(for-each
    (lambda (run-time-info)
     (let* ((run-name  (vector-ref run-time-info 0))
            (run-time  (vector-ref run-time-info 1))
            (target  (vector-ref run-time-info 2)))
        (print target saperator run-name saperator run-time )))
   run-times))

(define (task:print-runtime-as-json run-times)
 (let loop ((run-time-info (car run-times))
            (rema (cdr run-times)) 
            (str ""))
     (let* ((run-name  (vector-ref run-time-info 0))
            (run-time  (vector-ref run-time-info 1))
            (target  (vector-ref run-time-info 2)))
        ;(print (not (equal? str "")))
        (if (not (equal? str "")) 
            (set! str (conc str ",")))
        (if (null? rema)
		(print "[" str "{target:" target ",run-name:" run-name ", run-time:" run-time "}]")
            (loop (car rema) (cdr rema) (conc str "{target:" target ", run-name:" run-name ", run-time:" run-time "}"))))))

(define (task:get-run-times)
   (let* ( 
           (run-patt (if (args:get-arg "-run-patt")
                        (args:get-arg "-run-patt")
                        "%"))
           (target-patt (if (args:get-arg "-target-patt")
                        (args:get-arg "-target-patt")
                        "%"))
 
           (run-times  (rmt:get-run-times  run-patt target-patt )))
   (if (eq? (length run-times) 0)
     (begin
       (debug:print 0 *default-log-port* "Data not found!!")
       (exit)))
   (if (equal? (args:get-arg "-dumpmode") "json")
       (task:print-runtime-as-json run-times)
         (if (equal? (args:get-arg "-dumpmode") "csv")
	     (task:print-runtime run-times ",")
	     (task:print-runtime run-times "  ")))))


(define (task:print-testtime test-times saperator)
(for-each
    (lambda (test-time-info)
     (let* ((test-name  (vector-ref test-time-info 0))
            (test-time  (vector-ref test-time-info 2))
            (test-item  (if (eq? (string-length (vector-ref test-time-info 1)) 0)
                               "N/A"
				(vector-ref test-time-info 1))))
        (print  test-name saperator test-item saperator test-time )))
   test-times))

(define (task:print-testtime-as-json test-times)
 (let loop ((test-time-info (car test-times))
            (rema (cdr test-times)) 
            (str ""))
     (let* ((test-name  (vector-ref test-time-info 0))
            (test-time  (vector-ref test-time-info 2))
            (item  (vector-ref test-time-info 1)))
        ;(print (not (equal? str "")))
        (if (not (equal? str "")) 
            (set! str (conc str ",")))
        (if (null? rema)
		(print "[" str "{test-name:" test-name ", item-path:" item ", test-time:" test-time "}]")
            (loop (car rema) (cdr rema) (conc str "{test-name:" test-name ", item-path:" item ", test-time:" test-time "}"))))))


 (define (task:get-test-times)
   (let* ((runname (if (args:get-arg "-runname")
                        (args:get-arg "-runname")
                        #f))
           (target (if (args:get-arg "-target")
                        (args:get-arg "-target")
                        #f))
 
           (test-times  (rmt:get-test-times  runname target )))
   (if (not runname)
      (begin
      (debug:print 0 *default-log-port* "Error: Missing argument -runname")
      (exit))) 
    (if (string-contains runname "%")
      (begin
      (debug:print 0 *default-log-port* "Error: Invalid runname, '%' not allowed  (" runname ") ")
      (exit)))
    (if (not target)
      (begin
      (debug:print 0 *default-log-port* "Error: Missing argument -target")
      (exit)))
     (if  (string-contains target "%")
      (begin
      (debug:print 0 *default-log-port* "Error: Invalid target, '%' not allowed  (" target ") ")
      (exit)))
 
   (if (eq? (length test-times) 0)
     (begin
       (debug:print 0 *default-log-port* "Data not found!!")
       (exit)))
   (if (equal? (args:get-arg "-dumpmode") "json")
       (task:print-testtime-as-json test-times)
         (if (equal? (args:get-arg "-dumpmode") "csv")
	     (task:print-testtime test-times ",")
	     (task:print-testtime test-times "  ")))))



;; gets mtpg-run-id and syncs the record if different
;;
(define (tasks:run-id->mtpg-run-id dbh cached-info run-id area-info smallest-last-update-time)
  (let* ((runs-ht (hash-table-ref cached-info 'runs))
	 (runinf  (hash-table-ref/default runs-ht run-id #f))
         (area-id (vector-ref area-info 0)))
       (if runinf
	runinf ;; already cached
	(let* ((run-dat    (rmt:get-run-info run-id))               ;; NOTE: get-run-info returns a vector < row header >
	       (run-name   (rmt:get-run-name-from-id run-id))
	       (row        (db:get-rows run-dat))                   ;; yes, this returns a single row
	       (header     (db:get-header run-dat))
	       (state      (db:get-value-by-header row header "state"))
	       (status     (db:get-value-by-header row header "status"))
	       (owner      (db:get-value-by-header row header "owner"))
	       (event-time (db:get-value-by-header row header "event_time"))
	       (comment    (db:get-value-by-header row header "comment"))
	       (fail-count (db:get-value-by-header row header "fail_count"))
	       (pass-count (db:get-value-by-header row header "pass_count"))
               (db-contour (db:get-value-by-header row header "contour"))
	       (contour    (if (args:get-arg "-prepend-contour") 
                                 (if (and db-contour (not (equal? db-contour ""))  (string? db-contour )) 
                                           (begin 
                                            (debug:print-info 10 *default-log-port*  "db-contour" db-contour) 
 						db-contour)
					    (args:get-arg "-contour"))))
               (run-tag (if (args:get-arg "-run-tag")
                            (args:get-arg "-run-tag")
									""))
               (last-update (db:get-value-by-header row header "last_update"))
	       (keytarg    (if (or (args:get-arg "-prepend-contour") (args:get-arg "-prefix-target"))
	       			(conc "MT_CONTOUR/MT_AREA/" (string-intersperse (rmt:get-keys) "/")) (string-intersperse (rmt:get-keys) "/"))) ;; e.g. version/iteration/platform
               (base-target      (rmt:get-target run-id))
	       (target     (if (or (args:get-arg "-prepend-contour") (args:get-arg "-prefix-target")) 
	       			(conc (or (args:get-arg "-prefix-target") (conc contour "/" (common:get-area-name) "/")) base-target) base-target))                 ;; e.g. v1.63/a3e1/ubuntu
	       (spec-id    (pgdb:get-ttype dbh keytarg))
	       (publish-time (if (args:get-arg "-cp-eventtime-to-publishtime")
                            event-time
                           (current-seconds))) 
	       (new-run-id (if (and run-name base-target) (pgdb:get-run-id dbh spec-id target run-name area-id) #f)))
         (if new-run-id
	         (begin ;; let ((run-record (pgdb:get-run-info dbh new-run-id))
		        (hash-table-set! runs-ht run-id new-run-id)
		;; ensure key fields are up to date
     ;; if last_update == pgdb_last_update do not update smallest-last-update-time  
    (let* ((pgdb-last-update (pgdb:get-run-last-update dbh new-run-id))
           (smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" #f)))
     (if (and  (> last-update pgdb-last-update) (or (not smallest-time) (< last-update smallest-time)))
        (hash-table-set! smallest-last-update-time "smallest-time" last-update)))
		(pgdb:refresh-run-info
		 dbh
		 new-run-id
		 state status owner event-time comment fail-count pass-count area-id last-update publish-time)
     (debug:print-info 4 *default-log-port* (conc "Working on run-id " run-id " pgdb-id "  new-run-id))
     (if (not (equal? run-tag ""))
      (task:add-run-tag dbh new-run-id run-tag))
		new-run-id) 
      
	      (if (or (not state) (equal? state "deleted"))
          (begin 
          (debug:print-info 1 *default-log-port*  "Warning: Run with id " run-id " was created after previous sync and deleted before the sync") #f)
          (if (handle-exceptions
		        exn
		        (begin (print-call-chain)
              (debug:print 0 *default-log-port* ((condition-property-accessor 'exn 'message) exn))     
			      #f)
            
            (pgdb:insert-run
		     dbh
		     spec-id target run-name state status owner event-time comment fail-count pass-count  area-id last-update publish-time))
		       (let* ((smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" #f)))
             (if (or (not smallest-time) (< last-update smallest-time))
        				(hash-table-set! smallest-last-update-time "smallest-time" last-update))
             (tasks:run-id->mtpg-run-id dbh cached-info run-id area-info smallest-last-update-time))
		  #f)))))))

(define (task:add-run-tag dbh run-id tag) 
  (let* ((tag-info (pgdb:get-tag-info-by-name dbh tag)))
   (if (not tag-info)
     (begin   
     (if (handle-exceptions
	   exn
	   (begin 
               (debug:print-info 1 *default-log-port*  ((condition-property-accessor 'exn 'message) exn))     
	   #f)
	   (pgdb:insert-tag  dbh   tag))
                       (set! tag-info (pgdb:get-tag-info-by-name dbh tag))
		  #f)))
     ;;add to area_tags
     (handle-exceptions
	   exn
	   (begin 
               (debug:print-info 1 *default-log-port*  ((condition-property-accessor 'exn 'message) exn))     
	   #f)
           (if (not (pgdb:is-run-taged-with-a-tag dbh (vector-ref tag-info 0)  run-id))  
	   (pgdb:insert-run-tag  dbh   (vector-ref tag-info 0)  run-id)))))


(define (tasks:sync-test-steps dbh cached-info test-step-ids smallest-last-update-time)
 ; (print "Sync Steps " test-step-ids )
  (let ((test-ht (hash-table-ref cached-info 'tests))
        (step-ht (hash-table-ref cached-info 'steps))
        (run-id-in #f)
        )
    (for-each
     (lambda (test-step-id)
        (set! run-id-in (cdr test-step-id))
        (set! test-step-id (car test-step-id))
 

        (let* ((test-step-info  (rmt:get-steps-info-by-id run-id-in test-step-id))
               (step-id (tdb:step-get-id test-step-info))
               (test-id  (tdb:step-get-test_id    test-step-info))   
	       (stepname (tdb:step-get-stepname  test-step-info))
	       (state (tdb:step-get-state test-step-info))	
	       (status (tdb:step-get-status test-step-info))	
	       (event_time (tdb:step-get-event_time  test-step-info))	
	       (comment  (tdb:step-get-comment test-step-info))	
	       (logfile (tdb:step-get-logfile test-step-info))	
         (last-update (tdb:step-get-last_update test-step-info))
	       (pgdb-test-id  (hash-table-ref/default test-ht test-id #f))
				 (smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" #f))
         (pgdb-step-id (if pgdb-test-id 
                         (pgdb:get-test-step-id dbh pgdb-test-id stepname state)
                          #f)))
    (if step-id
      (begin  
        (if pgdb-test-id
           (begin 
                (if  pgdb-step-id
                   (begin
                    (debug:print-info 4 *default-log-port*  "Updating existing test-step with test-id: " test-id " and step-id " step-id " pgdb test id: " pgdb-test-id " pgdb step id " pgdb-step-id )
										(let* ((pgdb-last-update (pgdb:get-test-step-last-update dbh pgdb-step-id)))
         (if (and  (> last-update pgdb-last-update) (or (not smallest-time) (< last-update smallest-time)))
        (hash-table-set! smallest-last-update-time "smallest-time" last-update))) 
                    (pgdb:update-test-step dbh pgdb-step-id pgdb-test-id stepname state status event_time comment logfile last-update))
                    (begin
 		      (debug:print-info 4 *default-log-port*  "Inserting test-step with test-id: " test-id " and step-id " step-id  " pgdb test id: " pgdb-test-id)
                     (if (or (not smallest-time) (< last-update smallest-time))
        				      (hash-table-set! smallest-last-update-time "smallest-time" last-update))
                      (pgdb:insert-test-step dbh pgdb-test-id stepname state status event_time comment logfile last-update )
                      (set! pgdb-step-id  (pgdb:get-test-step-id dbh pgdb-test-id stepname state))))
                (hash-table-set! step-ht step-id pgdb-step-id ))
           (debug:print-info 1 *default-log-port*  "Error: Test not cashed")))
      (debug:print-info 1 *default-log-port*  "Error: Could not get test step info for step id " test-step-id ))))	;; this is a wierd senario need to debug      	
   test-step-ids)))

(define (tasks:sync-test-gen-data dbh cached-info test-data-ids smallest-last-update-time)
  (let ((test-ht (hash-table-ref cached-info 'tests))
        (data-ht (hash-table-ref cached-info 'data))
        (run-id-in #f)
        )
    (for-each
     (lambda (test-data-id)
        (set! run-id-in (cdr test-data-id))
        (set! test-data-id (car test-data-id))
        (let* ((test-data-info  (rmt:get-data-info-by-id run-id-in test-data-id))
               (data-id (db:test-data-get-id  test-data-info))
               (test-id  (db:test-data-get-test_id   test-data-info))   
	       (category  (db:test-data-get-category  test-data-info))
	       (variable  (db:test-data-get-variable test-data-info))	
	       (value (db:test-data-get-value  test-data-info))	
               (expected (db:test-data-get-expected  test-data-info))
               (tol (db:test-data-get-tol  test-data-info))
               (units (db:test-data-get-units  test-data-info))     
	       (comment  (db:test-data-get-comment test-data-info))	
               (status (db:test-data-get-status test-data-info))	
	       (type (db:test-data-get-type test-data-info))
				 (last-update (db:test-data-get-last_update test-data-info))
				 (smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" #f))
   	
	       (pgdb-test-id  (hash-table-ref/default test-ht test-id #f))
               (pgdb-data-id (if pgdb-test-id 
                                 (pgdb:get-test-data-id dbh pgdb-test-id category variable)
                                  #f)))
    (if data-id
      (begin
        (if pgdb-test-id
           (begin 
                (if  pgdb-data-id
                   (begin
                    (debug:print-info 4 *default-log-port*  "Updating existing test-data with test-id: " test-id " and  data-id " data-id " pgdb test id: " pgdb-test-id " pgdb data id " pgdb-data-id)
                    (let* ((pgdb-last-update (pgdb:get-test-data-last-update dbh pgdb-data-id)))
         (if (and  (>  last-update pgdb-last-update) (or (not smallest-time) (< last-update smallest-time)))
        (hash-table-set! smallest-last-update-time "smallest-time" last-update))) 
                    (pgdb:update-test-data dbh pgdb-data-id pgdb-test-id  category variable value expected tol units comment status type last-update))
                    (begin
 		      (debug:print-info 4 *default-log-port*  "Inserting test-data with test-id: " test-id " and data-id " data-id " pgdb test id: " pgdb-test-id)
                       (if (handle-exceptions
		      exn
		      (begin (print-call-chain)
                              (debug:print 0 *default-log-port* ((condition-property-accessor 'exn 'message) exn))     
			#f)
                     
                    (pgdb:insert-test-data dbh pgdb-test-id category variable value expected tol units comment status type last-update))
		       ;(tasks:run-id->mtpg-run-id dbh cached-info run-id area-info)
                      (begin
                      ;(pgdb:insert-test-data dbh pgdb-test-id category variable value expected tol units comment status type )
											(if (or (not smallest-time) (< last-update smallest-time))
        								(hash-table-set! smallest-last-update-time "smallest-time" last-update))
                      (set! pgdb-data-id  (pgdb:get-test-data-id dbh pgdb-test-id  category variable)))
		   #f)))
                (hash-table-set! data-ht data-id pgdb-data-id ))
             (begin
                 (debug:print-info 1 *default-log-port*  "Error: Test not in pgdb"))))

      (debug:print-info 1 *default-log-port*  "Error: Could not get test data info for data id " test-data-id ))))	;; this is a wierd senario need to debug      	
   test-data-ids)))



(define (tasks:sync-tests-data dbh cached-info test-ids area-info smallest-last-update-time main-run-id)
  (let ((test-ht (hash-table-ref cached-info 'tests))
        (run-id-in main-run-id))
    (for-each
     (lambda (test-id)
       ; (set! run-id-in  (cdr test-id))
       ; (set! test-id (car test-id))

        (debug:print 0 *default-log-port*  "test-id: " test-id " run-id: " run-id-in) 
       (let* ((test-info    (rmt:get-test-info-by-id run-id-in test-id))
	      (run-id       (db:test-get-run_id    test-info)) ;; look these up in db_records.scm
	      (test-id      (db:test-get-id        test-info))
	      (test-name    (db:test-get-testname  test-info))
	      (item-path    (db:test-get-item-path test-info))
	      (state        (db:test-get-state     test-info))
	      (status       (db:test-get-status    test-info))
	      (host         (db:test-get-host      test-info))
        (pid          (db:test-get-process_id test-info)) 
	      (cpuload      (db:test-get-cpuload   test-info))
	      (diskfree     (db:test-get-diskfree  test-info))
	      (uname        (db:test-get-uname     test-info))
	      (run-dir      (db:test-get-rundir    test-info))
	      (log-file     (db:test-get-final_logf test-info))
	      (run-duration (db:test-get-run_duration test-info))
	      (comment      (db:test-get-comment   test-info))
	      (event-time   (db:test-get-event_time test-info))
	      (archived     (db:test-get-archived  test-info))
        (last-update  (db:test-get-last_update  test-info))
	      (pgdb-run-id  (tasks:run-id->mtpg-run-id dbh cached-info run-id area-info smallest-last-update-time))
        (smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" #f))       
	      (pgdb-test-id (if pgdb-run-id 
				(begin
                                  ;(print pgdb-run-id)    
                                 (pgdb:get-test-id dbh pgdb-run-id test-name item-path))
                                 #f)))
	 ;; "id"           "run_id"        "testname"  "state"      "status"      "event_time"
	 ;; "host"         "cpuload"       "diskfree"  "uname"      "rundir"      "item_path"
	 ;; "run_duration" "final_logf"    "comment"   "shortdir"   "attemptnum"  "archived"
         (if (or (not item-path) (string-null? item-path))
             (debug:print-info 0 *default-log-port* "Working on Run id : " run-id " and test name : " test-name)) 
         (if pgdb-run-id
           (begin
	   (if pgdb-test-id ;; have a record
	     (begin ;; let ((key-name (conc run-id "/" test-name "/" item-path)))
	       (debug:print-info 4 *default-log-port*  "Updating existing test with run-id: " run-id " and test-id: " test-id " pgdb run id: " pgdb-run-id "  pgdb-test-id "  pgdb-test-id)
         (let* ((pgdb-last-update (pgdb:get-test-last-update dbh pgdb-test-id)))
         (if (and  (>  last-update pgdb-last-update) (or (not smallest-time) (< last-update smallest-time))) ;;if last-update is same as pgdb-last-update then it is safe to assume the records are identical and we can use a larger last update time.
        (hash-table-set! smallest-last-update-time "smallest-time" last-update))) 
	       (pgdb:update-test dbh pgdb-test-id pgdb-run-id test-name item-path state status host cpuload diskfree uname run-dir log-file run-duration comment event-time archived last-update pid))
	     (begin 
           (debug:print-info 4 *default-log-port*  "Inserting test with run-id: " run-id " and test-id: " test-id  " pgdb run id: " pgdb-run-id)
           (pgdb:insert-test dbh pgdb-run-id test-name item-path state status host cpuload diskfree uname run-dir log-file run-duration comment event-time archived last-update pid)
            (if (or (not smallest-time) (< last-update smallest-time))
        				(hash-table-set! smallest-last-update-time "smallest-time" last-update))
           (set! pgdb-test-id (pgdb:get-test-id dbh pgdb-run-id test-name item-path))))
           (hash-table-set! test-ht test-id pgdb-test-id))
           (debug:print-info 1 *default-log-port*  "WARNING: Skipping run with run-id:" run-id ". This run was created after privious sync and removed before this sync."))))
     test-ids)))

(define (task:add-area-tag dbh area-info tag) 
  (let* ((tag-info (pgdb:get-tag-info-by-name dbh tag)))
   (if (not tag-info)
     (begin   
     (if (handle-exceptions
	   exn
	   (begin 
               (debug:print-info 1 *default-log-port*  ((condition-property-accessor 'exn 'message) exn))     
	   #f)
	   (pgdb:insert-tag  dbh   tag))
                       (set! tag-info (pgdb:get-tag-info-by-name dbh tag))
		  #f)))
     ;;add to area_tags
     (handle-exceptions
	   exn
	   (begin 
               (debug:print-info 1 *default-log-port*  ((condition-property-accessor 'exn 'message) exn))     
	   #f)
           (if (not (pgdb:is-area-taged-with-a-tag dbh (vector-ref tag-info 0)  (vector-ref area-info 0)))  
	   (pgdb:insert-area-tag  dbh   (vector-ref tag-info 0)  (vector-ref area-info 0))))))

(define (tasks:sync-run-data dbh cached-info run-ids area-info smallest-last-update-time) 
  (for-each
     (lambda (run-id)
      (debug:print-info 4 *default-log-port*   "Check if run with " run-id " needs to be synced" )
       (tasks:run-id->mtpg-run-id dbh cached-info run-id area-info smallest-last-update-time))
run-ids))

;; get runs changed since last sync
;; (define (tasks:sync-test-data dbh cached-info area-info)
;;   (let* ((

(define (tasks:sync-to-postgres configdat dest)
  ;; (print "In sync")
  (let* ((dbh         (pgdb:open configdat dbname: dest))
	 (area-info   (pgdb:get-area-by-path dbh *toppath*))
	 (cached-info (make-hash-table))
	 (start       (current-seconds))
         (test-patt   (if (args:get-arg "-testpatt")
		      (args:get-arg "-testpatt")
                      "%"))
         (target      (if (args:get-arg "-target")
		      (args:get-arg "-target")
		      #f))
         (run-name   (if (args:get-arg "-runname")
		     (args:get-arg "-runname")
		     #f)))
     (if (and target  (not run-name))
       (begin
	  (debug:print 0 *default-log-port* "Error: Provide runname")
          (exit 1)))
     (if (and (not target)  run-name)
       (begin
	  (debug:print 0 *default-log-port* "Error: Provide target")
          (exit 1)))
    ;(print "123")
    ;(exit 1)
    (for-each (lambda (dtype)
		(hash-table-set! cached-info dtype (make-hash-table)))
	      '(runs targets tests steps data))
    (hash-table-set! cached-info 'start start) ;; when done we'll set sync times to this
    (if area-info
	(let* ((last-sync-time (if (and target run-name)
                                 0
                                 (if (args:get-arg "-since") 
                                   (string->number (args:get-arg "-since")) (vector-ref area-info 3))))
	       (smallest-last-update-time  (make-hash-table))
               (run-ids       (if (and target run-name)
                                   (rmt:get-run-record-ids target run-name (rmt:get-keys)) 
                                   (rmt:get-changed-record-run-ids last-sync-time)))
               (all-run-ids   (if (and target run-name) '() (rmt:get-all-runids)))
               (changed-run-dbs (if (and target run-name) '() (db:get-changed-run-ids last-sync-time)))
               (changed-run-ids (if (and target run-name) run-ids (filter (lambda (run) (member (modulo run (num-run-dbs)) changed-run-dbs)) all-run-ids)))
               (area-tag    (if (args:get-arg "-area-tag") 
                                 (args:get-arg "-area-tag")
                                 (if (args:get-arg "-area") 
                                   (args:get-arg "-area") 
                                   ""))))
           (if (and (equal? area-tag "") (not (pgdb:is-area-taged dbh (vector-ref area-info 0))))
            (set! area-tag *default-area-tag*)) 
           (if (not (equal? area-tag "")) 
             (task:add-area-tag dbh area-info area-tag))
           (if (not (null? run-ids))
            (begin
               (debug:print-info 0 *default-log-port*  "syncing runs: " run-ids)   
	       (tasks:sync-run-data dbh cached-info run-ids area-info smallest-last-update-time)))
          (for-each
            (lambda (run-id)
              (let ((test-ids (rmt:get-changed-record-test-ids run-id  last-sync-time)))
              (print test-ids)
              (if (not (null? test-ids))
              (begin
                (debug:print-info 0 *default-log-port*  "syncing tests: " test-ids)
	        (tasks:sync-tests-data dbh cached-info test-ids area-info smallest-last-update-time run-id)))))
            changed-run-ids)
     (let*  ((smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" (current-seconds))))
     (debug:print-info 0 "smallest-time :" smallest-time  " last-sync-time " last-sync-time)
    (if (not (and target run-name)) 
	  (if (or (and smallest-time (> smallest-time last-sync-time)) (and smallest-time (eq? last-sync-time 0)))
				(pgdb:write-sync-time dbh area-info smallest-time))))) ;;this needs to be changed
	(if (tasks:set-area dbh configdat)
	    (tasks:sync-to-postgres configdat dest)
	    (begin
	      (debug:print 0 *default-log-port* "ERROR: unable to create an area record")
	      #f)))))


	
)

(declare (unit tcp-transportmod))
(declare (uses debugprint))
(declare (uses commonmod))
(declare (uses dbfile))
(declare (uses dbmod))
(declare (uses portlogger))
(declare (uses mtmod))

(use address-info tcp)

(module tcp-transportmod
	*
	
(import scheme)

	  typed-records
	  tcp-server
	  
	  debugprint
	  commonmod
	  dbfile
	  dbmod
	  mtmod
	  portlogger
	)

;;======================================================================
;; client
;;======================================================================