Megatest

(declare (uses tasks))

;; allow these queries through without starting a server
;;
(define api:read-only-queries
  '(get-key-val-pairs
    get-keys
    get-key-vals
    test-toplevel-num-items
    get-test-info-by-id
    test-get-rundir-from-test-id
    get-count-tests-running-for-testname
    get-count-tests-running
    get-count-tests-running-in-jobgroup
    get-previous-test-run-record
    get-matching-previous-test-run-records
    test-get-logfile-info
    test-get-records-for-index-file
    get-testinfo-state-status
    test-get-top-process-pid
    test-get-paths-matching-keynames-target-new
    get-prereqs-not-met
    get-count-tests-running-for-run-id
    get-run-info
    get-run-status
    get-run-stats
    get-targets
    get-target
    ;; register-run
    get-tests-for-run
    get-test-id
    get-tests-for-runs-mindata
    get-run-name-from-id
    get-runs
    get-num-runs
    get-all-run-ids
    get-prev-run-ids
    get-run-ids-matching-target
    get-runs-by-patt
    get-steps-data
    get-steps-for-test
    read-test-data
    login
    tasks-get-last
    testmeta-get-record
    have-incompletes?
    synchash-get
    ))

(define api:write-queries
  '(

;;======================================================================
;; C L I E N T S
;;======================================================================

(require-extension (srfi 18) extras tcp s11n)

(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest)
;; (use zmq)

(use (prefix sqlite3 sqlite3:))

(use spiffy uri-common intarweb http-client spiffy-request-vars uri-common intarweb directory-utils)

(declare (unit client))

(declare (uses common))
(declare (uses db))

    ((rpc)  (rpc:client-connect  iface port))
    ((http) (http:client-connect iface port))
    ((zmq)  (zmq:client-connect  iface port))
    (else   (rpc:client-connect  iface port))))

(define (client:setup  run-id #!key (remaining-tries 10) (failed-connects 0))
  (case (server:get-transport)
    ((rpc) (rpc-transport:client-setup run-id remaining-tries: remaining-tries failed-connects: failed-connects)) ;;(client:setup-rpc run-id))
    ((http)(client:setup-http run-id remaining-tries: remaining-tries failed-connects: failed-connects))
    (else  (rpc-transport:client-setup run-id remaining-tries: remaining-tries failed-connects: failed-connects)))) ;; (client:setup-rpc run-id))))

;; (define (client:login-no-auto-setup server-info run-id)
;;   (case (server:get-transport)
;;     ((rpc)  (rpc:login-no-auto-client-setup server-info run-id))
;;     ((http) (rmt:login-no-auto-client-setup server-info run-id))
;;     (else   (rpc:login-no-auto-client-setup server-info run-id))))
;; 

;;======================================================================
;; Copyright 2006-2012, Matthew Welland.
;; 
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;; 
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.
;;======================================================================

(use srfi-1 posix regex-case base64 format dot-locking csv-xml z3 sql-de-lite hostinfo md5 message-digest typed-records)
(require-extension regex posix)

(require-extension (srfi 18) extras tcp rpc)

(import (prefix sqlite3 sqlite3:))
(import (prefix base64 base64:))

       (setenv key val))
      (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val)))

(define home (getenv "HOME"))
(define user (getenv "USER"))

;; GLOBAL GLETCHES

;; Common data structure for 
(defstruct cxt
  (taskdb #f))

(define *contexts* (make-hash-table)) ;; toppath => cxt

(define *db-keys* #f)

(define *configinfo*   #f)   ;; raw results from setup, includes toppath and table from megatest.config
(define *runconfigdat* #f)   ;; run configs data
(define *configdat*    #f)   ;; megatest.config data
(define *configstatus* #f)   ;; status of data; 'fulldata : all processing done, #f : no data yet, 'partialdata : partial read done
(define *toppath*      #f)

(define *testconfigs*       (make-hash-table)) ;; test-name => testconfig
(define *runconfigs*        (make-hash-table)) ;; target    => runconfig

;; This is a cache of pre-reqs met, don't re-calc in cases where called with same params less than
;; five seconds ago
(define *pre-reqs-met-cache* (make-hash-table))

;; cache of verbosity given string
;;
(define *verbosity-cache* (make-hash-table))

(define (common:clear-caches)
  (set! *target*             (make-hash-table))
  (set! *keys*               (make-hash-table))
  (set! *keyvals*            (make-hash-table))
  (set! *toptest-paths*      (make-hash-table))
  (set! *test-paths*         (make-hash-table))
  (set! *test-ids*           (make-hash-table))
  (set! *test-info*          (make-hash-table))
  (set! *run-info-cache*     (make-hash-table))
  (set! *env-vars-by-run-id* (make-hash-table))
  (set! *test-id-cache*      (make-hash-table)))

;; Generic string database
(define sdb:qry #f) ;; (make-sdb:qry)) ;;  'init #f)
;; Generic path database
(define *fdb* #f)

(define *last-launch* (current-seconds)) ;; use for throttling the launch rate. Would be better to use the db and last time of a test in LAUNCHED state.

;;======================================================================
;; V E R S I O N
;;======================================================================

(define (common:get-full-version)
  (conc megatest-version "-" megatest-fossil-hash))

  (db:multi-db-sync 
   #f ;; do all run-ids
   ;; 'new2old
   'killservers
   'dejunk
   ;; 'adj-testids
   ;; 'old2new
   'new2old
   'schema)
  (if (common:version-changed?)
      (common:set-last-run-version)))

;; Force a megatest cleanup-db if version is changed and skip-version-check not specified
;;
(define (common:exit-on-version-changed)
  (if (common:version-changed?)

;;======================================================================
;; E X I T   H A N D L I N G
;;======================================================================

(define (common:legacy-sync-recommended)
  (or (args:get-arg "-runtests")
      (args:get-arg "-run")
      (args:get-arg "-server")
      ;; (args:get-arg "-set-run-status")
      (args:get-arg "-remove-runs")
      ;; (args:get-arg "-get-run-status")
      (args:get-arg "-use-db-cache") ;; feels like a bad idea ...
      ))

(define (common:legacy-sync-required)
  (configf:lookup *configdat* "setup" "megatest-db"))

;; run-ids
;;    if #f use *db-local-sync* : or 'local-sync-flags
;;    if #t use timestamps      : or 'timestamps
(define (common:sync-to-megatest.db run-ids) 
  (let ((start-time         (current-seconds))
        (run-ids-to-process (if (list? run-ids)
                                run-ids
                                (if (or (eq? run-ids 'timestamps)(eq? run-ids #t))
                                    (db:get-changed-run-ids (let* ((mtdb-fpath (conc *toppath* "/megatest.db"))
                                                                   (mtdb-exists (file-exists? mtdb-fpath)))
                                                              (if mtdb-exists
                                                                  (file-modification-time mtdb-fpath)
                                                                  0)))
                                    (hash-table-keys *db-local-sync*)))))
    (debug:print-info 4 *default-log-port* "Processing run-ids: " run-ids-to-process)
    (for-each 
     (lambda (run-id)
       (mutex-lock! *db-multi-sync-mutex*)
       (if (or run-ids ;; if we were provided with run-ids, proceed
               (hash-table-ref/default *db-local-sync* run-id #f))
           ;; (if (> (- start-time last-write) 5) ;; every five seconds
           (begin ;; let ((sync-time (- (current-seconds) start-time)))
             (db:multi-db-sync (list run-id) 'new2old)
             (let ((sync-time (- (current-seconds) start-time)))
               (debug:print-info 3 *default-log-port* "Sync of newdb to olddb for run-id " run-id " completed in " sync-time " seconds")
               (if (common:low-noise-print 30 "sync new to old")
                   (debug:print-info 0 *default-log-port* "Sync of newdb to olddb for run-id " run-id " completed in " sync-time " seconds")))
             (hash-table-delete! *db-local-sync* run-id)))
       (mutex-unlock! *db-multi-sync-mutex*))
     run-ids-to-process)))

(define (common:watchdog)
  (thread-sleep! 0.05) ;; delay for startup
  (let ((legacy-sync (common:legacy-sync-required))
	(debug-mode  (debug:debug-mode 1))
	(last-time   (current-seconds)))
    (if (or (common:legacy-sync-recommended)
	    legacy-sync)
	(let loop ()
	  ;; sync for filesystem local db writes
	  ;;
	  (let ((start-time   (current-seconds)))
	    (common:sync-to-megatest.db 'local-sync-flags)
	    (if (and debug-mode
		     (> (- start-time last-time) 60))
		(begin
		  (set! last-time start-time)
		  (debug:print-info 4 *default-log-port* "timestamp -> " (seconds->time-string (current-seconds)) ", time since start -> " (seconds->hr-min-sec (- (current-seconds) *time-zero*))))))
	  
	  ;; keep going unless time to exit
	  ;;
	  (if (not *time-to-exit*)
	      (let delay-loop ((count 0))
		(if (and (not *time-to-exit*)
			 (< count 4)) ;; was 11, changing to 4. 
		    (begin
		      (thread-sleep! 1)
		      (delay-loop (+ count 1))))
		(loop)))
	  (if (common:low-noise-print 30)
	      (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*))))))

(define (std-exit-procedure)
  (let ((no-hurry  (if *time-to-exit* ;; hurry up
		       #f
		       (begin
			 (set! *time-to-exit* #t)
			 #t))))
    (debug:print-info 4 *default-log-port* "starting exit process, finalizing databases.")

;;     ((CHECK)            "255 100 50")
;;     ((REMOTEHOSTSTART)  "50  130 195")
;;     ((RUNNING)          "9   131 232")
;;     ((KILLREQ)          "39  82  206")
;;     ((KILLED)           "234 101 17")
;;     ((NOT_STARTED)      "240 240 240")
;;     (else               "192 192 192")))

(define (common:iup-color->rgb-hex instr)
  (string-intersperse 
   (map (lambda (x)
          (number->string x 16))
        (map string->number
             (string-split instr)))
   "/"))

(define (common:get-color-from-status status)
  (cond
   ((equal? status "PASS")    "green")
   ((equal? status "FAIL")    "red")
   ((equal? status "WARN")    "orange")
   ((equal? status "KILLED")  "orange")

     (with-output-to-port (current-error-port)
       (lambda ()
	 (print ((condition-property-accessor 'exn 'message) exn))
	 (print "Callback error in " procname)
	 (print "Full condition info:\n" (condition->list exn)))))
   (proc)))

;; this was cached based on results from profiling but it turned out the profiling
;; somehow went wrong - perhaps too many processes writing to it. Leaving the caching
;; in for now but can probably take it out later.
;;
(define (debug:calc-verbosity vstr)
  (or (hash-table-ref/default *verbosity-cache* vstr #f)
      (let ((res (cond
                  ((number? vstr) vstr)
                  ((not (string?  vstr))   1)
                  ;; ((string-match  "^\\s*$" vstr) 1)
                  (vstr           (let ((debugvals  (filter number? (map string->number (string-split vstr ",")))))
                                    (cond
                                     ((> (length debugvals) 1) debugvals)
                                     ((> (length debugvals) 0)(car debugvals))
                                     (else 1))))
                  ((args:get-arg "-v")   2)
                  ((args:get-arg "-q")    0)
                  (else                   1))))
        (hash-table-set! *verbosity-cache* vstr res)
        res)))

;; check verbosity, #t is ok
(define (debug:check-verbosity verbosity vstr)
  (if (not (or (number? verbosity)
	       (list?   verbosity)))
      (begin
	(print "ERROR: Invalid debug value \"" vstr "\"")

(use format fmt)
(require-library iup)
(import (prefix iup iup:))

(use canvas-draw)

(use srfi-1 posix regex regex-case srfi-69)
(use (prefix sqlite3 sqlite3:))

(declare (unit dashboard-tests))
(declare (uses common))
(declare (uses db))
(declare (uses gutils))
(declare (uses rmt))
(declare (uses ezsteps))

						       					   item-path))
						      ";megatest -target " keystring " -runname " runname 
						      " -run -preclean -testpatt " (conc testname "/" (if (equal? item-path "")
											   "%" 
											   item-path))
						      " -clean-cache"
						      )))
                                       (thread-start! (make-thread (lambda ()


                                                                     (common:run-a-command cmd))
                                                                   "clean-run-execute")))))
	       (remove-test (lambda (x)
			      (iup:attribute-set!
			       command-text-box "VALUE"
			       (conc "megatest -remove-runs -target " keystring " -runname " runname
				     " -testpatt " (conc testname "/" (if (equal? item-path "")
									  "%"
									  item-path))

  version " megatest-version "
  license GPL, Copyright (C) Matt Welland 2012-2016

Usage: dashboard [options]
  -h                    : this help
  -test run-id,test-id  : control test identified by testid
  -skip-version-check   : skip the version check
  -use-db-cache         : access database via cache 

Misc
  -rows R         : set number of rows
  -cols C         : set number of columns
"))

;;   -server host:port     : connect to host:port instead of db access

			) 
		 (list  "-h"
			"-use-server"
			"-guimonitor"
			"-main"
			"-v"
			"-q"
			"-use-db-cache"
			"-skip-version-check"
			)
		 args:arg-hash
		 0))

(if (not (null? remargs))
    (begin
      (print "Unrecognised arguments: " (string-intersperse remargs " "))
      (exit)))

(if (args:get-arg "-h")
    (begin
      (print help)
      (exit)))

;; TODO: Move this inside (main)
;;
(if (not (launch:setup))
    (begin
      (print "Failed to find megatest.config, exiting") 
      (exit 1)))

;; create a watch dog to move changes from lt/.db/*.db to megatest.db
;;
(if (file-write-access? (conc *toppath* "/megatest.db"))
    (thread-start! (make-thread common:watchdog "Watchdog thread"))
    (if (not (args:get-arg "-use-db-cache"))
	(begin
	  (debug:print-info 0 *default-log-port* "Forcing db-cache mode due to read-only access to megatest.db")
	  (hash-table-set! args:arg-hash "-use-db-cache" #t))))

;; data common to all tabs goes here
;;
(defstruct dboard:commondat
  ((curr-tab-num 0) : number)
  please-update  
  tabdats

  ((searchpatts        (make-hash-table)) : hash-table)  ;;
  ((state-ignore-hash  (make-hash-table)) : hash-table)  ;; hash of  STATE => #t/#f for display control
  ((status-ignore-hash (make-hash-table)) : hash-table)  ;; hash of STATUS => #t/#f
  (target              #f)
  (test-patts          #f)

  ;; db info to file the .db files for the area
  (access-mode        (db:get-access-mode))             ;; use cached db or not
  (dbdir               #f)
  (dbfpath             #f)
  (dbkeys              #f)
  ((last-db-update     (make-hash-table)) : hash-table) ;; last db file timestamp
  (monitor-db-path     #f)                              ;; where to find monitor.db
  ro                                                    ;; is the database read-only?

  ;; tests data
  ((num-tests          10)               : number)      ;; total number of tests to show (used in the old runs display)

  ;; runs tree
  ((path-run-ids       (make-hash-table)) : hash-table) ;; path (target / runname) => id
  (runs-tree           #f)
  ((runs-tree-ht       (make-hash-table)) : hash-table) ;; track which targets added to tree (merge functionality with path-run-ids?)

  ;; tab data
  ((view-changed       #t)                : boolean)   
  ((xadj               0)                 : number)     ;; x slider number (if using canvas)
  ((yadj               0)                 : number)     ;; y slider number (if using canvas)
  ;; runs-summary tab state
  ((runs-summary-modes '((one-run . "Show One Run") (xor-two-runs . "XOR Two Runs") (xor-two-runs-hide-clean . "XOR; Hide Clean")) )   : list)

  (dboard:tabdat-dbdir-set! tabdat (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
  (dboard:tabdat-dbfpath-set! tabdat (db:dbfile-path 0))
  (dboard:tabdat-monitor-db-path-set! tabdat (conc (dboard:tabdat-dbdir tabdat) "/monitor.db"))

  ;; HACK ALERT: this is a hack, please fix.
  (dboard:tabdat-ro-set! tabdat (not (file-read-access? (dboard:tabdat-dbfpath tabdat))))
  
  (dboard:tabdat-keys-set! tabdat (db:dispatch-query (db:get-access-mode) rmt:get-keys db:get-keys))
  (dboard:tabdat-dbkeys-set! tabdat (append (dboard:tabdat-keys tabdat) (list "runname")))
  (dboard:tabdat-tot-runs-set! tabdat (db:dispatch-query (db:get-access-mode) rmt:get-num-runs db:get-num-runs "%"))
  )

;; RADT => Matrix defstruct addition
(defstruct dboard:graph-dat
    ((id           #f) : string)
    ((color        #f) : vector)
    ((flag         #t) : boolean)

;; This is roughly the same as dboard:get-tests-dat, should merge them if possible
;;
;; gets all the tests for run-id that match testnamepatt and key-vals, merges them
;;
;;    NOTE: Yes, this is used
;;
(define (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)
  (let* ((access-mode  (dboard:tabdat-access-mode tabdat))
         (num-to-get
          (let ((num-tests-from-config (configf:lookup *configdat* "setup" "num-tests-to-get")))
            (if num-tests-from-config
                (begin
                  (BB> "override num-tests 100 -> "num-tests-from-config)
                  (string->number num-tests-from-config))
                100)))
	 (states      (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat)))

	 (db-path     (or (dboard:rundat-db-path run-dat)
			  (let* ((db-dir (tasks:get-task-db-path))
				 (db-pth (conc db-dir "/" run-id ".db")))
			    (dboard:rundat-db-path-set! run-dat db-pth)
			    db-pth)))
	 (tmptests    (if (or do-not-use-db-file-timestamps
			      (>=  (common:lazy-modification-time db-path) last-update))
                          (db:dispatch-query access-mode rmt:get-tests-for-run db:get-tests-for-run
                                             run-id testnamepatt states statuses  ;; run-id testpatt states statuses
                                             (dboard:rundat-run-data-offset run-dat)
                                             num-to-get
                                             (dboard:tabdat-hide-not-hide tabdat) ;; no-in
                                             sort-by                              ;; sort-by
                                             sort-order                           ;; sort-order
                                             #f ;; 'shortlist                           ;; qrytype
                                             (if (dboard:tabdat-filters-changed tabdat) 
                                                 0
                                                 last-update) ;; last-update
                                             *dashboard-mode*) ;; use dashboard mode
			  '()))
	 (use-new    (dboard:tabdat-hide-not-hide tabdat))
	 (tests-ht   (if (dboard:tabdat-filters-changed tabdat)
			 (let ((ht (make-hash-table)))
			   (dboard:rundat-tests-set! run-dat ht)
			   ht)
			 (dboard:rundat-tests run-dat)))

;; this calls dboard:get-tests-for-run-duplicate for each run
;;
;; create a virtual table of all the tests
;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
;;
(define (update-rundat tabdat runnamepatt numruns testnamepatt keypatts)
  (let* ((access-mode      (dboard:tabdat-access-mode tabdat))
         (keys             (db:dispatch-query access-mode rmt:get-keys db:get-keys))
	 (last-runs-update (dboard:tabdat-last-runs-update tabdat))
         (allruns          (db:dispatch-query access-mode rmt:get-runs db:get-runs
                                              runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts))
         ;;(allruns-tree (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f))
         (allruns-tree    (db:dispatch-query access-mode rmt:get-runs-by-patt db:get-runs-by-patt
                                             keys "%" #f #f #f #f last-runs-update));;'("id" "runname")
	 (header      (db:get-header allruns))
	 (runs        (db:get-rows   allruns)) ;; RA => Filtered as per runpatt selected
         (runs-tree   (db:get-rows   allruns-tree)) ;; RA => Returns complete list of runs
	 (start-time  (current-seconds))
	 (runs-hash   (let ((ht (make-hash-table)))
			 (for-each (lambda (run)
				     (hash-table-set! ht (db:get-value-by-header run header "id") run))

	(let loop ((run      (car runs))
		   (tal      (cdr runs))
		   (res     '())
		   (maxtests 0))
	  (let* ((run-id       (db:get-value-by-header run header "id"))
		 (run-struct   (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f))
		 (last-update  (if run-struct (dboard:rundat-last-update run-struct) 0))
		 (key-vals     (rmt:get-key-vals run-id)) ;; (db:dispatch-query (db:get-access-mode) rmt:get-key-vals db:get-key-vals run-id))
		 (tests-ht     (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals))
		 ;; GET RID OF dboard:get-tests-dat - it is superceded by dboard:get-tests-for-run-duplicate
		 ;;  dboard:get-tests-for-run-duplicate - returns a hash table
		 ;;  (dboard:get-tests-dat tabdat run-id last-update))
		 (all-test-ids (hash-table-keys tests-ht))
		 (num-tests    (length all-test-ids)))
	    ;; (print "run-struct: " run-struct)

	      (let ((newval (car values)))
		(iup:attribute-set! lb "VALUE" newval)
		newval))))))

(define (dashboard:update-target-selector tabdat #!key (action-proc #f))
  (let* ((runconf-targs (common:get-runconfig-targets))
	 (key-lbs       (dboard:tabdat-key-listboxes tabdat))
	 (db-target-dat (db:dispatch-query (db:get-access-mode) rmt:get-targets db:get-targets))
	 (header        (vector-ref db-target-dat 0))
	 (db-targets    (vector-ref db-target-dat 1))
	 (munge-target  (lambda (x)            ;; create a target vector from a string. Pad with na if needed.
			  (list->vector
			   (take (append (string-split x "/")
					 (make-list (length header) "na"))
				 (length header)))))

    (dashboard:update-run-command tabdat)))

;; used by run-controls
;;
(define (dashboard:update-tree-selector tabdat #!key (action-proc #f))
  (let* ((tb            (dboard:tabdat-runs-tree tabdat))
	 (runconf-targs (common:get-runconfig-targets))
	 (db-target-dat (db:dispatch-query (db:get-access-mode) rmt:get-targets db:get-targets))
         (runs-tree-ht  (dboard:tabdat-runs-tree-ht tabdat))
	 (header        (vector-ref db-target-dat 0))
	 (db-targets    (vector-ref db-target-dat 1))
	 (munge-target  (lambda (x)            ;; create a target vector from a string. Pad with na if needed.
			  (take (append (string-split x "/")
					(make-list (length header) "na"))
				(length header))))
	 (all-targets   (append (list (munge-target (string-intersperse 
						     (map (lambda (x) "%") header)
						     "/")))
				(map vector->list db-targets)
				(map munge-target
				     runconf-targs)
				)))
    (for-each
     (lambda (target)
       (if (not (hash-table-ref/default runs-tree-ht target #f))
           ;; (let ((existing (tree:find-node tb target)))
           ;;   (if (not existing)
           (begin
             (tree:add-node tb "Runs" target) ;; (append key-vals (list run-name))
             (hash-table-set! runs-tree-ht target #t))))
     all-targets)))

;; Run controls panel
;;
(define (dashboard:run-controls commondat tabdat #!key (tab-num #f))
  (let* ((targets       (make-hash-table))
	 (test-records  (make-hash-table))

(define (tree-path->run-id tabdat path)
  (if (not (null? path))
      (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) path #f)
      #f))

(define (dboard:get-tests-dat tabdat run-id last-update)
  (let* ((access-mode     (dboard:tabdat-access-mode tabdat))
         (tdat (if run-id (db:dispatch-query access-mode rmt:get-tests-for-run db:get-tests-for-run
                                             run-id 
					     (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%")
					     (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat))  ;; '()
					     (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat)) ;; '()
					     #f #f                                                       ;; offset limit
					     (dboard:tabdat-hide-not-hide tabdat)                        ;; not-in
					     #f #f                                                       ;; sort-by sort-order
					     #f ;; get all? "id,testname,item_path,state,status,event_time,run_duration"                        ;; qryval

(define (dashboard:safe-cadr-assoc name lst)
  (let ((res (assoc name lst)))
    (if (and res (> (length res) 1))
	(cadr res)
	#f)))

(define (dboard:update-tree tabdat runs-hash runs-header tb)
  (let* ((access-mode   (dboard:tabdat-access-mode tabdat))
         (run-ids (sort (filter number? (hash-table-keys runs-hash))
			(lambda (a b)
			  (let* ((record-a (hash-table-ref runs-hash a))
				 (record-b (hash-table-ref runs-hash b))
				 (time-a   (db:get-value-by-header record-a runs-header "event_time"))
				 (time-b   (db:get-value-by-header record-b runs-header "event_time")))
			    (< time-a time-b)))))
         (changed      #f)
	 (last-runs-update  (dboard:tabdat-last-runs-update tabdat))
	 (runs-dat     (db:dispatch-query access-mode rmt:get-runs-by-patt db:get-runs-by-patt
                                          (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)))
    (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2))
    (for-each (lambda (run-id)
		(let* ((run-record (hash-table-ref/default runs-hash run-id #f))
		       (key-vals   (map (lambda (key)(db:get-value-by-header run-record runs-header key))
					(dboard:tabdat-keys tabdat)))
		       (run-name   (db:get-value-by-header run-record runs-header "runname"))
		       (col-name   (conc (string-intersperse key-vals "\n") "\n" run-name))
		       (run-path   (append key-vals (list run-name))))
		  (if (not (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) run-path #f))
                      ;; (let ((existing   (tree:find-node tb run-path)))
                      ;;   (if (not existing)
                      (begin
                        (hash-table-set! (dboard:tabdat-run-keys tabdat) run-id run-path)
                        ;; (iup:attribute-set! (dboard:tabdat-runs-matrix tabdat)
                        ;;    		 (conc rownum ":" colnum) col-name)
                        ;; (hash-table-set! runid-to-col run-id (list colnum run-record))
                        ;; Here we update the tests treebox and tree keys
                        (tree:add-node tb "Runs" run-path) ;; (append key-vals (list run-name))
                        ;;                                             userdata: (conc "run-id: " run-id))))
                        (hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path run-id)
                        ;; (set! colnum (+ colnum 1))
                        ))))
	      run-ids)))

(define (dashboard:tests-ht->tests-dat tests-ht)
  (reverse
   (sort
    (hash-table-values tests-ht)
    (lambda (a b) 
      (let ((a-test-name  (db:test-get-testname a))
            (a-item-path  (db:test-get-item-path a))
            (b-test-name  (db:test-get-testname b))
            (b-item-path  (db:test-get-item-path b)))
        (cond
         ((< 0 (string-compare3 a-test-name b-test-name)) #t)
         ((> 0 (string-compare3 a-test-name b-test-name)) #f)
         ((< 0 (string-compare3 a-item-path b-item-path)) #t)
         (else #f)))))))


(define (dashboard:run-id->tests-mindat run-id tabdat runs-hash)
  (let* ((run          (hash-table-ref/default runs-hash run-id #f))
         (key-vals     (rmt:get-key-vals run-id)) ;; (db:dispatch-query (db:get-access-mode) rmt:get-key-vals db:get-key-vals run-id))
         (testnamepatt (or (dboard:tabdat-test-patts tabdat) "%/%"))
         (tests-ht     (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals))
         (tests-dat    (dashboard:tests-ht->tests-dat tests-ht)) 
         (tests-mindat (dcommon:minimize-test-data tests-dat)))  ;; reduces data for display
    (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2))
    (hash-table-set! (dboard:tabdat-last-test-dat tabdat) run-id tests-dat)
    (hash-table-set! (dboard:tabdat-run-update-times tabdat) run-id (- (current-seconds) 10))

         (dashboard:run-id->tests-mindat src-run-id tabdat runs-hash)
         (dashboard:run-id->tests-mindat dest-run-id tabdat runs-hash)
         hide-clean: hide-clean)
        #f)))


(define (dashboard:get-runs-hash tabdat)
  (let* ((access-mode       (dboard:tabdat-access-mode tabdat))
         (last-runs-update  0);;(dboard:tabdat-last-runs-update tabdat))
	 (runs-dat     (db:dispatch-query access-mode rmt:get-runs-by-patt db:get-runs-by-patt 
                                          (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))
	 (runs-header  (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
         (runs         (vector-ref runs-dat 1))
	 (run-id       (dboard:tabdat-curr-run-id tabdat))
         (runs-hash    (let ((ht (make-hash-table)))
			 (for-each (lambda (run)
				     (hash-table-set! ht (db:get-value-by-header run runs-header "id") run))
				   runs) ht)))
    runs-hash))
         

(define (dashboard:runs-summary-updater commondat tabdat tb cell-lookup run-matrix)
  (if (dashboard:database-changed? commondat tabdat context-key: 'runs-summary-rundat)
      (dashboard:do-update-rundat tabdat))
  (dboard:runs-summary-control-panel-updater tabdat)
  (let* ((last-runs-update  (dboard:tabdat-last-runs-update tabdat))
	 (runs-dat     (db:dispatch-query (dboard:tabdat-access-mode tabdat)
                                          rmt:get-runs-by-patt db:get-runs-by-patt
                                          (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))
	 (runs-header  (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
         (runs         (vector-ref runs-dat 1))
	 (run-id       (dboard:tabdat-curr-run-id tabdat))
         (runs-hash (dashboard:get-runs-hash tabdat))
         ;; (runs-hash    (let ((ht (make-hash-table)))
	 ;;        	 (for-each (lambda (run)
	 ;;        		     (hash-table-set! ht (db:get-value-by-header run runs-header "id") run))

              (iup:attribute-set! this-button "BGCOLOR" sel-color)
              (iup:attribute-set! this-button "BGCOLOR" nonsel-color))
          (loop (cdr buttons-left) (cdr modes-left))))))

(define (dboard:runs-summary-xor-labels-updater tabdat)
  (let ((source-runname-label (dboard:tabdat-runs-summary-source-runname-label tabdat))
        (dest-runname-label (dboard:tabdat-runs-summary-dest-runname-label tabdat))
        (mode (dboard:tabdat-runs-summary-mode tabdat))
	(access-mode (db:get-access-mode)))
    (when (and source-runname-label dest-runname-label)
      (case mode
        ((xor-two-runs xor-two-runs-hide-clean)
         (let* ((curr-run-id          (dboard:tabdat-curr-run-id tabdat))
                (prev-run-id          (dboard:tabdat-prev-run-id tabdat))
                (curr-runname (if curr-run-id
                                  (db:dispatch-query access-mode rmt:get-run-name-from-id db:get-run-name-from-id curr-run-id)
                                  "None"))
                (prev-runname (if prev-run-id
                                  (db:dispatch-query access-mode rmt:get-run-name-from-id db:get-run-name-from-id prev-run-id)
                                  "None")))
           (iup:attribute-set! source-runname-label "TITLE" (conc " SRC: "prev-runname"  "))
           (iup:attribute-set! dest-runname-label "TITLE" (conc "DEST: "curr-runname"  "))))
        (else
         (iup:attribute-set! source-runname-label "TITLE" "")
         (iup:attribute-set! dest-runname-label "TITLE" ""))))))

                           ;; Bummer - we dont have the global get/set api mapped in chicken
                           ;; (let* ((modkeys (iup:global "MODKEYSTATE")))
                           ;;   (BB> "modkeys="modkeys))

                           (BB> "click-cb: obj="obj" lin="lin" col="col" status="status)
                           ;; status is corrupted on Brandon's home machine.  will have to wait until after shutdown to see if it is still broken in PDX SLES
                           (let* ((access-mode (db:get-access-mode))
				  (toolpath (car (argv)))
                                  (key      (conc lin ":" col))
                                  (test-id   (hash-table-ref/default cell-lookup key -1))
                                  (run-id   (dboard:tabdat-curr-run-id tabdat))
                                  (run-info (db:dispatch-query access-mode rmt:get-run-info db:get-run-info run-id))
                                  (target   (db:dispatch-query access-mode rmt:get-target db:get-target run-id))
                                  (runname  (db:get-value-by-header (db:get-rows run-info)
                                                                    (db:get-header run-info) "runname"))
                                  (test-name (db:test-get-testname (rmt:get-test-info-by-id run-id test-id)))
                                  (testpatt  (let ((tlast (db:dispatch-query access-mode rmt:tasks-get-last tasks:get-last target runname)))
                                                (if tlast
                                                    (let ((tpatt (tasks:task-get-testpatt tlast)))
                                                      (if (member tpatt '("0" 0)) ;; known bad historical value - remove in 2017
                                                          "%"
                                                          tpatt))
                                                    "%")))
				  (test-info (db:dispatch-query access-mode rmt:get-test-info-by-id db:get-test-info-by-id run-id test-id))
                                  (item-path (db:test-get-item-path test-info))
                                  (item-test-path (conc test-name "/" (if (equal? item-path "")
									"%" 
									item-path)))
                                  (status-chars (char-set->list (string->char-set status)))
                                  (testpanel-cmd      (conc toolpath " -test " (dboard:tabdat-curr-run-id tabdat) "," test-id " &")))
                             (BB> "status-chars=["status-chars"] status=["status"]")
                             (cond

			    #:expand "NO"
			    #:fontsize btn-fontsz
			    #:button-cb
			    (lambda (obj a pressed x y btn . rem)
			      ;; (print "pressed= " pressed " x= " x " y= " y " rem=" rem " btn=" btn " string? " (string? btn))
			      (if  (substring-index "3" btn)
				   (if (eq? pressed 1)
				       (let* ((access-mode (db:get-access-mode))
					      (toolpath (car (argv)))
					      (buttndat (hash-table-ref (dboard:tabdat-buttondat runs-dat) button-key))
					      (test-id  (db:test-get-id (vector-ref buttndat 3)))
					      (run-id   (db:test-get-run_id (vector-ref buttndat 3)))
					      (run-info (db:dispatch-query access-mode rmt:get-run-info db:get-run-info run-id))
					      (target   (db:dispatch-query access-mode rmt:get-target db:get-target run-id))
					      (runname  (db:get-value-by-header (db:get-rows run-info)
										(db:get-header run-info) "runname"))
					      (test-info (db:dispatch-query access-mode rmt:get-test-info-by-id db:get-test-info-by-id run-id test-id))
					      (test-name (db:test-get-testname test-info))
					      (testpatt  (let ((tlast (db:dispatch-query access-mode rmt:tasks-get-last tasks:get-last target runname)))
							   (if tlast
							       (let ((tpatt (tasks:task-get-testpatt tlast)))
								 (if (member tpatt '("0" 0)) ;; known bad historical value - remove in 2017
								     "%"
								     tpatt))
							       "%")))
					      ;; Why are we getting the test-info over again? run-id and test-id are the same right?
                                              (item-path (db:test-get-item-path test-info)) ;; (db:dispatch-query access-mode rmt:get-test-info-by-id db:get-test-info-by-id run-id test-id)))
                                              (item-test-path (conc test-name "/" (if (equal? item-path "")
									"%" 
									item-path))))
					 (iup:show (dashboard:popup-menu run-id test-id target runname test-name testpatt item-test-path) ;; popup-menu
						   #:x 'mouse
						   #:y 'mouse
						   #:modal? "NO")

;; (define *monitor-db-path* #f)
(define *last-monitor-update-time* 0)

;; Force creation of the db in case it isn't already there.
(tasks:open-db)

(define (dashboard:get-youngest-run-db-mod-time tabdat)
  (let ((dbpath (dboard:tabdat-dbdir tabdat)))
    (handle-exceptions
     exn
     (begin
       (debug:print 0 *default-log-port* "WARNING: error in accessing databases in get-youngest-run-db-mod-time: " ((condition-property-accessor 'exn 'message) exn))
       (current-seconds)) ;; something went wrong - just print an error and return current-seconds
     (common:max (map (lambda (filen)
			(file-modification-time filen))
		      (glob (conc dbpath "/*.db")(conc dbpath "/*-shm")(conc dbpath "/*-wal")))))))

(define (dashboard:monitor-changed? commondat tabdat)
  (let* ((run-update-time (current-seconds))
	 (monitor-db-path (dboard:tabdat-monitor-db-path tabdat))
	 (monitor-modtime (if (and monitor-db-path (file-exists? monitor-db-path))
			      (file-modification-time monitor-db-path)
			      -1)))

	      (lambda (a b)
		(< (db:test-get-event_time (hash-table-ref testsdat (car a)))
		   (db:test-get-event_time (hash-table-ref testsdat (car b))))))))))

;; run times tab data updater
;;
(define (dashboard:run-times-tab-run-data-updater commondat tabdat tab-num)
  (let* ((access-mode      (dboard:tabdat-access-mode tabdat))
         (last-runs-update (dboard:tabdat-last-runs-update tabdat))
         (runs-dat      (db:dispatch-query access-mode
                                           rmt:get-runs-by-patt db:get-runs-by-patt
                                           (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))
	 (runs-header   (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
	 (runs-hash     (let ((ht (make-hash-table)))
			  (for-each (lambda (run)
				      (hash-table-set! ht (db:get-value-by-header run runs-header "id") run))
				    (vector-ref runs-dat 1))
			  ht))
	 (run-ids       (sort (filter number? (hash-table-keys runs-hash))

	(for-each
	 (lambda (run-id)
	   (let* ((run-record (hash-table-ref/default runs-hash run-id #f))
		  (key-vals   (map (lambda (key)(db:get-value-by-header run-record runs-header key))
				   (dboard:tabdat-keys tabdat)))
		  (run-name   (db:get-value-by-header run-record runs-header "runname"))
		  (col-name   (conc (string-intersperse key-vals "\n") "\n" run-name))
		  (run-path   (append key-vals (list run-name))))
             ;; 		  (existing   (tree:find-node tb run-path)))
	     (if (not (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) run-path #f))
		 (begin
		   (hash-table-set! (dboard:tabdat-run-keys tabdat) run-id run-path)
		   ;; Here we update the tests treebox and tree keys
		   (tree:add-node tb "Runs" run-path) ;; (append key-vals (list run-name))
                   ;;				  userdata: (conc "run-id: " run-id))
		   (hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path run-id)
		   ;; (set! colnum (+ colnum 1))
		   ))))
	 run-ids))
    ;; (print "Updating rundat")
    (if (dboard:tabdat-keys tabdat) ;; have keys yet?
	(let* ((num-keys (length (dboard:tabdat-keys tabdat)))

;;    if db already open - return inmem
;;    if db not open, open inmem, rundb and sync then return inmem
;;    inuse gets set automatically for rundb's
;;
(define (db:get-db dbstruct run-id) 
  (if (sqlite3:database? dbstruct) ;; pass sqlite3 databases on through
      dbstruct
      (if (pair? dbstruct)
	  dbstruct                 ;; pass pair ( db . path ) on through
	  (begin
	    ;; (assert (dbr:dbstruct? dbstruct)) ;; so much legacy, but by here we should have a genuine dbstruct
	    (let ((dbdat (if (or (not run-id)
				 (eq? run-id 0))
			     (db:open-main dbstruct)
			     (db:open-rundb dbstruct run-id)
			     )))
	      dbdat)))))

;; legacy handling of structure for managing db's. Refactor this into dbr:?
(define (db:dbdat-get-db dbdat)
  ;; (assert (pair? dbdat))
  (if (pair? dbdat)
      (car dbdat)
      dbdat))

(define (db:dbdat-get-path dbdat)
  ;; (assert (pair? dbdat))
  (if (pair? dbdat)
      (cdr dbdat)
      #f))

;; mod-read:
;;     'mod   modified data
;;     'read  read data

			   (file-write-access? fname)
			   dir-writable )))
    (if file-write ;; dir-writable
	(let (;; (lock    (obtain-dot-lock fname 1 5 10))
	      (db      (sqlite3:open-database fname)))
	  (sqlite3:set-busy-handler! db (make-busy-timeout 136000))
	  (db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = 0;")
	  (if (not file-exists)
	      (begin
		(if (string-match "^/tmp/.*" fname) ;; this is a file in /tmp
		    (sqlite3:execute db "PRAGMA journal_mode=WAL;")
		    (print "Creating " fname " in NON-WAL mode."))
		(initproc db)))
	  ;; (release-dot-lock fname)
	  db)
	(begin
	  (debug:print 2 *default-log-port* "WARNING: opening db in non-writable dir " fname)
	  (sqlite3:open-database fname))))) ;; )

;; This routine creates the db. It is only called if the db is not already opened

	    (if (and (not dbexists)
		     *db-write-access*) ;; did not have a prior db and do have write access
		(db:multi-db-sync #f 'old2new))  ;; migrate data from megatest.db automatically
	    dbdat)))))

;; Make the dbstruct, setup up auxillary db's and call for main db at least once
;;
;; called in http-transport and replicated in rmt.scm for *local* access. 
;;
(define (db:setup run-id #!key (local #f))
  (let* ((dbdir    (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
	 (dbstruct (make-dbr:dbstruct path: dbdir local: local)))
    dbstruct))

;; open the local db for direct access (no server)
;;
(define (db:open-local-db-handle)
  (or *dbstruct-db*
      (let ((dbstruct (db:setup #f local: #t)))
	(set! *dbstruct-db* dbstruct)
	dbstruct)))
	  
;; Open the classic megatest.db file in toppath
;;
;;   NOTE: returns a dbdat not a dbstruct!
;;
(define (db:open-megatest-db #!key (path #f))
  (let* ((dbpath       (or path (conc *toppath* "/megatest.db")))
	 (dbexists     (file-exists? dbpath))
	 (db           (db:lock-create-open dbpath
					    (lambda (db)
					      (db:initialize-main-db db)

                               BEGIN 
                                 UPDATE run_stats SET last_update=(strftime('%s','now'))
                                   WHERE id=old.id;
                               END;"))

(define *global-db-store* (make-hash-table))

(define (db:get-access-mode)
  (if (args:get-arg "-use-db-cache") 'cached 'rmt))

;; Add db direct
;;
(define (db:dispatch-query access-mode rmt-cmd db-cmd . params)
  (if (eq? access-mode 'cached)
      (apply db:call-with-cached-db db-cmd params)
      (apply rmt-cmd params)))

;; return the target db handle so it can be used
;;
(define (db:cache-for-read-only source target #!key (use-last-update #f))
  (if (and (hash-table-ref/default *global-db-store* target #f)
	   (>= (file-modification-time target)(file-modification-time source)))
      (hash-table-ref *global-db-store* target)
      (let* ((toppath   (launch:setup))

	(hash-table-set! *global-db-store* target cache-db)
	cache-db)))

;; call a proc with a cached db
;;
(define (db:call-with-cached-db proc . params)
  ;; first cache the db in /tmp
  (let* ((cname-part  (conc "megatest_cache/" (common:get-testsuite-name)))
	 (fname       (conc  (common:get-area-path-signature) ".db"))
	 (cache-dir   (common:get-create-writeable-dir
		       (list (conc "/tmp/" (current-user-name) "/" cname-part)
			     (conc "/tmp/" (current-user-name) "-" cname-part)
			     (conc "/tmp/" (current-user-name) "_" cname-part))))
	 (megatest-db (conc *toppath* "/megatest.db")))
	 ;; (debug:print-info 0 *default-log-port* "Using cache dir " cache-dir)
    (if (not cache-dir)
	(begin
	  (debug:print 0 *default-log-port* "ERROR: Failed to find an area to write the cache db")
	  (exit 1))
	(let* ((th1      (make-thread
			  (lambda ()
			    (if (and (file-exists? megatest-db)
				     (file-write-access? megatest-db))
				(begin
				  (common:sync-to-megatest.db 'timestamps) ;; internally mutexes on *db-local-sync*
				  (debug:print-info 2 *default-log-port* "Done syncing to megatest.db"))))
			  "call-with-cached-db sync-to-megatest.db"))
	       (cache-db (db:cache-for-read-only
			  megatest-db
			  (conc cache-dir "/" fname)
			  use-last-update: #t)))
	  (thread-start! th1)
	  (apply proc cache-db params)
	  ))))

;; options:
;;
;;  'killservers  - kills all servers
;;  'dejunk       - removes junk records
;;  'adj-testids  - move test-ids into correct ranges
;;  'old2new      - sync megatest.db records to .db/{main,1,2 ...}.db
;;  'new2old      - sync .db/{main,1,2,3 ...}.db to megatest.db
;;  'closeall     - close all opened dbs
;;  'schema       - attempt to apply schema changes
;;
;;  run-ids: '(1 2 3 ...) or #f (for all)
;;
(define (db:multi-db-sync run-ids . options)
  (let* ((toppath  (launch:setup))
	 (dbstruct (if toppath (make-dbr:dbstruct path: toppath) #f))
	 (mtdb     (if toppath (db:open-megatest-db)))

           (map
            (lambda (run-id)
              (thread-start! 
               (make-thread
                (lambda ()
                  (let* ((fromdb (if toppath (make-dbr:dbstruct path: toppath local: #t) #f))
                         (frundb (db:dbdat-get-db (db:get-db fromdb run-id))))
                    (if (member 'schema options)
                        (if (eq? run-id 0)
                            (let ((maindb  (db:dbdat-get-db (db:get-db fromdb #f))))
                              (db:patch-schema-maindb run-id maindb))
                            (db:patch-schema-rundb run-id frundb))))
                  (set! count (+ count 1))
                  (debug:print 0 *default-log-port* "Finished patching schema for " (if (eq? run-id 0) " main.db " (conc run-id ".db")) ", " count " of " total)))))
            all-run-ids))
          ;; Then sync and fix db's
          (set! count 0)
          (process-fork
           (lambda ()

    
    (debug:print-info 18 *default-log-port* "Found " (length oldlaunched) " old LAUNCHED items, " (length toplevels) " old LAUNCHED toplevel tests and " (length incompleted) " tests marked RUNNING but apparently dead.")
    (if (and (null? incompleted)
	     (null? oldlaunched)
	     (null? toplevels))
	#f
	#t)))

;; given a launch delay (minimum time from last launch) return amount of time to wait
;;
;; (define (db:launch-delay-left dbstruct run-id launch-delay)
  

;;  select end_time-now from
;;      (select testname,item_path,event_time+run_duration as
;;                          end_time,strftime('%s','now') as now from tests where state in
;;      ('RUNNING','REMOTEHOSTSTART','LAUNCED'));

(define (db:find-and-mark-incomplete dbstruct run-id ovr-deadtime)

	    (set! res (cons (list key key-val) res)))
	  db qry run-id)))
     keys)
    (reverse res)))

;; get key vals for a given run-id
(define (db:get-key-vals dbstruct run-id)
  ;; (assert (dbr:dbstruct? dbstruct))
  (let* ((keys (db:get-keys dbstruct))
	 (res  '())
	 (dbdat  (db:get-db dbstruct #f))
	 (db     (db:dbdat-get-db dbdat)))
    (for-each 
     (lambda (key)
       (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;")))

	      (list  "MT_TEST_NAME" test-name)
	      (list  "MT_ITEM_INFO" (conc itemdat))
	      (list  "MT_ITEMPATH"  item-path)
	      (list  "MT_RUNNAME"   runname)
	      (list  "MT_MEGATEST"  megatest)
	      (list  "MT_TARGET"    target)
	      (list  "MT_LINKTREE"  (configf:lookup *configdat* "setup" "linktree"))
	      (list  "MT_TESTSUITE_NAME" (common:get-testsuite-name))))

	  (if mt-bindir-path (setenv "PATH" (conc (getenv "PATH") ":" mt-bindir-path)))
	  ;; (change-directory top-path)
	  ;; Can setup as client for server mode now
	  ;; (client:setup)

	  

	 (target   (common:args-get-target))
	 (linktree (common:get-linktree))
	 (sections (if target (list "default" target) #f)) ;; for runconfigs
	 (mtconfig (or (args:get-arg "-config") "megatest.config")) ;; allow overriding megatest.config 
	 (rundir   (if (and runname target linktree)(conc linktree "/" target "/" runname) #f))
	 (mtcachef (and rundir (conc rundir "/" ".megatest.cfg-"  megatest-version "-" megatest-fossil-hash)))
	 (rccachef (and rundir (conc rundir "/" ".runconfigs.cfg-"  megatest-version "-" megatest-fossil-hash)))
	 (cancreate (and rundir (file-exists? rundir)(file-write-access? rundir)))
         (cxt       (hash-table-ref/default *contexts* toppath #f)))

    ;; create our cxt for this area if it doesn't already exist
    (if (not cxt)(hash-table-set! *contexts* toppath (make-cxt)))

    ;; (print "runname: " runname " target: " target " mtcachef: " mtcachef " rccachef: " rccachef)
    (set! *toppath* toppath) ;; This is needed when we are running as a test using CMDINFO as a datasource
    (cond
     ;; data was read and cached and available in *configstatus*, toppath has already been set
     ((eq? *configstatus* 'fulldata)
      *toppath*)
     ;; if mtcachef exists just read it, however we need to assume toppath is available in $MT_RUN_AREA_HOME

	       (if (not (file-exists? tlink))
		   (create-symbolic-link linktree tlink)))))
	  (begin
	    (debug:print-error 0 *default-log-port* "linktree not defined in [setup] section of megatest.config")
	    )))
    (if (and *toppath*
	     (directory-exists? *toppath*))
	(begin
	  (setenv "MT_RUN_AREA_HOME" *toppath*)
	  (setenv "MT_TESTSUITE_NAME" (common:get-testsuite-name)))
	(begin
	  (debug:print-error 0 *default-log-port* "failed to find the top path to your Megatest area.")))
    *toppath*))

(define (get-best-disk confdat testconfig)
  (let* ((disks   (or (and testconfig (hash-table-ref/default testconfig "disks" #f))
		      (hash-table-ref/default confdat "disks" #f)))

;; 2. create run dir on disk, path name is meaningful
;; 3. create link from run dir to megatest runs area 
;; 4. remotely run the test on allocated host
;;    - could be ssh to host from hosts table (update regularly with load)
;;    - could be netbatch
;;      (launch-test db (cadr status) test-conf))
(define (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat params)
  (let loop ((delta        (- (current-seconds) *last-launch*))
	     (launch-delay (string->number (or (configf:lookup *configdat* "setup" "launch-delay") "5"))))
    (if (> launch-delay delta)
	(begin
	  (debug:print-info 0 *default-log-port* "Delaying launch of " test-name " for " (- launch-delay delta) " seconds")
	  (thread-sleep! (- launch-delay delta))
	  (loop (- (current-seconds) *last-launch*) launch-delay))))
  (set! *last-launch* (current-seconds))
  (change-directory *toppath*)
  (alist->env-vars ;; consolidate this code with the code in megatest.scm for "-execute"
   (list ;; (list "MT_TEST_RUN_DIR" work-area)
    (list "MT_RUN_AREA_HOME" *toppath*)
    (list "MT_TEST_NAME" test-name)
    ;; (list "MT_ITEM_INFO" (conc itemdat)) 
    (list "MT_RUNNAME"   runname)

;; Always use two or four digit decimal
;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00..

(declare (unit megatest-version))

(define megatest-version 1.6208)

;; (include "common.scm")
;; (include "megatest-version.scm")

;; fake out readline usage of toplevel-command
(define (toplevel-command . a) #f)

(use sqlite3 srfi-1 posix regex regex-case srfi-69 base64 readline apropos json http-client directory-utils rpc typed-records;; (srfi 18) extras)
     http-client srfi-18 extras format) ;;  zmq extras)

;; Added for csv stuff - will be removed
;;
(use sparse-vectors)

(import (prefix sqlite3 sqlite3:))

;;
(let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target"))))
  (if targ (setenv "MT_TARGET" targ)))

;; The watchdog is to keep an eye on things like db sync etc.
;;
(define *time-zero* (current-seconds))
(define *watchdog*  (make-thread common:watchdog "Watchdog thread"))



















































(thread-start! *watchdog*)


(if (args:get-arg "-log")
    (let ((oup (open-output-file (args:get-arg "-log"))))
      (debug:print-info 0 *default-log-port* "Sending log output to " (args:get-arg "-log"))
      (set! *default-log-port* oup)))

(if (or (args:get-arg "-h")

  (let ((indx (hash-table-ref/default test-field-index fieldname #f)))
    (if indx
	(if (>= indx (vector-length datavec))
	    #f ;; index too high, should raise an error I suppose
	    (vector-ref datavec indx))
	#f)))








;; NOTE: list-runs and list-db-targets operate on local db!!!
;;
;; IDEA: megatest list -runname blah% ...
;;
(if (or (args:get-arg "-list-runs")
	(args:get-arg "-list-db-targets"))
    (if (launch:setup)
	(let* (;; (dbstruct    (make-dbr:dbstruct path: *toppath* local: (args:get-arg "-local")))
	       (runpatt     (args:get-arg "-list-runs"))
               (access-mode (db:get-access-mode))
	       (testpatt    (common:args-get-testpatt #f))
	       ;; (if (args:get-arg "-testpatt") 
	       ;;  	        (args:get-arg "-testpatt") 
	       ;;  	        "%"))
	       (keys        (rmt:get-keys)) ;; (db:get-keys dbstruct))
	       ;; (runsdat  (db:get-runs dbstruct runpatt #f #f '()))
	;; (runsdat     (rmt:get-runs-by-patt keys (or runpatt "%") (common:args-get-target) ;; (db:get-runs-by-patt dbstruct keys (or runpatt "%") (common:args-get-target)
	;; 		           	 #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0))
	       (runsdat     (db:dispatch-query access-mode rmt:get-runs-by-patt db:get-runs-by-patt keys (or runpatt "%") 
                                            (common:args-get-target) #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0))
	       (runstmp     (db:get-rows runsdat))
	       (header      (db:get-header runsdat))
	       ;; this is "-since" support. This looks at last mod times of <run-id>.db files
	       ;; and collects those modified since the -since time.
	       (runs        (if (and (not (null? runstmp))
				     (args:get-arg "-since"))

			     (hash-table-set! data "targets" (cons targetstr (hash-table-ref/default data "targets" '())))
			     )))
		   (let* ((run-id  (db:get-value-by-header run header "id"))
			  (runname (db:get-value-by-header run header "runname")) 
			  (states  (string-split (or (args:get-arg "-state") "") ","))
			  (statuses (string-split (or (args:get-arg "-status") "") ","))
			  (tests   (if tests-spec
				       (db:dispatch-query access-mode rmt:get-tests-for-run db:get-tests-for-run run-id testpatt states statuses #f #f #f 'testname 'asc ;; (db:get-tests-for-run dbstruct run-id testpatt '() '() #f #f #f 'testname 'asc 
							     ;; use qryvals if test-spec provided
							     (if tests-spec
								 (string-intersperse adj-tests-spec ",")
								 ;; db:test-record-fields
								 #f)
							     #f
							     'normal)

						 (conc "\n         rundir:   " (get-value-by-fieldname test test-field-index "rundir")) ;; (db:test-get-rundir test)
						 "")
;;					     "\n         rundir:   " (get-value-by-fieldname test test-field-index "") ;; (sdb:qry 'getstr ;; (filedb:get-path *fdb* 
;; 					     (db:test-get-rundir test) ;; )
					     )
				    ;; Each test
				    ;; DO NOT remote run
				    (let ((steps (db:dispatch-query access-mode rmt:get-steps-for-test db:get-steps-for-test run-id (db:test-get-id test)))) ;; (db:get-steps-for-test dbstruct run-id (db:test-get-id test))))
				      (for-each 
				       (lambda (step)
					 (format #t 
						 "    Step: ~20a State: ~10a Status: ~10a Time ~22a\n"
						 (tdb:step-get-stepname step)
						 (tdb:step-get-state step)
						 (tdb:step-get-status step)

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

(define (rmt:open-qry-close-locally cmd run-id params #!key (remretries 5))
  (let* ((qry-is-write   (not (member cmd api:read-only-queries)))
	 (dbdir          (db:dbfile-path #f))
	 (dbstruct-local (if *dbstruct-db*
			     *dbstruct-db*

			     (let* ((db (make-dbr:dbstruct path:  dbdir local: #t)))
			       (set! *dbstruct-db* db)
			       db)))

	 (read-only      (not (file-write-access? dbdir)))
	 (start          (current-milliseconds))
	 (resdat         (if (not (and read-only qry-is-write))
			     (api:execute-requests dbstruct-local (vector (symbol->string cmd) params))
			     (vector #t '())))
	 (success        (vector-ref resdat 0))
	 (res            (vector-ref resdat 1))
	 (duration       (- (current-milliseconds) start)))
    (if (and read-only qry-is-write)
	(begin
	  (debug:print 0 *default-log-port* "ERROR: attempt to write to read-only database ignored. cmd=" cmd)
	  ))
    (if (not success)
	(if (> remretries 0)
	    (begin
	      (debug:print-error 0 *default-log-port* "local query failed. Trying again.")
	      (thread-sleep! (/ (random 5000) 1000)) ;; some random delay 
	      (rmt:open-qry-close-locally cmd run-id params remretries: (- remretries 1)))
	    (begin
	      (debug:print-error 0 *default-log-port* "too many retries in rmt:open-qry-close-locally, giving up")
	      #f))
	(begin
	  ;; (rmt:update-db-stats run-id cmd params duration)
	  ;; mark this run as dirty if this was a write
	  (if qry-is-write
	      (let ((start-time (current-seconds)))
		(if (not (or (common:legacy-sync-required)
			     (common:legacy-sync-recommended))) ;; no sync being done
		    (common:sync-to-megatest.db 'timestamps)  ;; forced full sync based on timestamps
		    (begin
		      (mutex-lock! *db-multi-sync-mutex*)


		      (hash-table-set! *db-local-sync* (or run-id 0) start-time) ;; the oldest "write"
		      (mutex-unlock! *db-multi-sync-mutex*)))))
	  res))))

(define (rmt:send-receive-no-auto-client-setup connection-info cmd run-id params)
  (let* ((run-id   (if run-id run-id 0))
	 ;; (jparams  (db:obj->string params)) ;; (rmt:dat->json-str params))
	 (res  	   (handle-exceptions
		    exn

;; These require run-id because the values come from the run!
;;
(define (rmt:get-key-val-pairs run-id)
  (rmt:send-receive 'get-key-val-pairs run-id (list run-id)))

(define (rmt:get-keys)
  (if *db-keys* *db-keys* 
     (let ((res (rmt:send-receive 'get-keys #f '())))
       (set! *db-keys* res)
       res)))

;; we don't reuse run-id's (except possibly *after* a db cleanup) so it is safe
;; to cache the resuls in a hash
;;
(define (rmt:get-key-vals run-id)
  (or (hash-table-ref/default *keyvals* run-id #f)
      (let ((res (rmt:send-receive 'get-key-vals #f (list run-id))))
        (hash-table-set! *keyvals* run-id res)
        res)))

(define (rmt:get-targets)
  (rmt:send-receive 'get-targets #f '()))

(define (rmt:get-target run-id)
  (rmt:send-receive 'get-target run-id (list run-id)))

	  (debug:print-info 4 *default-log-port* "Exiting loop with...\n  hed=" hed "\n  tal=" tal "\n  reruns=" reruns))
	 )))
    ;; now *if* -run-wait we wait for all tests to be done
    ;; Now wait for any RUNNING tests to complete (if in run-wait mode)
    (thread-sleep! 5) ;; I think there is a race condition here. Let states/statuses settle
    (let wait-loop ((num-running      (rmt:get-count-tests-running-for-run-id run-id))
		    (prev-num-running 0))
      ;; (BB> "num-running=" num-running ", prev-num-running=" prev-num-running)
      (if (and (or (args:get-arg "-run-wait")
		   (equal? (configf:lookup *configdat* "setup" "run-wait") "yes"))
	       (> num-running 0))
	  (begin
	    ;; Here we mark any old defunct tests as incomplete. Do this every fifteen minutes
	    ;; (debug:print 0 *default-log-port* "Got here eh! num-running=" num-running " (> num-running 0) " (> num-running 0))
	    (if (> (current-seconds)(+ last-time-incomplete 900))

test0 : cleanprep
	cd simplerun ; $(MEGATEST) -server - -debug $(DEBUG)

test1 : cleanprep

test2 : fullprep
	cd fullrun;$(MEGATEST) -preclean -runtests ez_pass,runfirst/a/% -reqtarg ubuntu/nfs/none -runname $(RUNNAME) -debug $(DEBUG) $(LOGGING)
	cd fullrun;megatest -preclean -runtests % -target ubuntu/nfs/none -runname $(RUNNAME)_01 -testpatt %/,%/ai -debug $(DEBUG)
	cd fullrun;megatest -preclean -runtests %/,%/ai -target ubuntu/nfs/none -runname $(RUNAME)_02 -debug $(DEBUG)
	cd fullrun;megatest -preclean -runtests runfirst/%,%/ai -target ubuntu/nfs/none -runname $(RUNNAME)_02 -debug $(DEBUG)
	cd fullrun;megatest -runtests %/,%/winter -target ubuntu/nfs/none -runname $(RUNNAME)_03  -debug $(DEBUG)
	sleep 40;cd fullrun;megatest -target ubuntu/nfs/none -runname $(RUNNAME) -set-state-status COMPLETED,FORCED :state COMPLETED :status PASS -testpatt ez_p%s,runfirst/ -debug $(DEBUG) $(LOGGING)


test3 : fullprep test3a test3b

test3a :
	@echo Run runfirst and any waitons.
	cd fullrun;$(MEGATEST) -preclean -runtests runfirst -reqtarg ubuntu/nfs/none -runname $(RUNNAME)_b 

test3b :
	@echo Run all_toplevel and all waitons
	cd fullrun;$(MEGATEST) -preclean -runtests all_toplevel -reqtarg ubuntu/nfs/none -runname $(RUNNAME)_c

test4 : cleanprep
	@echo "WARNING: No longer running fullprep, test converage may be lessened"
	cd fullrun;time $(MEGATEST) -debug $(DEBUG) -run-wait -run -testpatt % -reqtarg ubuntu/nfs/none -runname $(RUNNAME)_b -m "This is a comment specific to a run" -v $(LOGGING)

test4a : cleanprep
	cd fullrun;time $(MEGATEST) -debug $(DEBUG) -preclean -run -testpatt all_toplevel -reqtarg ubuntu/nfs/none -runname $(RUNNAME)_b -m "This is a comment specific to a run" -v $(LOGGING)

# NOTE: Only one instance can be a server
test5 : cleanprep
	rm -f fullrun/a*.log fullrun/logs/*
	@echo "WARNING: No longer running fullprep, test converage may be lessened"
	cd fullrun;sleep 0;$(MEGATEST) -preclean -runtests % -target $(TARGET) :runname $(RUNNAME)_aa -debug $(DEBUG) $(LOGGING) > aa.log 2> aa.log &
	cd fullrun;sleep 0;$(MEGATEST) -preclean -runtests % -target ubuntu/nfs/sleep1 :runname $(RUNNAME)_ae -debug $(DEBUG) $(LOGGING) > ae.log 2> ae.log &	

# turn off faststart, put monitor.db in MT_RUN_AREA_HOME/db
# and set the dbdir to /var/tmp/$USER/mt_db to enable keeping
# the raw db in /var/tmp/$USER
#
faststart  no
monitordir #{getenv MT_RUN_AREA_HOME}/db
dbdirdefn  /tmp/#{getenv USER}/#{getenv MT_TESTSUITE_NAME}/db
dbdirmkdir #{scheme (create-directory "#{get setup dbdirdefn}" #t)}
dbdir      #{get setup dbdirdefn}

# sync more aggressively to megatest-db
megatest-db yes

# Set launchwait to no to use the more agressive code that does not wait for the launch to complete before proceeding
# this may save a few milliseconds on launching tests
# launchwait no
waivercommentpatt ^WW\d+ [a-z].*
incomplete-timeout 1

# wait 25 seconds between launching every process
#
launch-delay 25

# wait for runs to completely complete. yes, anything else is no
run-wait yes

# If set to "default" the old code is used. Otherwise defaults to 200 or uses
# numeric value given.
#

    sleep 1
    screen -X hardstatus off
    screen -X hardstatus alwayslastline
    screen -X hardstatus string '%{= kG}[ %{G}%H %{g}][%= %{= kw}%?%-Lw%?%{r}(%{W}%n*%f%t%?(%u)%?%{r})%{w}%?%+Lw%?%?%= %{g}][%{B} %m-%d %{W} %c %{g}]'
fi

cmd="cd $PWD;$*"
screen -X screen bash -c "$cmd;echo \"Press any key to continue, ctrl-f <space> to see other windows\";bash -c 'read -n 1 -s'" &