Megatest

# make install CSCOPTS='-accumulate-profile -profile-name $(PWD)/profile-ww$(shell date +%V.%u)'
PREFIX=$(PWD)
CSCOPTS= 
INSTALL=install
SRCFILES = common.scm items.scm launch.scm \
   ods.scm runconfig.scm server.scm configf.scm \
   db.scm keys.scm margs.scm megatest-version.scm \
   process.scm runs.scm tasks.scm tests.scm genexample.scm \
   http-transport.scm filedb.scm \
   client.scm synchash.scm daemon.scm mt.scm \
   ezsteps.scm lock-queue.scm sdb.scm \
   rmt.scm api.scm tdb.scm rpc-transport.scm \
   portlogger.scm archive.scm env.scm

# Eggs to install (straightforward ones)
EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \

dboard : $(OFILES) $(GOFILES) dashboard.scm
	csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) -o dboard

ndboard : newdashboard.scm $(OFILES) $(GOFILES)
	csc $(CSCOPTS) $(OFILES) $(GOFILES) newdashboard.scm -o ndboard

#multi-dboard : multi-dboard.scm $(OFILES) $(GOFILES)
#	csc $(CSCOPTS) $(OFILES) $(GOFILES) multi-dboard.scm -o multi-dboard

# 
# $(PREFIX)/bin/revtagfsl : utils/revtagfsl.scm
#	csc utils/revtagfsl.scm -o $(PREFIX)/bin/revtagfsl

# Special dependencies for the includes
tests.o db.o launch.o runs.o dashboard-tests.o dashboard-guimonitor.o dashboard-main.o monitor.o dashboard.o  \

$(PREFIX)/bin/.$(ARCHSTR)/ndboard : ndboard
	$(INSTALL) ndboard $(PREFIX)/bin/.$(ARCHSTR)/ndboard

$(PREFIX)/bin/newdashboard : $(PREFIX)/bin/.$(ARCHSTR)/ndboard utils/mk_wrapper
	utils/mk_wrapper $(PREFIX) ndboard $(PREFIX)/bin/newdashboard
	chmod a+x $(PREFIX)/bin/newdashboard

#$(PREFIX)/bin/.$(ARCHSTR)/mdboard : multi-dboard
#	$(INSTALL) multi-dboard $(PREFIX)/bin/.$(ARCHSTR)/mdboard

$(PREFIX)/bin/mdboard : $(PREFIX)/bin/.$(ARCHSTR)/mdboard  utils/mk_wrapper
	utils/mk_wrapper $(PREFIX) mdboard $(PREFIX)/bin/mdboard
	chmod a+x $(PREFIX)/bin/mdboard

# $(HELPERS) : utils/%
# 	$(INSTALL) $< $@

	if  csi -ne '(use mysql-client)';then \
           echo "(use mysql-client)(hash-table-set! *available-db* 'mysql #t)" >> altdb.scm; \
	fi
	if csi -ne '(use postgresql)';then \
	   echo "(use postgresql)(hash-table-set! *available-db* 'postgresql #t)" >> altdb.scm;\
	fi

portlogger-example : portlogger-example.scm api.o archive.o client.o common.o configf.o daemon.o dashboard-tests.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o megatest-version.o mt.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o
	csc $(CSCOPTS) portlogger-example.scm api.o archive.o client.o common.o configf.o daemon.o dashboard-tests.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o megatest-version.o mt.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o

	  (debug:print-info 4 *default-log-port* "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries)
	  (if server-dat
	      (let* ((iface     (tasks:hostinfo-get-interface server-dat))
		     (hostname  (tasks:hostinfo-get-hostname  server-dat))
		     (port      (tasks:hostinfo-get-port      server-dat))
		     (start-res (case *transport-type*
				  ((http)(http-transport:client-connect iface port))
				  ;;((nmsg)(nmsg-transport:client-connect hostname port))
                                  ))
		     (ping-res  (case *transport-type* 
				  ((http)(rmt:login-no-auto-client-setup start-res run-id))
				  ;; ((nmsg)(let ((logininfo (rmt:login-no-auto-client-setup start-res run-id)))
 				  ;;          (if logininfo
 				  ;;              (car (vector-ref logininfo 1))
 				  ;;              #f)))

                                  )))
		(if (and start-res
			 ping-res)
		    (begin
		      (hash-table-set! *runremote* run-id start-res)
		      (debug:print-info 2 *default-log-port* "connected to " (http-transport:server-dat-make-url start-res))
		      start-res)
		    (begin    ;; login failed but have a server record, clean out the record and try again

;;======================================================================
;; 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)
(require-extension regex posix)

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

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

  (conc megatest-version "-" megatest-fossil-hash))

(define (common:version-signature)
  (conc megatest-version "-" (substring megatest-fossil-hash 0 4)))

;; from metadat lookup MEGATEST_VERSION
;;
(define (common:get-last-run-version) ;; RADT => How does this work in send-receive function??; assume it is the value saved in some DB
  (rmt:get-var "MEGATEST_VERSION"))

(define (common:get-last-run-version-number)
  (string->number 
   (substring (common:get-last-run-version) 0 6)))

(define (common:set-last-run-version)
  (rmt:set-var "MEGATEST_VERSION" (common:version-signature)))

(define (common:version-changed?)
  (not (equal? (common:get-last-run-version)
	       (common:version-signature))))

;; Move me elsewhere ...
;; RADT => Why do we meed the version check here, this is called only if version misma
;;
(define (common:cleanup-db)
  (db:multi-db-sync 
   #f ;; do all run-ids
   ;; 'new2old
   'killservers
   'dejunk
   ;; 'adj-testids
   ;; 'old2new
   'new2old)
  (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?)
      (let ((mtconf (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.config")))
        (debug:print 0 *default-log-port*
		     "WARNING: Version mismatch!\n"
		     "   expected: " (common:version-signature) "\n"
		     "   got:      " (common:get-last-run-version))
	(if (and (file-exists? mtconf)
		 (eq? (current-user-id)(file-owner mtconf))) ;; safe to run -cleanup-db
	    (begin
	      (debug:print 0 *default-log-port* "   I see you are the owner of megatest.config, attempting to cleanup and reset to new version")
	      (handle-exceptions

		    (if (> curr-rownum rownum) curr-rownum rownum)
		    (if (> curr-colnum colnum) curr-colnum colnum)
		    ))))))

;;======================================================================
;; S Y S T E M   S T U F F
;;======================================================================

;; lazy-safe get file mod time. on any error (file not existing etc.) return 0
;;
(define (common:lazy-modification-time fpath)
  (handle-exceptions
   exn
   0
   (file-modification-time fpath)))

;; return a nice clean pathname made absolute
(define (common:nice-path dir)
  (let ((match (string-match "^(~[^\\/]*)(\\/.*|)$" dir)))
    (if match ;; using ~ for home?
	(common:nice-path (conc (common:read-link-f (cadr match)) "/" (caddr match)))
	(normalize-pathname (if (absolute-pathname? dir)

     ;; NOTE: This can fail when there is no mention of the host in /etc/hosts. FIXME
     (vector->list (hostinfo-addresses (hostname->hostinfo hostname))))
    (string-intersperse 
     (map number->string
	  (u8vector->list
	   (if res res (hostname->ip hostname)))) ".")))














(define (common:send-dboard-main-changed)
  (let* ((dashboard-ips (mddb:get-dashboards)))
    (for-each
     (lambda (ipadr)
       (let* ((soc (common:open-nm-req (conc "tcp://" ipadr)))
	      (msg (conc "main " *toppath*))
	      (res (common:nm-send-receive-timeout soc msg)))
	 (if (not res) ;; couldn't reach that dashboard - remove it from db
	     (print "ERROR: couldn't reach dashboard " ipadr))
	 res))
     dashboard-ips)))
    

































    















































;;======================================================================
;; D A S H B O A R D   D B 
;;======================================================================

(define (mddb:open-db)
  (let* ((db (open-database (conc (get-environment-variable "HOME") "/.dashboard.db"))))
    (set-busy-handler! db (busy-timeout 10000))

  (if (debug:debug-mode n)
      (with-output-to-port (or e (current-error-port))
	(lambda ()
	  (if *logging*
	      (db:log-event (apply conc params))
	      (apply print params)
	      )))))

;; Brandon's debug printer shortcut (indulge me :)
(define (BB> . in-args)
  (let* ((stack (get-call-chain))
         (location #f))
    (for-each
     (lambda (frame)
       (let* ((this-loc (vector-ref frame 0))
              (this-func (cadr (string-split this-loc " "))))
         (if (equal? this-func "BB>")
             (set! location this-loc))))
     stack)
    (let ((dp-args (append (list 0 *default-log-port* location"   "  ) in-args)))
      (apply debug:print dp-args))))

(define (debug:print-error n e . params)
  ;; normal print
  (if (debug:debug-mode n)
      (with-output-to-port (or e (current-error-port))
	(lambda ()
	  (if *logging*

					 (iup:destroy! dlog)))))))
    dlog))


;;======================================================================
;;
;;======================================================================
(define (dashboard-tests:examine-test run-id test-id) ;; run-id run-key origtest)
  (let* ((db-path       (db:dbfile-path run-id)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/db/" run-id ".db"))
	 (dbstruct      (make-dbr:dbstruct path:  (db:dbfile-path #f) ;; (configf:lookup *configdat* "setup" "linktree") 
					   local: #t))
	 (testdat        (rmt:get-test-info-by-id run-id test-id)) ;; (db:get-test-info-by-id dbstruct run-id test-id))
	 (db-mod-time   0) ;; (file-modification-time db-path))
	 (last-update   0) ;; (current-seconds))
	 (request-update #t))

		 0))

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

;; data common to all tabs goes here
;;
(defstruct dboard:commondat
  ((curr-tab-num 0) : number)
  please-update  
  tabdats
  update-mutex
  updaters 
  updating
  uidat ;; needs to move to tabdat at some time
  hide-not-hide-tabs
  )


(define (dboard:commondat-make)
  (make-dboard:commondat
   curr-tab-num:         0
   tabdats:              (make-hash-table)
   please-update:        #t
   update-mutex:         (make-mutex)
   updaters:             (make-hash-table)
   updating:             #f
   hide-not-hide-tabs:   #f
   ))

;; RA => returns the tabdat stored at hashkey passed in commondat-tabdats table (e.g. 0 gives summary)
;;
(define (dboard:common-get-tabdat commondat #!key (tab-num #f))
  (hash-table-ref/default 
   (dboard:commondat-tabdats commondat)
   (or tab-num (dboard:commondat-curr-tab-num commondat)) ;; tab-num value is curr-tab-num value in passed commondat
   #f))

;; RA => sets the tabdat passed to the hashkey at commondat:tabdats hash table
;;
(define (dboard:common-set-tabdat! commondat tabnum tabdat)
  (hash-table-set!
   (dboard:commondat-tabdats commondat)
   tabnum
   tabdat))

;; gets and calls updater list based on curr-tab-num
(define (dboard:common-run-curr-updaters commondat #!key (tab-num #f))
  (if (dboard:common-get-tabdat commondat tab-num: tab-num) ;; only update if there is a tabdat
      (let* ((tnum     (or tab-num (dboard:commondat-curr-tab-num commondat)))
	     (updaters (hash-table-ref/default (dboard:commondat-updaters commondat)
					       tnum
					       '())))
	(debug:print 4 *default-log-port* "Found these updaters: " updaters " for tab-num: " tnum)
	(for-each ;; perform the function calls for the complete updaters list
	 (lambda (updater)
	   ;; (debug:print 3 *default-log-port* "Running " updater)
	   (updater))
	 updaters))))

;; if tab-num passed in then use it, otherwise look in commondat at curr-tab-num
;; adds the updater passed in the updaters list at that hashkey
;;
(define (dboard:commondat-add-updater commondat updater #!key (tab-num #f))
  (let* ((tnum          (or tab-num
			     (dboard:commondat-curr-tab-num commondat)))
	 (curr-updaters (hash-table-ref/default (dboard:commondat-updaters commondat) tnum '())))
    (hash-table-set! (dboard:commondat-updaters commondat)
		     tnum

  (key-lbs           #f)			         
  run-name                                              ;; from run name setting widget
  states                                                ;; states for -state s1,s2 ...
  statuses                                              ;; statuses for -status s1,s2 ...
						         
  ;; Selector variables				         
  curr-run-id                                           ;; current row to display in Run summary view
  prev-run-id                                           ;; previous runid selected before current runid was selected (used in xor-two-runs runs summary mode
  curr-test-ids                                         ;; used only in dcommon:run-update which is used in newdashboard
  ((filters-changed  #t)                  : boolean)    ;; to to indicate that the user changed filters for this tab
  ((last-filter-str  "")                  : string)      ;; conc the target runname and testpatt for a signature of changed filters
  ((hide-empty-runs  #f)                  : boolean)     
  ((hide-not-hide    #t)                  : boolean)     ;; toggle for hide/not hide empty runs
  (hide-not-hide-button #f)
  ((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

  (runs-tree           #f)

  ;; 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)
  ((runs-summary-mode-buttons '())               : list)
  ((runs-summary-mode  'one-run)            : symbol)
  ((runs-summary-mode-change-callbacks '()) : list)
  (runs-summary-source-runname-label #f)
  (runs-summary-dest-runname-label #f)
  ;; runs summary view
  
  tests-tree       ;; used in newdashboard
  )

(define (dboard:tabdat-target-string vec)
  (let ((targ (dboard:tabdat-target vec)))
    (if (list? targ)(string-intersperse targ "/") "no-target-specified")))

;; 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* ((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)))
	 (statuses    (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat)))
         (do-not-use-db-file-timestamps (configf:lookup *configdat* "setup" "do-not-use-db-file-timestamps")) ;; this still hosts runs-summary-tab
         (do-not-use-query-timestamps (configf:lookup *configdat* "setup" "do-not-use-query-timestamps")) ;; this no longer troubles runs-summary-tab
	 (sort-info   (get-curr-sort))
	 (sort-by     (vector-ref sort-info 1))
	 (sort-order  (vector-ref sort-info 2))
	 (bubble-type (if (member sort-order '(testname))
			  'testname
			  'itempath))
	 ;; note: the rundat is normally created in "update-rundat". 
	 (run-dat    (or (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f)
			 (let ((rd (dboard:rundat-make-init run: run key-vals: key-vals)))
			   (hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id rd)
			   rd)))
	 ;; (prev-tests  (dboard:rundat-tests prev-dat)) ;; (vector-ref prev-dat 1))
         (last-update
          (if do-not-use-query-timestamps
              0
              (dboard:rundat-last-update run-dat)
              ;;(hash-table-ref/default (dboard:tabdat-run-update-times tabdat) run-id 0)
              ))

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

     tmptests)
    
    ;; set last-update to 0 if still getting data incrementally

    (if (> (dboard:rundat-run-data-offset run-dat) 0)
	(begin
	  ;; (print "run-data-offset: " (dboard:rundat-run-data-offset run-dat) ", setting last-update to 0")
	  ;; (dboard:rundat-last-update-set! run-dat 0)
          (dboard:rundat-last-update-set! run-dat 0))
        ;; (hash-table-set! (dboard:tabdat-run-update-times tabdat) run-id (- start-time 3))
        
	(dboard:rundat-last-update-set! run-dat (- (current-seconds) 2))) ;; go back two seconds in time to ensure all changes are captured.

    ;; (debug:print-info 0 *default-log-port* "tests-ht: " (hash-table-keys tests-ht))
    tests-ht))

;; tmptests   - new tests data
;; prev-tests - old tests data

		    (dboard:tabdat-allruns-set! tabdat new-res)
		    maxtests)
		  (if (> (dboard:rundat-run-data-offset run-struct) 0)
		      (loop run tal new-res newmaxtests) ;; not done getting data for this run
		      (loop (car tal)(cdr tal) new-res newmaxtests)))))))
    (dboard:tabdat-filters-changed-set! tabdat #f)
    (dboard:update-tree tabdat runs-hash header tb)))




(define *collapsed* (make-hash-table))

(define (toggle-hide lnum uidat) ; fulltestname)
  (let* ((btn (vector-ref (dboard:uidat-get-lftcol uidat) lnum))
	 (fulltestname (iup:attribute btn "TITLE"))
	 (parts        (string-split fulltestname "("))

			  (take-right (dboard:tabdat-allruns tabdat) numruns)
			  (pad-list (dboard:tabdat-allruns tabdat) numruns)))
	 (lftcol      (dboard:uidat-get-lftcol uidat))
	 (tableheader (dboard:uidat-get-header uidat))
	 (table       (dboard:uidat-get-runsvec uidat))
	 (coln        0)
	 (all-test-names (make-hash-table)))

    ;; create a concise list of test names
    ;;
    (for-each
     (lambda (rundat)
       (if rundat
	   (let* ((testdats  (dboard:rundat-tests rundat))
		  (testnames (map test:test-get-fullname (hash-table-values testdats))))

			   (color      (car (gutils:get-color-for-state-status teststate teststatus)))
			   (curr-color (vector-ref buttondat 1)) ;; (iup:attribute button "BGCOLOR"))
			   (curr-title (vector-ref buttondat 2))) ;; (iup:attribute button "TITLE")))
		      (if (not (equal? curr-color color))
			  (iup:attribute-set! button "BGCOLOR" color))
		      (if (not (equal? curr-title buttontxt))
			  (iup:attribute-set! button "TITLE"   buttontxt))
                      ;;(print "RA => testdat " testdat " teststate " teststate " teststatus " teststatus " buttondat " buttondat " curr-color " curr-color  " curr-title " curr-title "buttontxt" buttontxt " title " curr-title )
		      (vector-set! buttondat 0 run-id)
		      (vector-set! buttondat 1 color)
		      (vector-set! buttondat 2 buttontxt)
		      (vector-set! buttondat 3 testdat)
		      (vector-set! buttondat 4 run-key)))
		(set! rown (+ rown 1))))
	    (dboard:tabdat-all-test-names tabdat)))

 ;; #:title "Logs" ;; To be replaced with tabs
 ;; (let ((logs-tb (iup:textbox #:expand "YES"
 ;;				   #:multiline "YES")))
 ;;	 (dboard:tabdat-logs-textbox-set! tabdat logs-tb)
 ;;	 logs-tb))

(define (dboard:runs-tree-browser commondat tabdat)
  (let* ((tb
          (iup:treebox
           #:value 0
           #:name "Runs"
           #:expand "YES"
           #:addexpanded "NO"
           #:selection-cb
           (lambda (obj id state)
             (debug:catch-and-dump
              (lambda ()
                (let* ((run-path (tree:node->path obj id))
                       (run-id    (tree-path->run-id tabdat (cdr run-path))))
                  ;; (dboard:tabdat-view-changed-set! tabdat #t) ;; ?? done below when run-id is a number
                  (dboard:tabdat-target-set! tabdat (cdr run-path)) ;; (print "run-path: " run-path)			    
                  (dboard:tabdat-layout-update-ok-set! tabdat #f)
                  (if (number? run-id)
                      (begin
                        ;; capture last two in tabdat.
                        (dboard:tabdat-prev-run-id-set!
                         tabdat
                         (dboard:tabdat-curr-run-id tabdat))
                        (dboard:tabdat-curr-run-id-set! tabdat run-id)
                        (dboard:tabdat-view-changed-set! tabdat #t))
                      (debug:print-error 5 *default-log-port* "tree-path->run-id returned non-number " run-id))))
              "treebox"))
           ;; (print "path: " (tree:node->path obj id) " run-id: " run-id)
           )))
    (dboard:tabdat-runs-tree-set! tabdat tb)
    tb))

;;======================================================================
;; R U N   C O N T R O L S
;;======================================================================
;;

			;; 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))
         (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))
    (when (not run)
        (BB> "ERROR: NO RUN FOR RUN-ID run-id="run-id)
        (BB> "runs-hash-> " (hash-table->alist runs-hash))
        )
    tests-mindat))

(define (dashboard:runs-summary-xor-matrix-content tabdat runs-hash #!key (hide-clean #f))
  (let* ((src-run-id (dboard:tabdat-prev-run-id tabdat))
         (dest-run-id (dboard:tabdat-curr-run-id tabdat)))
    (if (and src-run-id dest-run-id)
        (dcommon:xor-tests-mindat 
         (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* ((last-runs-update  0);;(dboard:tabdat-last-runs-update tabdat))
	 (runs-dat     (rmt: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)
  (dashboard:do-update-rundat tabdat) 
  (dboard:runs-summary-control-panel-updater tabdat)
  (let* ((last-runs-update  (dboard:tabdat-last-runs-update tabdat))
	 (runs-dat     (rmt: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))
	 ;;        		   runs)
	 ;;        	 ht))
         )
    (dboard:update-tree tabdat runs-hash runs-header tb)
    (if run-id
        (let* ((matrix-content





                (case (dboard:tabdat-runs-summary-mode tabdat) 

                  ((one-run) (dashboard:run-id->tests-mindat run-id tabdat runs-hash))



                  ((xor-two-runs) (dashboard:runs-summary-xor-matrix-content tabdat runs-hash))

                  ((xor-two-runs-hide-clean) (dashboard:runs-summary-xor-matrix-content tabdat runs-hash hide-clean: #t))
                  (else (dashboard:run-id->tests-mindat run-id tabdat runs-hash)))))
          (when matrix-content
            (let* ((indices      (common:sparse-list-generate-index matrix-content)) ;;  proc: set-cell))
                   (row-indices  (cadr indices))
                   (col-indices  (car indices))
                   (max-row      (if (null? row-indices) 1 (common:max (map cadr row-indices))))
                   (max-col      (if (null? col-indices) 1 (common:max (map cadr col-indices))))
                   (max-visible  (max (- (dboard:tabdat-num-tests tabdat) 15) 3)) ;; (dboard:tabdat-num-tests tabdat) is proportional to the size of the window
                   (numrows      1)
                   (numcols      1)
                   (changed      #f)
                   )

              

              
              
              (dboard:tabdat-filters-changed-set! tabdat #f)
              (let loop ((pass-num 0)
                         (changed  #f))
                ;; Update the runs tree
                (dboard:update-tree tabdat runs-hash runs-header tb)
                
                (if (eq? pass-num 1)
                    (begin ;; big reset
                      (iup:attribute-set! run-matrix "CLEARVALUE" "ALL") ;; NOTE: Was CONTENTS
                      (iup:attribute-set! run-matrix "CLEARATTRIB" "CONTENTS")
                      (iup:attribute-set! run-matrix "RESIZEMATRIX" "YES")))

                (if (> max-col (string->number (iup:attribute run-matrix "NUMCOL")))
                    (iup:attribute-set! run-matrix "NUMCOL" max-col ))

                (let ((effective-max-row (if (< max-row max-visible) max-visible max-row)))
                  (if (> effective-max-row (string->number (iup:attribute run-matrix "NUMLIN")))
                      (iup:attribute-set! run-matrix "NUMLIN" effective-max-row )))
                
                ;; Row labels
                (for-each (lambda (ind)
                            (let* ((name (car ind))
                                   (num  (cadr ind))
                                   (key  (conc num ":0")))
                              (if (not (equal? (iup:attribute run-matrix key) name))
                                  (begin
                                    (set! changed #t)
                                    (iup:attribute-set! run-matrix key name)))))
                          row-indices)
                ;; (print "row-indices: " row-indices " col-indices: " col-indices)
                (if (and (eq? pass-num 0) changed)
                    (loop 1 #t)) ;; force second pass
                
                ;; Cell contents
                (for-each (lambda (entry)
                            ;; (print "entry: " entry)
                            (let* ((row-name  (cadr entry))
                                   (col-name  (car entry))
                                   (valuedat  (caddr entry))
                                   (test-id   (list-ref valuedat 0))
                                   (test-name row-name) ;; (list-ref valuedat 1))
                                   (item-path col-name) ;; (list-ref valuedat 2))
                                   (state     (list-ref valuedat 1))
                                   (status    (list-ref valuedat 2))
                                   (value     (gutils:get-color-for-state-status state status))
                                   (row-num   (cadr (assoc row-name row-indices)))
                                   (col-num   (cadr (assoc col-name col-indices)))
                                   (key       (conc row-num ":" col-num)))
                              (hash-table-set! cell-lookup key test-id)
                              (if (not (equal? (iup:attribute run-matrix key) (cadr value)))
                                  (begin
                                    (set! changed #t)
                                    (iup:attribute-set! run-matrix key (cadr value))
                                    (iup:attribute-set! run-matrix (conc "BGCOLOR" key) (car value))))))
                          matrix-content)
                
                ;; Col labels - do after setting Cell contents so they are accounted for in the size calc.
                
                (for-each (lambda (ind)
                            (let* ((name (car ind))
                                   (num  (cadr ind))
                                   (key  (conc "0:" num)))
                              (if (not (equal? (iup:attribute run-matrix key) name))
                                  (begin
                                    (set! changed #t)
                                    (iup:attribute-set! run-matrix key name)
                                    (if (<= num max-col)
                                        (iup:attribute-set! run-matrix "FITTOTEXT" (conc "C" num)))))))
                          col-indices)
                
                (if (and (eq? pass-num 0) changed)
                    (loop 1 #t)) ;; force second pass due to column labels changing
                
                ;; (debug:print 0 *default-log-port* "runs-summary-updater, changed: " changed " pass-num: " pass-num)
                ;; (print "runs-summary-updater, changed: " changed " pass-num: " pass-num)
                (if changed (iup:attribute-set! run-matrix "REDRAW" "ALL")))))))))



;;======================================================================
;; S U M M A R Y 
;;======================================================================
;;
;; General info about the run(s) and megatest area
(define (dashboard:summary commondat tabdat #!key (tab-num #f))

					 ((eval (string->symbol updater)) commondat tabs tab-num view-name views-cfgdat *configdat*)))
				      tab-num: tab-num))
    (if success
	(begin
	  ;; (iup:attribute-set! tabs (conc "TABTITLE" tab-num) view-name)
	  (dboard:common-set-tabdat! commondat tab-num (dboard:tabdat-make-data))))
    result-child))



(define (dboard:runs-summary-buttons-updater tabdat)
  (let loop ((buttons-left (dboard:tabdat-runs-summary-mode-buttons tabdat))
             (modes-left (dboard:tabdat-runs-summary-modes tabdat)))
    (if (or (null? buttons-left) (null? modes-left))
        #t
        (let* ((this-button (car buttons-left))
               (mode-item (car modes-left))
               (this-mode (car mode-item))
               (sel-color    "180 100 100")
               (nonsel-color "170 170 170")
               (current-mode (dboard:tabdat-runs-summary-mode tabdat)))
          (if (eq? this-mode current-mode)
              (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)))
    (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
                                  (rmt:get-run-name-from-id curr-run-id)
                                  "None"))
                (prev-runname (if prev-run-id
                                  (rmt: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" ""))))))

(define (dboard:runs-summary-control-panel-updater tabdat)
  (dboard:runs-summary-xor-labels-updater tabdat)
  (dboard:runs-summary-buttons-updater tabdat))


;; setup buttons and callbacks to switch between modes in runs summary tab
;;
(define (dashboard:runs-summary-control-panel tabdat)
  (let* ((summary-buttons ;; build buttons
          (map
           (lambda (mode-item)
             (let* ((this-mode (car mode-item))
                    (this-mode-label (cdr mode-item)))
               (iup:button this-mode-label
                           #:action
                           (lambda (obj)
                             (debug:catch-and-dump
                              (lambda ()
                                (dboard:tabdat-runs-summary-mode-set! tabdat this-mode)
                                (dboard:runs-summary-control-panel-updater tabdat))
                              "runs summary control panel updater")))))
           (dboard:tabdat-runs-summary-modes tabdat)))
         (summary-buttons-hbox (apply iup:hbox summary-buttons))
         (xor-runname-labels-hbox
          (iup:hbox
           (let ((temp-label
                  (iup:label "" #:size "125x15" #:fontsize "10" )))
             (dboard:tabdat-runs-summary-source-runname-label-set! tabdat temp-label)
             temp-label
             )
           (let ((temp-label
                  (iup:label "" #:size "125x15" #:fontsize "10")))
             (dboard:tabdat-runs-summary-dest-runname-label-set! tabdat temp-label)
             temp-label))))
    (dboard:tabdat-runs-summary-mode-buttons-set! tabdat summary-buttons)

    ;; maybe wrap in a frame
    (let ((res (iup:vbox summary-buttons-hbox xor-runname-labels-hbox )))
      (dboard:runs-summary-control-panel-updater tabdat)
      res
      )))



;;======================================================================
;; R U N
;;======================================================================
;;
;; display and manage a single run at a time

;; This is the Run Summary tab
;; 
(define (dashboard:runs-summary commondat tabdat #!key (tab-num #f))
  (let* ((update-mutex (dboard:commondat-update-mutex commondat))
	 (tb      (iup:treebox
		   #:value 0
		   #:name "Runs"
		   #:expand "YES"
		   #:addexpanded "NO"
		   #:selection-cb
		   (lambda (obj id state)
		     (debug:catch-and-dump
		      (lambda ()
			;; (print "obj: " obj ", id: " id ", state: " state)
			(let* ((run-path (tree:node->path obj id))
			       (run-id   (tree-path->run-id tabdat (cdr run-path))))
			  (if (number? run-id)
			      (begin
                                (dboard:tabdat-prev-run-id-set!
                                 tabdat
                                 (dboard:tabdat-curr-run-id tabdat))

				(dboard:tabdat-curr-run-id-set! tabdat run-id)
				(dboard:tabdat-layout-update-ok-set! tabdat #f)
				;; (dashboard:update-run-summary-tab)
				)
			      ;; (debug:print-error 0 *default-log-port* "tree-path->run-id returned non-number " run-id)
			      )))
		      "selection-cb in runs-summary")
		     ;; (print "path: " (tree:node->path obj id) " run-id: " run-id)
		     )))
	 (cell-lookup (make-hash-table))
	 (run-matrix (iup:matrix
		      #:expand "YES"
		      #:click-cb
                      
		      (lambda (obj lin col status)
                        (debug:catch-and-dump
                         (lambda ()

                           ;; 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* ((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 (rmt:get-run-info run-id))
                                  (target   (rmt: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 (rmt: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))
                                                    "%")))
                                  (item-path (db:test-get-item-path (rmt:get-test-info-by-id run-id test-id)))
                                  (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
                              ((member #\1 status-chars) ;; 1 is left mouse button
                               (system testpanel-cmd))
                              
                              ((member #\2 status-chars) ;; 2 is middle mouse button
                               
                               (BB> "mmb- test-name="test-name" testpatt="testpatt)
                               (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")
                               )
                              (else
                               (BB> "unhandled status in run-summary-click-cb.  Doing right click action. (status is corrupted on Brandon's ubuntu host - bad/buggy  iup install??" )
                               (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")
                               )
                              )
                            
                             )) "runs-summary-click-callback"))))
	 (runs-summary-updater  
          (lambda ()
	    (mutex-lock! update-mutex)
            (if  (or (dashboard:database-changed? commondat tabdat)
                     (dboard:tabdat-view-changed tabdat))
                 (debug:catch-and-dump
                  (lambda () ;; check that run-matrix is initialized before calling the updater
		    (if run-matrix 
			(dashboard:runs-summary-updater commondat tabdat tb cell-lookup run-matrix)))
                  "dashboard:runs-summary-updater")
                 )
	    (mutex-unlock! update-mutex)))
         (runs-summary-control-panel (dashboard:runs-summary-control-panel tabdat))
         )
    (dboard:commondat-add-updater commondat runs-summary-updater tab-num: tab-num)
    (dboard:tabdat-runs-tree-set! tabdat tb)
    (iup:vbox
     (iup:split
      #:value 200
      tb
      run-matrix)
     (dboard:make-controls commondat tabdat extra-widget: runs-summary-control-panel))))

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

(define (dboard:make-controls commondat tabdat #!key (extra-widget #f) )
  (let ((btn-fontsz  (dboard:tabdat-runs-btn-fontsz tabdat)))
    (iup:hbox
     (iup:vbox
      (iup:frame 
       #:title "filter test and items"
       (iup:vbox
        (iup:hbox
	(iup:vbox
	 (iup:textbox #:size "120x15" #:fontsize "10" #:value "%"
		      #:expand "NO"
		      #:action (lambda (obj unk val)
				 (debug:catch-and-dump
				  (lambda ()
				    (mark-for-update tabdat)

		(sort-lb    (iup:listbox #:expand "NO" ;; "HORIZONTAL"
					 #:size   "80x15"
					 #:dropdown "YES"
					 #:action (lambda (obj val index lbstate)
						    (set! *tests-sort-reverse* index)
						    (mark-for-update tabdat))))
		(default-cmd (car (list-ref *tests-sort-type-index* *tests-sort-reverse*))))
                
	   (iuplistbox-fill-list sort-lb cmds-list selected-item: default-cmd)
	   
	   (set! hide-empty (iup:button "HideEmpty"
					;; #:expand HORIZONTAL"
					#:expand "NO" #:size "80x15"
					#:action (lambda (obj)
						   (dboard:tabdat-hide-empty-runs-set! tabdat (not (dboard:tabdat-hide-empty-runs tabdat)))

					     (dboard:tabdat-hide-not-hide-set! tabdat #f) ;; (not (dboard:tabdat-hide-not-hide tabdat)))
					     (iup:attribute-set! show "BGCOLOR" sel-color)
					     (iup:attribute-set! hide "BGCOLOR" nonsel-color)
					     (mark-for-update tabdat))))
	   (iup:attribute-set! hide "BGCOLOR" sel-color)
	   (iup:attribute-set! show "BGCOLOR" nonsel-color)
	   ;; (dboard:tabdat-hide-not-hide-button-set! tabdat hideit) ;; never used, can eliminate ...
           (iup:vbox
            (iup:hbox hide show)
            sort-lb))) 
	)

        ;; insert extra widget here
        (if extra-widget
            extra-widget
            (iup:hbox)) ;; empty widget

        

        
        )))

     (iup:frame 
      #:title "state/status filter"
      (iup:vbox
       (apply 
	iup:hbox
	(map (lambda (status)
	       (iup:toggle (conc status "  ")

					   (mark-for-update tabdat)
					   (debug:print 6 *default-log-port* "(dboard:tabdat-start-run-offset tabdat) " (dboard:tabdat-start-run-offset tabdat) " maxruns: " maxruns ", val: " val " oldmax: " oldmax)
					   (iup:attribute-set! obj "MAX" (* maxruns 10))))
		     #:expand "HORIZONTAL"
		     #:max (* 10 (max (hash-table-size (dboard:tabdat-allruns-by-id tabdat)) 10))
		     #:min 0
		     #:step 0.01)))
     ;;(iup:button "inc rows" #:action (lambda (obj)(dboard:tabdat-num-tests-set! tabdat (+ (dboard:tabdat-num-tests tabdat) 1))))
					;(iup:button "dec rows" #:action (lambda (obj)(dboard:tabdat-num-tests-set! tabdat (if (> (dboard:tabdat-num-tests tabdat) 0)(- (dboard:tabdat-num-tests tabdat) 1) 0))))
     )))

(define (dashboard:popup-menu  run-id test-id target runname test-name testpatt item-test-path)
  (iup:menu 
   (iup:menu-item
    "Test Control Panel"
    #:action
    (lambda (obj)
      (let* ((toolpath (car (argv)))
             (testpanel-cmd
              (conc toolpath " -test " run-id "," test-id " &")))
        (system testpanel-cmd)
        )))
   
   (iup:menu-item
    (conc "View Log (not yet implemented) " item-test-path)
    )
   
   (iup:menu-item
    (conc "Rerun " item-test-path)
    #:action
    (lambda (obj)
      (common:run-a-command
       (conc "megatest -set-state-status NOT_STARTED,n/a -run -target " target
             " -runname " runname
             " -testpatt " item-test-path
             " -preclean -clean-cache"))))
   
   (iup:menu-item
    "Start xterm"
    #:action
    (lambda (obj)
      (dcommon:examine-xterm run-id test-id)))

   (iup:menu-item
    (conc "Kill " item-test-path)
    #:action
    (lambda (obj)
      ;; (rmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f)
      (common:run-a-command
       (conc "megatest -set-state-status KILLREQ,n/a -target " target
             " -runname " runname
             " -testpatt " item-test-path 
             " -state RUNNING,REMOTEHOSTSTART,LAUNCHED"))))

   
   (iup:menu-item
    "Run"
    (iup:menu              
     (iup:menu-item
      (conc "Rerun " testpatt)
      #:action
      (lambda (obj)
        ;; (print  " run-id: " run-id " test-id: " test-id " target: " target " runname: " runname " test-name: " test-name " testpatt: " testpatt "item-path : " item-path)
	(common:run-a-command
	 (conc "megatest -run -target " target
	       " -runname " runname
	       " -testpatt " testpatt
	       " -preclean -clean-cache")
	 )))
     (iup:menu-item

     (iup:menu-item
      "Clean Complete Run"
      #:action
      (lambda (obj)
        (common:run-a-command
         (conc "megatest -remove-runs -target " target
               " -runname " runname
               " -testpatt % "))))
     (iup:menu-item ;; RADT => itemize this run lists before merging with v1.61
      "Kill Complete Run"
      #:action
      (lambda (obj)
        (common:run-a-command
         (conc "megatest -set-state-status KILLREQ,n/a -target " target
               " -runname " runname
               " -testpatt % "
               "  -state RUNNING,REMOTEHOSTSTART,LAUNCHED"))))))
   (iup:menu-item
    "Test"
    (iup:menu 
     (iup:menu-item
      (conc "Rerun " item-test-path)
      #:action
      (lambda (obj)

			  " " tconfig " &")))
	  (system cmd))))
     ))))

(define (make-dashboard-buttons commondat) ;;  runs-sum-dat new-view-dat)
  (let* ((stats-dat       (dboard:tabdat-make-data))
	 (runs-dat        (dboard:tabdat-make-data))
	 (onerun-dat      (dboard:tabdat-make-data)) ;; name for run-summary structure 
	 (runcontrols-dat (dboard:tabdat-make-data))
	 (runtimes-dat    (dboard:tabdat-make-data))
	 (nruns           (dboard:tabdat-numruns runs-dat))
	 (ntests          (dboard:tabdat-num-tests runs-dat))
	 (keynames        (dboard:tabdat-dbkeys runs-dat))
	 (nkeys           (length keynames))
	 (runsvec         (make-vector nruns))

								     "%"
								     tpatt))
							       "%")))
                                              (item-path (db:test-get-item-path (rmt: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")
					 ;; (print "got here")
					 ))
				   (if (eq? pressed 0)
				       (let* ((toolpath (car (argv)))

						 (let* ((tab-num (dboard:commondat-curr-tab-num commondat))
							(tabdat  (dboard:common-get-tabdat commondat tab-num: tab-num)))
						   (dboard:commondat-please-update-set! commondat #t)
						   (dboard:tabdat-layout-update-ok-set! tabdat #t)))
					       "tabchangepos"))
			  (dashboard:summary commondat stats-dat tab-num: 0)
			  runs-view
			  (dashboard:runs-summary commondat onerun-dat tab-num: 2)
			  ;; (dashboard:new-view db data new-view-dat tab-num: 3)
			  (dashboard:run-controls commondat runcontrols-dat tab-num: 3)
			  (dashboard:run-times commondat runtimes-dat tab-num: 4)
			  additional-views)))
	;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c)))
	(iup:attribute-set! tabs "TABTITLE0" "Summary")
	(iup:attribute-set! tabs "TABTITLE1" "Runs")

     recalc))

;; point inside line
;;
(define-inline (dashboard:px-between px lx1 lx2)
  (and (< lx1 px)(> lx2 px)))

;;Not reference anywhere
;;
;; can a bar be placed in row "rownum" covering x1 to x2 without overlapping with existing 
;; bars? Use num-rows to check that a block will fit from rownum to (+ rownum num-rows)
;;
(define (dashboard:row-collision rowhash rownum x1 x2 #!key (num-rows #f))
  (let ((lastrow   (if num-rows (+ rownum num-rows) rownum)))
    (let loop ((i      0)
	       (rowdat (hash-table-ref/default rowhash rownum '())))

				      (begin
					(if (dboard:tabdat-layout-update-ok tabdat)
					    (runloop (car runtal)(cdr runtal) (+ run-num 1) newdoneruns)
					    (escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat)
					    ))))))))) ;;  new-run-start-row
		)))
	(debug:print 2 *default-log-port* "no tabdat for run-times-tab-updater"))))

(define (tabdat-values tabdat)
  (let ((allruns (dboard:tabdat-allruns tabdat))
        (allruns-by-id (dboard:tabdat-allruns-by-id tabdat))
        (done-runs (dboard:tabdat-done-runs tabdat))
        (not-done-runs (dboard:tabdat-not-done-runs tabdat))
        (header  (dboard:tabdat-header  tabdat))
        (keys (dboard:tabdat-keys tabdat))
        (numruns (dboard:tabdat-numruns tabdat))
        (tot-runs (dboard:tabdat-tot-runs tabdat))
        (last-data-update (dboard:tabdat-last-data-update tabdat))
        (runs-mutex (dboard:tabdat-runs-mutex tabdat))
        (run-update-times (dboard:tabdat-run-update-times tabdat))
        (last-test-dat (dboard:tabdat-last-test-dat tabdat))
        (run-db-paths (dboard:tabdat-run-db-paths tabdat))
        (buttondat (dboard:tabdat-buttondat tabdat))
        (item-test-names (dboard:tabdat-item-test-names tabdat))
        (run-keys (dboard:tabdat-run-keys tabdat))
        (start-run-offset (dboard:tabdat-start-run-offset tabdat))
        (start-test-offset (dboard:tabdat-start-test-offset tabdat))
        (runs-btn-height (dboard:tabdat-runs-btn-height tabdat))
        (all-test-names (dboard:tabdat-all-test-names tabdat))
        (cnv (dboard:tabdat-cnv tabdat))
        (command (dboard:tabdat-command tabdat))
        (run-name (dboard:tabdat-run-name tabdat))
        (states (dboard:tabdat-states tabdat))
        (statuses (dboard:tabdat-statuses tabdat))
        (curr-run-id (dboard:tabdat-curr-run-id tabdat))
        (curr-test-ids (dboard:tabdat-curr-test-ids tabdat))
        (state-ignore-hash (dboard:tabdat-state-ignore-hash tabdat))
        (test-patts (dboard:tabdat-test-patts tabdat))
        (target (dboard:tabdat-target tabdat))
        (dbdir (dboard:tabdat-dbdir tabdat))
        (monitor-db-path (dboard:tabdat-monitor-db-path tabdat))
        (path-run-ids (dboard:tabdat-path-run-ids tabdat)))
        (print "allruns is : " allruns)
        (print "allruns-by-id is : " allruns-by-id)
        (print "done-runs is : " done-runs)
        (print "not-done-runs is : " not-done-runs)
        (print "header  is : " header )
        (print "keys is : " keys)
        (print "numruns is : " numruns)
        (print "tot-runs is : " tot-runs)
        (print "last-data-update is : " last-data-update)
        (print "runs-mutex is : " runs-mutex)
        (print "run-update-times is : " run-update-times)
        (print "last-test-dat is : " last-test-dat)
        (print "run-db-paths is : " run-db-paths)
        (print "buttondat is : " buttondat)
        (print "item-test-names is : " item-test-names)
        (print "run-keys is : " run-keys)
        (print "start-run-offset is : " start-run-offset)
        (print "start-test-offset is : " start-test-offset)
        (print "runs-btn-height is : " runs-btn-height)
        (print "all-test-names is : " all-test-names)
        (print "cnv is : " cnv)
        (print "command is : " command)
        (print "run-name is : " run-name)
        (print "states is : " states)
        (print "statuses is : " statuses)
        (print "curr-run-id is : " curr-run-id)
        (print "curr-test-ids is : " curr-test-ids)
        (print "state-ignore-hash is : " state-ignore-hash)
        (print "test-patts is : " test-patts)
        (print "target is : " target)
        (print "dbdir is : " dbdir)
        (print "monitor-db-path is : " monitor-db-path)
        (print "path-run-ids is : " path-run-ids)))

(define (dashboard:do-update-rundat tabdat)
  (update-rundat
   tabdat
   (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%")
   (dboard:tabdat-numruns tabdat)
   (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%")
   ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "item-name" "%")
   (let* ((dbkeys (dboard:tabdat-dbkeys tabdat)))
     ;; (print "dbkeys: " dbkeys)
     (let ((fres   (if (dboard:tabdat-target tabdat)
                       (let ((ptparts (append (dboard:tabdat-target tabdat)(make-list (length dbkeys) "%"))))
                         (map (lambda (k v)(list k v)) dbkeys ptparts))
                       (let ((res '()))
                         ;; (print "target: " (dboard:tabdat-target tabdat))
                         (for-each (lambda (key)
                                     (if (not (equal? key "runname"))
                                         (let ((val (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) key #f)))
                                           (if val (set! res (cons (list key val) res))))))
                                   dbkeys)
                         res))))
       ;; (debug:print 0 *default-log-port* "fres: " fres)
       fres))))

(define (dashboard:runs-tab-updater commondat tab-num)
  (debug:catch-and-dump 
   (lambda ()
     (let* ((tabdat (dboard:common-get-tabdat commondat tab-num: tab-num))
	    (dbkeys (dboard:tabdat-dbkeys tabdat)))
       ;;(print "RA => calling runs-tab-updater with commondat " commondat " tab-num " tab-num)
       ;;(tabdat-values tabdat) ;;RA added 
       (dashboard:do-update-rundat tabdat)



















       (let ((uidat (dboard:commondat-uidat commondat)))
         ;;(print "RA => Calling update-buttons with tabdat : " tabdat " uidat " uidat)
	 (update-buttons tabdat uidat (dboard:tabdat-numruns tabdat) (dboard:tabdat-num-tests tabdat)))
       ))
   "dashboard:runs-tab-updater"))

;; ((2)
;;  (dashboard:update-run-summary-tab))
;; ((3)
;;  (dashboard:update-new-view-tab))
;; (else
;;  (dboard:common-run-curr-updater commondat)))
;; (set! *last-recalc-ended-time* (current-milliseconds))))))))

;;======================================================================
;; The heavy lifting starts here
;;======================================================================

(define (main)
  (let ((mtdb-path (conc *toppath* "/megatest.db"))) ;; 
    (if (and (file-exists? mtdb-path)
	     (file-write-access? mtdb-path))
	(if (not (args:get-arg "-skip-version-check"))
	    (let ((th1 (make-thread common:exit-on-version-changed)))
	      (thread-start! th1)
	      (if (> megatest-version (common:get-last-run-version-number))
		  (debug:print-info 0 *default-log-port* "Version bump detected, blocking until db sync complete")
		  (thread-join! th1)))))
    (let* ((commondat       (dboard:commondat-make)))
      ;; Move this stuff to db.scm? I'm not sure that is the right thing to do...
      (cond 
       ((args:get-arg "-test") ;; run-id,test-id
	(let* ((dat     (let ((d (map string->number (string-split (args:get-arg "-test") ",")))) ;; RADT couldn't find string->number, though it works
			  (if (> (length d) 1)
			      d
			      (list #f #f))))
	       (run-id  (car dat))
	       (test-id (cadr dat)))
	  (if (and (number? run-id)
		   (number? test-id)
		   (>= test-id 0))
	      (dashboard-tests:examine-test run-id test-id)
	      (begin
		(debug:print 3 *default-log-port* "INFO: tried to open test with invalid run-id,test-id. " (args:get-arg "-test"))
		(exit 1)))))
       ;; ((args:get-arg "-guimonitor")
       ;;  (gui-monitor (dboard:tabdat-dblocal tabdat)))
       (else
	(dboard:commondat-uidat-set! commondat (make-dashboard-buttons commondat)) ;; (dboard:tabdat-dblocal data)
	;; (dboard:tabdat-numruns tabdat)
	;; (dboard:tabdat-num-tests tabdat)
	;; (dboard:tabdat-dbkeys tabdat)
	;; runs-sum-dat new-view-dat))
	;; legacy setup of updaters for summary tab and runs tab
	;; summary tab
	;; (dboard:commondat-add-updater 
	;;  commondat 
	;;  (lambda ()
	;; 	 (dashboard:summary-tab-updater commondat 0))
	;;  tab-num: 0)
	;; runs tab
	(dboard:commondat-curr-tab-num-set! commondat 0)
	(dboard:commondat-add-updater 
	 commondat 
	 (lambda ()
	   (dashboard:runs-tab-updater commondat 1))
	 tab-num: 1)
	(iup:callback-set! *tim*
			   "ACTION_CB"
			   (lambda (time-obj)
			     (let ((update-is-running #f))
			       (mutex-lock! (dboard:commondat-update-mutex commondat))
			       (set! update-is-running (dboard:commondat-updating commondat))
			       (if (not update-is-running)
				   (dboard:commondat-updating-set! commondat #t))
			       (mutex-unlock! (dboard:commondat-update-mutex commondat))
			       (if (not update-is-running) ;; we know that the update was not running and we now have a lock on doing an update
				   (begin
				     (dboard:common-run-curr-updaters commondat) ;; (dashboard:run-update commondat)
				     (mutex-lock! (dboard:commondat-update-mutex commondat))
				     (dboard:commondat-updating-set! commondat #f)
				     (mutex-unlock! (dboard:commondat-update-mutex commondat)))
				   ))
			     1))))
      
      (let ((th1 (make-thread (lambda ()
				(thread-sleep! 1)
				(dboard:common-run-curr-updaters commondat 0) ;; force update of summary tab 
				;; (dboard:commondat-please-update-set! commondat #t) ;; MRW: ww36.3 - why was please update set true here? Removing it for now.
				;; (dashboard:run-update commondat)
				) "update buttons once"))
	    (th2 (make-thread iup:main-loop "Main loop")))
	;; (thread-start! th1)
	(thread-start! th2)
	(thread-join! th2)))))

;; ease debugging by loading ~/.dashboardrc
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc")))
  (if (file-exists? debugcontrolf)
      (load debugcontrolf)))







































































(main)

;;======================================================================
;; Copyright 2006-2016, 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.
;;======================================================================

;;======================================================================
;; Database access
;;======================================================================

;; dbstruct vector containing all the relevant dbs like main.db, megatest.db, run.db etc

(require-extension (srfi 18) extras tcp) ;; RADT => use of require-extension?
(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64 format dot-locking z3 typed-records)
(import (prefix sqlite3 sqlite3:))
(import (prefix base64 base64:)) ;; RADT => prefix??

(declare (unit db))
(declare (uses common))
(declare (uses keys))
(declare (uses ods))
(declare (uses client))
(declare (uses mt))

(include "common_records.scm")
(include "db_records.scm")
(include "key_records.scm")
(include "run_records.scm")

(define *rundb-mutex* (make-mutex)) ;; prevent problems opening/closing rundb's
(define *number-of-writes* 0)
(define *number-non-write-queries* 0)

;;======================================================================
;;  R E C O R D S
;;======================================================================

(defstruct dbr:dbstruct 
  main
  strdb
  ((path #f)  : string)
  ((local #f) : boolean)
  rundb
  inmem
  mtime
  rtime 
  stime
  inuse
  refdb
  ((locdbs (make-hash-table)) : hash-table)
  olddb)

;;======================================================================
;; SQLITE3 HELPERS
;;======================================================================

(define (db:general-sqlite-error-dump exn stmt . params)
  (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) ;; RADT ... how does this work?
    ;; check for (exn sqlite3) ((condition-property-accessor 'exn 'message) exn)
    (print "err-status: " err-status)
    (debug:print-error 0 *default-log-port* " query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn))
    (print-call-chain (current-error-port))))

;; convert to -inline
;;
(define (db:first-result-default db stmt default . params)
  (handle-exceptions
   exn
   (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn)))
     ;; check for (exn sqlite3) ((condition-property-accessor 'exn 'message) exn)
     (if (eq? err-status 'done)
	 default
	 (begin
	   (debug:print-error 0 *default-log-port* " query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn))
	   (print-call-chain (current-error-port))
	   default)))
   (apply sqlite3:first-result db stmt params)))

;; Get/open a database
;;    if run-id => get run specific db
;;    if #f     => get main db
;;    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
      (begin
	(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)
  (if (pair? dbdat)
      (car dbdat)
      dbdat))

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

;; mod-read:
;;     'mod   modified data
;;     'read  read data
;; Locks the mutex and depending on 'mod or 'read passed, sets the last timestamp in dbstruct
;;
(define (db:done-with dbstruct run-id mod-read)
  (if (not (sqlite3:database? dbstruct))
      (begin
	(mutex-lock! *rundb-mutex*)
	(if (eq? mod-read 'mod)
	    (dbr:dbstruct-mtime-set! dbstruct (current-milliseconds))
	    (dbr:dbstruct-rtime-set! dbstruct (current-milliseconds)))
	(dbr:dbstruct-inuse-set! dbstruct #f)
	(mutex-unlock! *rundb-mutex*))))

;; (db:with-db dbstruct run-id sqlite3:exec "select blah from blaz;")
;; r/w is a flag to indicate if the db is modified by this query #t = yes, #f = no
;;
(define (db:with-db dbstruct run-id r/w proc . params)
  (let* ((dbdat (if (dbr:dbstruct? dbstruct)
		    (db:get-db dbstruct run-id)
		    dbstruct)) ;; cheat, allow for passing in a dbdat
	 (db    (db:dbdat-get-db dbdat)))

    (handle-exceptions
     exn
     (begin
       (debug:print-error 0 *default-log-port* "sqlite3 issue in db:with-db, dbstruct=" dbstruct ", run-id=" run-id ", proc=" proc ", params=" params " error: " ((condition-property-accessor 'exn 'message) exn))
       (print-call-chain (current-error-port)))
     (let ((res (apply proc db params)))
       (if (vector? dbstruct)(db:done-with dbstruct run-id r/w))

;; ;;
;; (define (db:get-path dbstruct id)
;;   (let ((fdb (db:get-filedb dbstruct)))
;;     (filedb:get-path db id)))

;; NB// #f => return dbdir only
;;      (was planned to be;  zeroth db with name=main.db)
;; 
;; If run-id is #f return to create and retrieve the path where the db will live.
;;
(define (db:dbfile-path run-id)
  (let* ((dbdir           (db:get-dbdir))
	 (fname           (if run-id
			      (if (eq? run-id 0) "main.db" (conc run-id ".db"))
			      #f)))
    (handle-exceptions
     exn
     (begin
       (debug:print-error 0 *default-log-port* "Couldn't create path to " dbdir)
       (exit 1))
     (if (not (directory? dbdir))(create-directory dbdir #t)))
    (if fname
	(conc dbdir "/" fname)
	dbdir)))

;; Returns the database location as specified in config file
;;
(define (db:get-dbdir)
  (or (configf:lookup *configdat* "setup" "dbdir")
      (conc (configf:lookup *configdat* "setup" "linktree") "/.db")))
	       
(define (db:set-sync db)
  (let ((syncprag (configf:lookup *configdat* "setup" "sychronous")))
    (sqlite3:execute db (conc "PRAGMA synchronous = " (or syncprag 1) ";")))) 

;; open an sql database inside a file lock

;; returns: db existed-prior-to-opening
;; RA => Returns a db handler; sets the lock if opened in writable mode
;;
(define (db:lock-create-open fname initproc)
  ;; (if (file-exists? fname)
  ;;     (let ((db (sqlite3:open-database fname)))
  ;;       (sqlite3:set-busy-handler! db (make-busy-timeout 136000))
  ;;       (db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = 0;")
  ;;       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
;; 
(define (db:open-rundb dbstruct run-id #!key (attemptnum 0)(do-not-open #f)) ;;  (conc *toppath* "/megatest.db") (car *configinfo*)))
  (let* ((local  (dbr:dbstruct-local dbstruct))
	 (rdb    (if local
		     (dbr:dbstruct-localdb dbstruct run-id)
		     (dbr:dbstruct-inmem dbstruct)))) ;; (dbr:dbstruct-runrec dbstruct run-id 'inmem)))
    (if (or rdb
	    do-not-open)
	rdb
	(begin
	  (mutex-lock! *rundb-mutex*)
	  (let* ((dbpath       (db:dbfile-path run-id)) ;; (conc toppath "/db/" run-id ".db"))
		 (dbexists     (file-exists? dbpath))

				     (set! *megatest-db* db)
				     db)))
		 (write-access (file-write-access? dbpath))
		 ;; (handler      (make-busy-timeout 136000))
		 )
	    (if (and dbexists (not write-access))
		(set! *db-write-access* #f)) ;; only unset so other db's also can use this control
	    (dbr:dbstruct-rundb-set!  dbstruct (cons db dbpath))
	    (dbr:dbstruct-inuse-set!  dbstruct #t)
	    (dbr:dbstruct-olddb-set!  dbstruct olddb)
	    ;; (dbr:dbstruct-run-id-set! dbstruct run-id)
	    (mutex-unlock! *rundb-mutex*)
	    (if local
		(begin
		  (dbr:dbstruct-localdb-set! dbstruct run-id db) ;; (dbr:dbstruct-inmem-set! dbstruct db) ;; direct access ...
		  db)
		(begin
		  (dbr:dbstruct-inmem-set!  dbstruct inmem)
		  ;; dec 14, 2014 - keep deleted records available. hunch is that they are needed for id placeholders
		  ;; (sqlite3:execute db "DELETE FROM tests WHERE state='DELETED';") ;; they just slow us down in this context
		  (db:sync-tables db:sync-tests-only db inmem)
		  (db:delay-if-busy refdb) ;; dbpath: (db:dbdat-get-path refdb)) ;; What does delaying here achieve? 
		  (dbr:dbstruct-refdb-set!  dbstruct refdb)
		  (db:sync-tables db:sync-tests-only inmem refdb) ;; use inmem as the reference, don't read again from db
		  ;; sync once more to deal with delays?
		  ;; (db:sync-tables db:sync-tests-only db inmem)
		  ;; (db:sync-tables db:sync-tests-only inmem refdb)
		  inmem)))))))

;; This routine creates the db if not already present. It is only called if the db is not already ls opened
;;
(define (db:open-main dbstruct) ;;  (conc *toppath* "/megatest.db") (car *configinfo*))) 
  (let ((mdb (dbr:dbstruct-main dbstruct))) ;; RA => Returns the first reference in dbstruct
    (if mdb
	mdb
	(begin
	  (mutex-lock! *rundb-mutex*)
	  (let* ((dbpath       (db:dbfile-path 0))
		 (dbexists     (file-exists? dbpath))
		 (db           (db:lock-create-open dbpath db:initialize-main-db))
		 (olddb        (db:open-megatest-db))
		 (write-access (file-write-access? dbpath))
		 (dbdat        (cons db dbpath)))
	    (if (and dbexists (not write-access))
		(set! *db-write-access* #f))
	    (dbr:dbstruct-main-set!   dbstruct dbdat)
	    (dbr:dbstruct-olddb-set!  dbstruct olddb) ;; olddb is already a (cons db path)
	    (mutex-unlock! *rundb-mutex*)
	    (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

    (if (and dbexists (not write-access))
	(set! *db-write-access* #f))
    (cons db dbpath)))

;; sync run to disk if touched
;;
(define (db:sync-touched dbstruct run-id #!key (force-sync #f))
  (let ((mtime  (dbr:dbstruct-mtime dbstruct))
	(stime  (dbr:dbstruct-stime dbstruct))
	(rundb  (dbr:dbstruct-rundb dbstruct))
	(inmem  (dbr:dbstruct-inmem dbstruct))
	(maindb (dbr:dbstruct-main  dbstruct))
	(refdb  (dbr:dbstruct-refdb dbstruct))
	(olddb  (dbr:dbstruct-olddb dbstruct))
	;; (runid  (dbr:dbstruct-run-id dbstruct))
	)
    (debug:print-info 4 *default-log-port* "Syncing for run-id: " run-id)
    ;; (mutex-lock! *http-mutex*)
    (if (eq? run-id 0)
	;; runid equal to 0 is main.db
	(if maindb
	    (if (or (not (number? mtime))
		    (not (number? stime))
		    (> mtime stime)
		    force-sync)
		(begin
		  (db:delay-if-busy maindb)
		  (db:delay-if-busy olddb)
		  (let ((num-synced (db:sync-tables (db:sync-main-list maindb) maindb olddb)))
		    (dbr:dbstruct-stime-set! dbstruct (current-milliseconds))
		    num-synced)
		  0))
	    (begin
	      ;; this can occur when using local access (i.e. not in a server)
	      ;; need a flag to turn it off.
	      ;;
	      (debug:print 3 *default-log-port* "WARNING: call to sync main.db to megatest.db but main not initialized")
	      0))
	;; any other runid is a run
	(if (or (not (number? mtime))
		(not (number? stime))
		(> mtime stime)
		force-sync)
	    (begin
	      (db:delay-if-busy rundb)
	      (db:delay-if-busy olddb)
	      (dbr:dbstruct-stime-set! dbstruct (current-milliseconds))
	      (let ((num-synced (db:sync-tables db:sync-tests-only inmem refdb rundb olddb)))
		;; (mutex-unlock! *http-mutex*)
		num-synced)
	      (begin
		;; (mutex-unlock! *http-mutex*)
		0))))))

(define (db:close-main dbstruct)
  (let ((maindb (dbr:dbstruct-main dbstruct)))
    (if maindb
	(begin
	  (sqlite3:finalize! (db:dbdat-get-db maindb))
	  (dbr:dbstruct-main-set! dbstruct #f)))))

(define (db:close-run-db dbstruct run-id)
  (let ((rdb (db:open-rundb dbstruct run-id do-not-open: #t)))
    (if (and rdb
	     (sqlite3:database? rdb))
	(begin
	  (sqlite3:finalize! rdb)
	  (dbr:dbstruct-localdb-set! dbstruct run-id #f)
	  (dbr:dbstruct-inmem-set! dbstruct #f)))))

;; close all opened run-id dbs
(define (db:close-all dbstruct)
  ;; finalize main.db
  (db:sync-touched dbstruct 0 force-sync: #t)
  ;;(common:db-block-further-queries)
  ;; (mutex-lock! *db-sync-mutex*) ;; with this perhaps it isn't necessary to use the block-further-queries mechanism?

  (db:close-main dbstruct)
  
  (let ((locdbs (dbr:dbstruct-locdbs dbstruct)))
    (if (hash-table? locdbs)
	(for-each (lambda (run-id)
		    (db:close-run-db dbstruct run-id))
		  (hash-table-keys locdbs)))))

(define (db:open-inmem-db)
  (let* ((db      (sqlite3:open-database ":memory:"))

	  (for-each 
	   (lambda (run-id)
	     (db:delay-if-busy mtdb)
	     (let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id))
		   (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t) #f)))
	       (debug:print 0 *default-log-port* "INFO: Propagating " (length testrecs) " records for run-id=" run-id " to run specific db")
	       (db:replace-test-records dbstruct run-id testrecs)
	       (sqlite3:finalize! (db:dbdat-get-db (dbr:dbstruct-rundb dbstruct)))))
	   run-ids)))

    ;; now ensure all newdb data are synced to megatest.db
    ;; do not use the run-ids list passed in to the function
    ;;
    (if (member 'new2old options)
	(let* ((maindb      (make-dbr:dbstruct path: toppath local: #t))

			   ;; this test is younger, store it in the hash
			   (hash-table-set! tests-hash full-testname testdat))))
		   results)
		  (if (null? tal)
		      (map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests
		      (loop (car tal)(cdr tal))))))))))

;; Function recursively checks if <db>.journal exists; if yes means db busy; call itself after delayed interval
;; return the sqlite3 db handle if possible
;; 
(define (db:delay-if-busy dbdat #!key (count 6))
  (if (not (configf:lookup *configdat* "server" "delay-on-busy")) ;;RADT => two conditions in a if block?? also understand what config looked up
      (and dbdat (db:dbdat-get-db dbdat))
      (if dbdat
	  (let* ((dbpath (db:dbdat-get-path dbdat))
		 (db     (db:dbdat-get-db   dbdat)) ;; we'll return this so (db:delay--if-busy can be called inline
		 (dbfj   (conc dbpath "-journal")))
	    (if (handle-exceptions
		 exn

		   (db:delay-if-busy count: 1))
		  ((1)
		   (thread-sleep! 6.4)
		   (db:delay-if-busy count: 0))
		  (else
		   (debug:print-info 0 *default-log-port* "delaying db access due to high database load.")
		   (thread-sleep! 12.8))))
	    db) ;; RADT => why does it need to return db, not #t
	  "bogus result from db:delay-if-busy")))

(define (db:test-get-records-for-index-file dbstruct run-id test-name)
  (let ((res '()))
    (db:with-db
     dbstruct
     run-id

;;            |-1.db
;;            |-<N>.db
;;
;;
;; Accessors for a dbstruct
;;

;; (define-inline (dbr:dbstruct-main    vec)    (vector-ref  vec 0)) ;; ( db path )
;; (define-inline (dbr:dbstruct-strdb   vec)    (vector-ref  vec 1)) ;; ( db path )
;; (define-inline (dbr:dbstruct-path    vec)    (vector-ref  vec 2)) 
;; (define-inline (dbr:dbstruct-local   vec)    (vector-ref  vec 3))
;; (define-inline (dbr:dbstruct-rundb   vec)    (vector-ref  vec 4)) ;; ( db path )
;; (define-inline (dbr:dbstruct-inmem   vec)    (vector-ref  vec 5)) ;; ( db #f )
;; (define-inline (dbr:dbstruct-mtime   vec)    (vector-ref  vec 6))
;; (define-inline (dbr:dbstruct-rtime   vec)    (vector-ref  vec 7))
;; (define-inline (dbr:dbstruct-stime   vec)    (vector-ref  vec 8))
;; (define-inline (dbr:dbstruct-inuse   vec)    (vector-ref  vec 9))
;; (define-inline (dbr:dbstruct-refdb   vec)    (vector-ref  vec 10)) ;; ( db path )
;; (define-inline (dbr:dbstruct-locdbs  vec)    (vector-ref  vec 11))
;; (define-inline (dbr:dbstruct-olddb   vec)    (vector-ref  vec 12)) ;; ( db path )
;; ;; (define-inline (dbr:dbstruct-main-path vec)  (vector-ref  vec 13))
;; ;; (define-inline (dbr:dbstruct-rundb-path vec) (vector-ref  vec 14))
;; ;; (define-inline (dbr:dbstruct-run-id  vec)    (vector-ref  vec 13))
;; 
;; (define-inline (dbr:dbstruct-main-set!   vec val)(vector-set! vec 0 val))
;; (define-inline (dbr:dbstruct-strdb-set!  vec val)(vector-set! vec 1 val))
;; (define-inline (dbr:dbstruct-path-set!   vec val)(vector-set! vec 2 val))
;; (define-inline (dbr:dbstruct-local-set!  vec val)(vector-set! vec 3 val))
;; (define-inline (dbr:dbstruct-rundb-set!  vec val)(vector-set! vec 4 val))
;; (define-inline (dbr:dbstruct-inmem-set!  vec val)(vector-set! vec 5 val))
;; (define-inline (dbr:dbstruct-mtime-set!  vec val)(vector-set! vec 6 val))
;; (define-inline (dbr:dbstruct-rtime-set!  vec val)(vector-set! vec 7 val))
;; (define-inline (dbr:dbstruct-stime-set!  vec val)(vector-set! vec 8 val))
;; (define-inline (dbr:dbstruct-inuse-set!  vec val)(vector-set! vec 9 val))
;; (define-inline (dbr:dbstruct-refdb-set!  vec val)(vector-set! vec 10 val))
;; (define-inline (dbr:dbstruct-locdbs-set! vec val)(vector-set! vec 11 val))
;; (define-inline (dbr:dbstruct-olddb-set!  vec val)(vector-set! vec 12 val))
;; (define-inline (dbr:dbstruct-main-path-set! vec val)(vector-set! vec 13 val))
;; (define-inline (dbr:dbstruct-rundb-path-set! vec val)(vector-set! vec 14 val))
;; 
; (define-inline (dbr:dbstruct-run-id-set! vec val)(vector-set! vec 13 val))

;; constructor for dbstruct
;;
;; (define (make-dbr:dbstruct #!key (path #f)(local #f))
;;   (let ((v (make-vector 15 #f)))
;;     (dbr:dbstruct-path-set! v path)
;;     (dbr:dbstruct-local-set! v local)
;;     (dbr:dbstruct-locdbs-set! v (make-hash-table))
;;     v))

;; Returns the database for a particular run-id fron the dbstruct:localdbs
;;
(define (dbr:dbstruct-localdb v run-id)
  (hash-table-ref/default (dbr:dbstruct-locdbs v) run-id #f))

(define (dbr:dbstruct-localdb-set! v run-id db)
  (hash-table-set! (dbr:dbstruct-locdbs v) run-id db))


(define (make-db:test)(make-vector 20))
(define-inline (db:test-get-id           vec) (vector-ref vec 0))
(define-inline (db:test-get-run_id       vec) (vector-ref vec 1))
(define-inline (db:test-get-testname     vec) (vector-ref vec 2))
(define-inline (db:test-get-state        vec) (vector-ref vec 3))

  (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-inline (db:test-get-first_err    vec) (printable (vector-ref vec 15)))
(define-inline (db:test-get-first_warn   vec) (printable (vector-ref vec 16))) ;; RADT => reference 16 is repeated

(define-inline (db:test-set-cpuload!  vec val)(vector-set! vec 7 val))
(define-inline (db:test-set-diskfree! vec val)(vector-set! vec 8 val))
(define-inline (db:test-set-testname! vec val)(vector-set! vec 2 val))
(define-inline (db:test-set-state!    vec val)(vector-set! vec 3 val))
(define-inline (db:test-set-status!   vec val)(vector-set! vec 4 val))
(define-inline (db:test-set-run_duration! vec val)(vector-set! vec 12 val))
(define-inline (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-inline (db:mintest-get-id           vec)    (vector-ref  vec 0))
(define-inline (db:mintest-get-run_id       vec)    (vector-ref  vec 1))
(define-inline (db:mintest-get-testname     vec)    (vector-ref  vec 2))
(define-inline (db:mintest-get-state        vec)    (vector-ref  vec 3))
(define-inline (db:mintest-get-status       vec)    (vector-ref  vec 4))

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

(use format)
(require-library iup)
(import (prefix iup iup:))
(use canvas-draw)
(import canvas-draw-iup)
(use regex typed-records)

(declare (unit dcommon))

(declare (uses megatest-version))
(declare (uses gutils))
(declare (uses db))
(declare (uses synchash))

	       (item-path  (db:test-get-item-path hed))
	       (state      (db:test-get-state hed))
	       (status     (db:test-get-status hed))
	       (newitem    (list test-name item-path (list test-id state status))))
	  (if (null? tal)
	      (reverse (cons newitem res))
	      (loop (car tal)(cdr tal)(cons newitem res)))))))

(define (dcommon:tests-mindat->hash tests-mindat)
  (let* ((res (make-hash-table)))
    (for-each
     (lambda (item)
       (let* ((test-name+item-path (cons (list-ref item 0) (list-ref item 1)))
              (value (list-ref item 2)))
         (hash-table-set! res test-name+item-path value)))
     tests-mindat)
    res))

;; return 1 if status1 is better
;; return 0 if status1 and 2 are equally good
;; return -1 if status2 is better
(define (dcommon:status-compare3 status1 status2)
  (let*
      ((status-goodness-ranking  (list "PASS" "WARN" "WAIVED" "SKIP" "FAIL" "ABORT" #f))
       (mem1 (member status1 status-goodness-ranking))
       (mem2 (member status2 status-goodness-ranking))
       )
    (cond
     ((and (not mem1) (not mem2)) 0)
     ((not mem1) -1)
     ((not mem2) 1)
     ((= (length mem1) (length mem2)) 0)
     ((> (length mem1) (length mem2)) 1)
     (else -1))))
     
(define (dcommon:xor-tests-mindat src-tests-mindat dest-tests-mindat #!key (hide-clean #f))
  (let* ((src-hash (dcommon:tests-mindat->hash src-tests-mindat))
         (dest-hash (dcommon:tests-mindat->hash dest-tests-mindat))
         (all-keys
          (reverse (sort 
           (delete-duplicates
            (append (hash-table-keys src-hash) (hash-table-keys dest-hash)))

           (lambda (a b) 
             (cond
              ((< 0 (string-compare3 (car a) (car b))) #t)
              ((> 0 (string-compare3 (car a) (car b))) #f)
              ((< 0 (string-compare3 (cdr a) (cdr b))) #t)
              (else #f)))

           ))))
    (let ((res
           (map ;; TODO: rename xor to delta globally in dcommon and dashboard
            (lambda (key)
              (let* ((test-name (car key))
                     (item-path (cdr key))

                     (dest-value (hash-table-ref/default dest-hash key #f)) ;; (list test-id state status)
                     (dest-test-id  (if dest-value (list-ref dest-value 0) #f))
                     (dest-state    (if dest-value (list-ref dest-value 1) #f))
                     (dest-status   (if dest-value (list-ref dest-value 2) #f))

                     (src-value     (hash-table-ref/default src-hash key #f))   ;; (list test-id state status)
                     (src-test-id   (if src-value (list-ref src-value 0) #f))
                     (src-state     (if src-value (list-ref src-value 1) #f))
                     (src-status    (if src-value (list-ref src-value 2) #f))

                     (incomplete-statuses '("DELETED" "INCOMPLETE" "STUCK/DEAD" "N/A")) ;; if any of these statuses apply, treat test as incomplete

                     (dest-complete
                      (and dest-value dest-state dest-status
                           (equal? dest-state "COMPLETED")
                           (not (member dest-status incomplete-statuses))))
                     (src-complete
                      (and src-value src-state src-status
                           (equal? src-state "COMPLETED")
                           (not (member src-status incomplete-statuses))))
                     (status-compare-result (dcommon:status-compare3 src-status dest-status))
                     (xor-new-item
                      (cond
                       ;; complete, for this case means: state=compelte AND status not in ( deleted uncomplete stuck/dead n/a )
                       ;; neither complete -> bad

                       ;; src !complete, dest complete -> better
                       ((and (not dest-complete) (not src-complete))
                        (list dest-test-id "BOTH-BAD" "BOTH-INCOMPLETE"))
                       ((not dest-complete)
                        (list src-test-id "DIFF-MISSING" "DEST-INCOMPLETE"))  
                       ((not src-complete)
                        (list dest-test-id "DIFF-NEW" "SRC-INCOMPLETE"))      
                       ((and
                         (equal? src-state dest-state)
                         (equal? src-status dest-status))
                        (list dest-test-id  (conc "CLEAN") (conc "CLEAN-" dest-status) )) 
                       ;;    better or worse: pass > warn > waived > skip > fail > abort
                       ;;     pass > warn > waived > skip > fail > abort
                       
                       ((= 1 status-compare-result) ;; src is better, dest is worse
                        (list dest-test-id "DIRTY-WORSE" (conc src-status "->" dest-status)))
                       (else
                        (list dest-test-id "DIRTY-BETTER" (conc src-status "->" dest-status)))
                       )))
                (list test-name item-path  xor-new-item)))
            all-keys)))

      (if hide-clean
          (filter
           (lambda (item)
             ;;(print item)
             (not
              (equal?
               "CLEAN"
               (list-ref (list-ref item 2) 1))))
           res)
          res))))

(define (dcommon:examine-xterm run-id test-id)
  (let* ((testdat (rmt:get-test-info-by-id run-id test-id)))
    (if (not testdat)
        (begin
          (debug:print 2 "ERROR: No test data found for test " test-id ", exiting")
          (exit 1))
        (let*
            ((rundir        (if testdat 
                                (db:test-get-rundir testdat)
                                logfile))
             (testfullname  (if testdat (db:test-get-fullname testdat) "Gathering data ..."))
             (xterm      (lambda ()
                           (if (directory-exists? rundir)
                               (let* ((shell (if (get-environment-variable "SHELL") 
                                                 (conc "-e " (get-environment-variable "SHELL"))
                                                 ""))
                                      (command (conc "cd " rundir 
                                                     ";mt_xterm -T \"" (string-translate testfullname "()" "  ") "\" " shell "&")))
                                 (print "Command =" command)
                                 (common:without-vars
                                  command
                                  "MT_.*"))
                               (message-window  (conc "Directory " rundir " not found"))))))
          (xterm)
          (print "Adding xterm code")))))

;;======================================================================
;; D A T A   T A B L E S
;;======================================================================

;; Table of keys
(define (dcommon:keys-matrix rawconfig)
  (let* ((curr-row-num 1)
         (key-vals     (configf:section-vars rawconfig "fields"))
         (keys-matrix  (iup:matrix
                        #:alignment1 "ALEFT"
                        #:expand "YES" ;; "HORIZONTAL" ;; "VERTICAL"
                        ;; #:scrollbar "YES"
                        #:numcol 1
                        #:numlin (length key-vals)
                        #:numcol-visible 1
                        #:numlin-visible (length key-vals)
                        #:click-cb (lambda (obj lin col status)
                                     (print "obj: " obj " lin: " lin " col: " col " status: " status)))))
    ;; (iup:attribute-set! keys-matrix "0:0" "Run Keys")
    (iup:attribute-set! keys-matrix "WIDTH0" 0)
    (iup:attribute-set! keys-matrix "0:1" "Key Name")
    ;; (iup:attribute-set! keys-matrix "WIDTH1" "100")
    ;; fill in keys
    (for-each 
     (lambda (var)
       ;; (iup:attribute-set! keys-matrix "ADDLIN" (conc curr-row-num))
       (iup:attribute-set! keys-matrix (conc curr-row-num ":0") curr-row-num)
       (iup:attribute-set! keys-matrix (conc curr-row-num ":1") var)
       (set! curr-row-num (+ 1 curr-row-num))) ;; (config-lookup *configdat* "fields" var)))
     key-vals)
    (iup:attribute-set! keys-matrix "WIDTHDEF" "40")
    keys-matrix))

;; Section to table
(define (dcommon:section-matrix rawconfig sectionname varcolname valcolname #!key (title #f))
  (let* ((curr-row-num    1)
         (key-vals        (configf:section-vars rawconfig sectionname))
         (section-matrix  (iup:matrix
                           #:alignment1 "ALEFT"
                           #:expand "YES" ;; "HORIZONTAL"
                           #:numcol 1
                           #:numlin (length key-vals)
                           #:numcol-visible 1
                           #:numlin-visible (min 10 (length key-vals))
			   #:scrollbar "YES")))
    (iup:attribute-set! section-matrix "0:0" varcolname)
    (iup:attribute-set! section-matrix "0:1" valcolname)
    (iup:attribute-set! section-matrix "WIDTH1" "200")
    ;; fill in keys
    (for-each 
     (lambda (var)

;;======================================================================
;; Copyright 2006-2013, 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 format numbers sql-de-lite srfi-1 posix regex regex-case srfi-69 srfi-18 call-with-environment-variables)
(require-library iup)
(import (prefix iup iup:))
(use canvas-draw)

(declare (uses margs))
(declare (uses megatest-version))
(declare (uses gutils))
(declare (uses tree))
(declare (uses configf))
(declare (uses portlogger))
(declare (uses keys))
(declare (uses common))

(include "common_records.scm")
;; (include "db_records.scm")
;; (include "key_records.scm")

(define help (conc 
	      "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
  version " megatest-version "
  license GPL, Copyright (C) Matt Welland 2011

Usage: dashboard [options]
  -h                : this help
  -group groupname  : display this group of areas
  -test testid      : control test identified by testid
  -guimonitor       : control panel for runs

Misc
  -rows N         : set number of rows
"))

;; process args
(define remargs (args:get-args 
		 (argv)
		 (list  "-group" ;; display this group of areas
			"-debug"
			) 
		 (list  "-h"
			"-v"
			"-q"
			)
		 args:arg-hash
		 0))

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

;; (if (args:get-arg "-host")
;;     (begin
;;       (set! (common:get-remote remote) (string-split (args:get-arg "-host" ":")))
;;       (client:launch))
;;     (client:launch))

(define *runremote* #f)
(define *windows* (make-hash-table))
(define *changed-main* (make-hash-table)) ;; set path/... => #t
(define *changed-mutex* (make-mutex))     ;; use for all incoming change requests
(define *searchpatts*   (make-hash-table))

(debug:setup)

(define *tim* (iup:timer))
(define *ord* #f)

(iup:attribute-set! *tim* "TIME" 300)
(iup:attribute-set! *tim* "RUN" "YES")

(define (message-window msg)
  (iup:show
   (iup:dialog
    (iup:vbox 
     (iup:label msg #:margin "40x40")))))

(define (iuplistbox-fill-list lb items . default)
  (let ((i 1)
	(selected-item (if (null? default) #f (car default))))
    (iup:attribute-set! lb "VALUE" (if selected-item selected-item ""))
    (for-each (lambda (item)
		(iup:attribute-set! lb (number->string i) item)
		(if selected-item
		    (if (equal? selected-item item)
			(iup:attribute-set! lb "VALUE" item))) ;; (number->string i))))
		(set! i (+ i 1)))
	      items)
    i))

(define (pad-list l n)(append l (make-list (- n (length l)))))


(define (mkstr . x)
  (string-intersperse (map conc x) ","))

(define (update-search x val)
  (hash-table-set! *searchpatts* x val))


;;======================================================================
;; R E C O R D S
;;======================================================================

;; NOTE: Consider switching to defstruct.

;; data for an area (regression or testsuite)
;;
(define-record areadat
  name               ;; area name
  path               ;; mt run area home
  configdat          ;; megatest config
  denoise            ;; focal point for not putting out same messages over and over
  client-signature   ;; key for client-server conversation
  remote             ;; hash of all the client side connnections
  run-keys           ;; target keys for this area
  runs               ;; used in dashboard, hash of run-ids -> rundat
  read-only          ;; can I write to this area?
  monitordb          ;; db handle for monitor.db
  maindb             ;; db handle for main.db
  )

;; rundat, basic run data
;;
(define-record rundat
  id                 ;; the run-id
  target             ;; val1/val2 ... corrosponding to run-keys in areadat
  runname
  state              ;; state of the run, symbol 
  status             ;; status of the run, symbol
  event-time         ;; when the run was initiated
  tests              ;; hash of test-id -> testdat, QUESTION: separate by run-id?
  db                 ;; db handle
  )

;; testdat, basic test data
(define-record testdat
  run-id             ;; what run is this from
  id                 ;; test id
  testname           ;; test name
  itempath           ;; item path
  state              ;; test state, symbol
  status             ;; test status, symbol
  event-time         ;; when the test started
  duration           ;; how long the test took
  )

;; general data for the dboard application
;;
(define-record data
  cfgdat             ;; data from ~/.megatest/<group>.dat
  areas              ;; hash of areaname -> area-rec
  current-window-id  ;; 
  current-tab-id     ;; 
  update-needed      ;; flag to indicate that the tab pointed to by current tab id needs refreshing immediately
  tabs               ;; hash of tab-id -> areaname (??) should be of type "tab"
  )

;; all the components of an area display, all fits into a tab but
;; parts may be swapped in/out as needed
;;
(define-record tab
  tree
  matrix    ;; the spreadsheet 
  areadat   ;; the one-structure (one day dbstruct will be put in here)
  view-path ;; <target/path>/<runname>/...
  view-type ;; standard, etc.
  controls  ;; the controls
  data      ;; all the data kept in sync with db
  filters   ;; user filters, alist name -> filter record, eventually store these in ~/.megatest/<group>.dat?
  run-id    ;; the current run-id
  test-ids  ;; the current test id hash, run-id => test-id
  command   ;; the command from the entry field
  headers   ;; hash of header  -> colnum
  rows      ;; hash of rowname -> rownum
  )

(define-record filter
  target    ;; hash of widgets for the target
  runname   ;; the runname widget
  testpatt  ;; the testpatt widget
  )

;;======================================================================
;; D B
;;======================================================================

;; These are all using sql-de-lite and independent of area so cannot use stuff 
;; from db.scm

;; NB// run-id=#f => return dbdir only
;;
(define (areadb:dbfile-path areadat run-id)
  (let* ((cfgdat  (areadat-configdat areadat))
	 (dbdir   (or (configf:lookup cfgdat "setup" "dbdir")
		      (conc (configf:lookup cfgdat "setup" "linktree") "/.db")))
	 (fname   (if run-id
		      (case run-id
			((-1) "monitor.db")
			((0) "main.db")
			(else (conc run-id ".db")))
		      #f)))
    (handle-exceptions
     exn
     (begin
       (debug:print-error 0 *default-log-port* "Couldn't create path to " dbdir)
       (exit 1))
     (if (not (directory? dbdir))(create-directory dbdir #t)))
    (if fname
	(conc dbdir "/" fname)
	dbdir)))

;; -1 => monitor.db
;;  0 => main.db
;; >1 => <run-id>.db
;;
(define (areadb:open areadat run-id)
  (let* ((runs   (areadat-runs areadat))
	 (rundat (if (> run-id 0) ;; it is a run
		     (hash-table-ref/default runs run-id #f)
		     #f))
	 (db     (case run-id ;; if already opened, get the db and return it
		   ((-1) (areadat-monitordb areadat))
		   ((0)  (areadat-maindb    areadat))
		   (else (if rundat
			     (rundat-db rundat)
			     #f)))))
    (if db
	db ;; merely return the already opened db
	(let* ((dbfile (areadb:dbfile-path areadat run-id)) ;; not already opened, so open it
	       (db     (if (file-exists? dbfile)
			   (open-database dbfile)
			   (begin
			     (debug:print-error 0 *default-log-port* "I was asked to open " dbfile ", but file does not exist or is not readable.")
			     #f))))
	  (case run-id
	    ((-1)(areadat-monitordb-set! areadat db))
	    ((0) (areadat-maindb-set!    areadat db))
	    (else (rundat-db-set!        rundat  db)))
	  db))))

;; populate the areadat tests info, does NOT fill the tests data itself unless asked
;;
(define (areadb:populate-run-info areadat)
  (let* ((runs   (or (areadat-runs areadat) (make-hash-table)))
	 (keys   (areadat-run-keys areadat))
	 (maindb (areadb:open areadat 0)))
    (if maindb
	(query (for-each-row (lambda (row)
			       (let ((id  (list-ref row 0))
				     (dat (apply make-rundat (append row (list #f #f))))) ;; add placeholders for tests and db
				 (print row)
				 (hash-table-set! runs id dat))))
	       (sql maindb (conc "SELECT id,"
				 (string-intersperse keys "||'/'||")
				 ",runname,state,status,event_time FROM runs WHERE state != 'deleted';")))
	(debug:print-error 0 *default-log-port* "no main.db found at "  (areadb:dbfile-path areadat 0)))
    areadat))

;; given an areadat and target/runname patt fill up runs data
;;
;; ?????/

;; given a list of run-ids refresh/retrieve runs data into areadat
;;
(define (areadb:fill-tests areadat #!key (run-ids #f))
  (let* ((runs   (or (areadat-runs areadat) (make-hash-table))))
    (for-each
     (lambda (run-id)
       (let* ((rundat (hash-table-ref/default runs run-id #f))
	      (tests  (if (and rundat
			       (rundat-tests rundat)) ;; re-use existing hash table?
			  (rundat-tests rundat)
			  (let ((ht (make-hash-table)))
			    (rundat-tests-set! rundat ht)
			    ht)))
	      (rundb  (areadb:open areadat run-id)))
	 (query (for-each-row (lambda (row)
				(let* ((id         (list-ref row 0))
				       (testname   (list-ref row 1))
				       (itempath   (list-ref row 2))
				       (state      (list-ref row 3))
				       (status     (list-ref row 4))
				       (eventtim   (list-ref row 5))
				       (duration   (list-ref row 6)))
				  (hash-table-set! tests id
						   (make-testdat run-id id testname itempath state status eventtim duration)))))
		(sql rundb "SELECT id,testname,item_path,state,status,event_time,run_duration FROM tests WHERE state != 'DELETED';"))))
     (or run-ids (hash-table-keys runs)))
    areadat))
    

;; initialize and refresh data
;;		
(define (dboard:general-updater con port)
  (for-each
   (lambda (window-id)
     ;; (print "Processing for window-id " window-id)
     (let* ((window-dat     (hash-table-ref *windows* window-id))
	    (areas          (data-areas     window-dat))
	    ;; (keys           (areadat-run-keys area-dat))
	    (tabs           (data-tabs      window-dat))
	    (tab-ids        (hash-table-keys tabs))
	    (current-tab    (if (null? tab-ids)
				#f
				(hash-table-ref tabs (car tab-ids))))
	    (current-tree   (if (null? tab-ids) #f (tab-tree   current-tab)))
	    (current-node   (if (null? tab-ids) 0  (string->number (iup:attribute current-tree "VALUE"))))
	    (current-path   (if (eq? current-node 0)
				"Areas"
				(string-intersperse (tree:node->path current-tree current-node) "/")))
	    (current-matrix (if (null? tab-ids) #f (tab-matrix current-tab)))
	    (seen-nodes     (make-hash-table))
	    (path-changed   (if current-tab
				(equal? current-path (tab-view-path current-tab))
				#t)))
       ;; (debug:print-info 0 *default-log-port* "Current path: " current-path)
       ;; now for each area in the window gather the data
       (if path-changed
	   (begin
	     (debug:print-info 0 *default-log-port* "clearing matrix - path changed")
	     (dboard:clear-matrix current-tab)))
       (for-each
	(lambda (area-name)
	  ;; (print "Processing for area-name " area-name)
	  (let* ((area-dat  (hash-table-ref areas area-name))
		 (area-path (areadat-path   area-dat))
		 (runs      (areadat-runs   area-dat)))
	    (if (hash-table-ref/default *changed-main* area-path 'processed)
		(begin
		  (print "Processing " area-dat " for area-name " area-name)
		  (hash-table-set! *changed-main* area-path #f)
		  (areadb:populate-run-info area-dat)
		  (for-each 
		   (lambda (run-id)
		     (let* ((run     (hash-table-ref runs run-id))
			    (target  (rundat-target run))
			    (runname (rundat-runname run)))
		       (if current-tree
			   (let* ((partial-path (append (string-split target "/")(list runname)))
				  (full-path    (cons area-name partial-path)))
			     (if (not (hash-table-exists? seen-nodes full-path))
				 (begin
				   (print "INFO: Adding node " partial-path " to section " area-name)
				   (tree:add-node current-tree "Areas" full-path)
				   (areadb:fill-tests area-dat run-ids: (list run-id))))
				   (hash-table-set! seen-nodes full-path #t)))))
		   (hash-table-keys runs))))
	    (if (or (equal? "Areas" current-path)
		    (string-match (conc "^Areas/" area-name "(|\\/.*)$") current-path))
		(dboard:redraw-area area-name area-dat current-tab current-matrix current-path))))
	(hash-table-keys areas))))
   (hash-table-keys *windows*)))

;;======================================================================
;; D A S H B O A R D   D B 
;;======================================================================

;; All moved to common.scm		

;;======================================================================
;; T R E E 
;;======================================================================

;; <area> - <target - ... > - <runname> - <test> - <itempath - ...>

(define (dashboard:tree-browser data adat window-id)
  ;; (iup:split
  (let* ((tb      (iup:treebox
		   #:value 0
		   #:title "Areas"
		   #:expand "YES"
		   #:addexpanded "NO"
		   #:selection-cb
		   (lambda (obj id state)
		     ;; (print "obj: " obj ", id: " id ", state: " state)
		     (let* ((tree-path (tree:node->path obj id))
			    (area      (car tree-path))
			    (areadat-path (cdr tree-path)))
		       #f
		       ;; (test-id  (tree-path->test-id (cdr run-path))))
		       ;; (if test-id
		       ;;    (hash-table-set! (dboard:data-curr-test-ids *data*)
		       ;;		     window-id test-id))
		       ;; (print "path: " (tree:node->path obj id) " test-id: " test-id))))))
		       )))))
    ;; (iup:attribute-set! tb "VALUE" "0")
    ;; (iup:attribute-set! tb "NAME" "Runs")
    ;; (iup:attribute-set! tb "ADDEXPANDED" "NO")
    ;; (dboard:data-tests-tree-set! *data* tb)
    tb))

;;======================================================================
;; M A I N   M A T R I X
;;======================================================================

;; General displayer
;;
(define (dashboard:main-matrix data adat window-id)
  (let* (;; (tab-dat         (areadat-
	 (view-matrix     (iup:matrix
			   ;; (runs-for-targ (db:get-runs-by-patt *dbstruct-local* *keys* "%" target #f #f #f))
			   #:expand "YES"
			   ;; #:fittosize "YES"
			   #:resizematrix "YES"
			   #:scrollbar "YES"
			   #:numcol 100
			   #:numlin 100
			   #:numcol-visible 3
			   #:numlin-visible 20
			   #:click-cb (lambda (obj lin col status)
					(print "obj: " obj " lin: " lin " col: " col " status: " status " value: " (iup:attribute obj "VALUE"))))))
    
    ;; (iup:attribute-set! view-matrix "RESIZEMATRIX" "YES")
    (iup:attribute-set! view-matrix "WIDTH0" "100")
    ;; (dboard:data-runs-matrix-set! *data* runs-matrix)
    ;; (iup:hbox
    ;;  (iup:frame 
    ;;   #:title "Runs browser"
    ;;   (iup:vbox
    view-matrix))

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

(define (dashboard:init-area data area-name apath)
  (let* ((mtconf      (dboard:read-mtconf apath))
	 (area-dat    (let ((ad (make-areadat
				 area-name ;; area name
				 apath     ;; path to area
				 ;; 'http     ;; transport
				 mtconf    ;; megatest.config
				 (make-hash-table) ;; denoise hash
				 #f        ;; client-signature
				 #f        ;; remote connections
				 (keys:config-get-fields mtconf) ;; run keys
				 (make-hash-table) ;; run-id -> (hash of test-ids => dat)
				 (and (file-exists? apath)(file-write-access? apath)) ;; read-only
				 #f
				 #f
				 )))
			(hash-table-set! (data-areas data) area-name ad)
			ad)))
    area-dat))

;; given the keys for an area and a path from the tree browser
;; return the level: areas area runs run tests test
;;
(define (dboard:get-view-type keys current-path)
  (let* ((path-parts (string-split current-path "/"))
	 (path-len   (length path-parts)))
    (cond
     ((equal? current-path "Areas")     'areas)
     ((eq? path-len 2)                  'area)
     ((<= (+ (length keys) 2) path-len) 'runs)
     (else                              'run))))

(define (dboard:clear-matrix tab)
  (if tab
      (begin
	(iup:attribute-set! (tab-matrix tab) "CLEARVALUE" "ALL")
	(tab-headers-set! tab (make-hash-table))
	(tab-rows-set!    tab (make-hash-table)))))

;; full redraw of a given area
;;
(define (dboard:redraw-area area-name area-dat tab-dat current-matrix current-path)
  (let* ((keys      (areadat-run-keys area-dat))
	 (runs      (areadat-runs     area-dat))
	 (headers   (tab-headers   tab-dat))
	 (rows      (tab-rows      tab-dat))
	 (used-cols (hash-table-values headers))
	 (used-rows (hash-table-values rows))
	 (touched   (make-hash-table)) ;; (vector row col) ==> true, touched cell
	 (view-type (dboard:get-view-type keys current-path))
	 (changed   #f)
	 (state-statuses  (list "PASS" "FAIL" "WARN" "CHECK" "SKIP" "RUNNING" "LAUNCHED")))
    ;; (debug:print 0 *default-log-port* "current-matrix=" current-matrix)
    (case view-type
      ((areas) ;; find row for this area, if not found, create new entry
       (let* ((curr-rownum (hash-table-ref/default rows area-name #f))
	      (next-rownum (+ (apply max (cons 0 used-rows)) 1))
	      (rownum      (or curr-rownum next-rownum))
	      (coord       (conc rownum ":0")))
	 (if (not curr-rownum)(hash-table-set! rows area-name rownum))
	 (if (not (equal? (iup:attribute current-matrix coord) area-name))
	     (begin
	       (let loop ((hed  (car state-statuses))
			  (tal  (cdr state-statuses))
			  (count 1))
		 (if (not (equal? (iup:attribute current-matrix (conc "0:" count)) hed))
		     (iup:attribute-set! current-matrix (conc "0:" count) hed))
		 (iup:attribute-set! current-matrix (conc rownum ":" count) "0")
		 (if (not (null? tal))
		     (loop (car tal)(cdr tal)(+ count 1))))
	       (debug:print-info 0 *default-log-port* "view-type=" view-type ", rownum=" rownum ", curr-rownum=" curr-rownum ", next-rownum=" next-rownum ", coord=" coord ", area-name=" area-name)
	       (iup:attribute-set! current-matrix coord area-name)
	       (set! changed #t))))))
    (if changed (iup:attribute-set! current-matrix "REDRAW" "ALL"))))
	     

       
   ;; (dboard:clear-matrix current-matrix used-cols used-rows touched) ;; clear all
    
	
  
;;======================================================================
;; D A S H B O A R D
;;======================================================================

(define (dashboard:area-panel aname data window-id)
  (let* ((apath      (configf:lookup (data-cfgdat data) aname "path")) ;;  (hash-table-ref (dboard:data-cfgdat data) area-name))
	 ;;          (hash-table-ref (dboard:data-cfgdat data) aname))
	 (area-dat   (dashboard:init-area data aname apath))
	 (tb         (dashboard:tree-browser data area-dat window-id)) ;; (dboard:areas-tree-browser data)
	 (ad         (dashboard:main-matrix  data area-dat window-id))
	 (areas      (data-areas data))
	 (dboard-dat (make-tab
		      #f           ;; tree
		      #f           ;; matrix
		      area-dat     ;;
		      #f           ;; view path
		      'default     ;; view type
		      #f           ;; controls
		      (make-hash-table) ;; cached data? not sure how to use this yet :)
		      #f           ;; filters
		      #f           ;; the run-id
		      (make-hash-table) ;; run-id -> test-id, for current test id
		      ""
		      (make-hash-table) ;; headername -> colnum
		      (make-hash-table) ;; rowname    -> rownum
		      )))
    (hash-table-set! (data-areas data) aname area-dat) ;; dboard-dat)
    (hash-table-set! (data-tabs data) window-id dboard-dat)
    (tab-tree-set!   dboard-dat tb)
    (tab-matrix-set! dboard-dat ad)
    (iup:split
     #:value 200
     tb ad)))


;; Main Panel
;;
(define (dashboard:main-panel data window-id)
  (iup:dialog
   #:title "Megatest Control Panel"
;;   #:menu (dcommon:main-menu data)
   #:shrink "YES"
   (iup:vbox
    (let* ((area-names  (hash-table-keys (data-cfgdat data)))
	   (area-panels (map (lambda (aname)
			       (dashboard:area-panel aname data window-id))
			     area-names))
	   (tabtop      (apply iup:tabs  
			       #:tabchangepos-cb (lambda (obj curr prev)
						   (data-current-tab-id-set! data curr)
						   (data-update-needed-set!  data #t)
						   (print "Tab is: " curr ", prev was " prev))
			       area-panels))
	   (tabs     (data-tabs data)))
      (if (not (null? area-names))
	  (let loop ((index 0)
		     (hed   (car area-names))
		     (tal   (cdr area-names)))
	    ;; (hash-table-set! tabs index hed)
	    (debug:print 0 *default-log-port* "Adding area " hed " with index " index " to dashboard")
	    (iup:attribute-set! tabtop (conc "TABTITLE" index) hed)
	    (if (not (null? tal))
		(loop (+ index 1)(car tal)(cdr tal)))))
      tabtop))))


;;======================================================================
;; N A N O M S G   S E R V E R
;;======================================================================

(define (dboard:server-service soc port)
  (print "server starting")
  (let loop ((msg-in (nn-recv soc))
	     (count  0))
    (if (eq? 0 (modulo count 1000))
	(print "server received: " msg-in ", count=" count))
    (cond
     ;;
     ;; quit
     ;;
     ((equal? msg-in "quit")
      (nn-send soc "Ok, quitting"))
     ;;
     ;; ping
     ;;
     ((and (>= (string-length msg-in) 4)
	   (equal? (substring msg-in 0 4) "ping"))
      (nn-send soc (conc (current-process-id)))
      (loop (nn-recv soc)(+ count 1)))
     ;;
     ;; main changed
     ;;
     ((and (>= (string-length msg-in) 4)
	   (equal? (substring msg-in 0 4) "main"))
      (let ((parts (string-split msg-in " ")))
	(hash-table-set! *changed-main* (cadr parts) #t)
	(nn-send soc "got it!")))
     ;;
     ;; ??
     ;;
     (else
      (nn-send soc "hello " msg-in " you got to the else clause!")))
    (loop (nn-recv soc)(if (> count 20000000)
			   0
			   (+ count 1)))))

(define (dboard:one-time-ping-receive soc port)
  (let ((msg-in (nn-recv soc)))
    (if (and (>= (string-length msg-in) 4)
	     (equal? (substring msg-in 0 4) "ping"))
	(nn-send soc (conc (current-process-id))))))

(define (dboard:server-start given-port #!key (num-tries 200))
  (let* ((rep (nn-socket 'rep))
	 (port (or given-port  (portlogger:main "find")))
	 (con (conc "tcp://*:" port)))
    ;; register this connect here ....
    (nn-bind rep con)
    (thread-start! 
     (make-thread (lambda ()
		    (dboard:one-time-ping-receive rep port))
		  "one time receive thread"))
    (if (dboard:ping-self "localhost" port)
	(begin
	  (print "INFO: dashboard nanomsg server started on " port)
	  (values rep port))
	(begin
	  (print "WARNING: couldn't create server on port " port)
	  (portlogger:main "set" "failed")
	  (if (> num-tries 0)
	      (dboard:server-start #f (- num-tries 1))
	      (begin
		(print "ERROR: failed to start nanomsg server")
		(values #f #f)))))))

(define (dboard:server-close con port)
  (nn-close con)
  (portlogger:main "set" port "released"))

(define (dboard:ping-self host port #!key (return-socket #t))
  ;; send a random number along with pid and check that we get it back
  (let* ((req     (nn-socket 'req))
	 (key     "ping")
	 (success #f)
	 (keepwaiting #t)
	 (ping    (make-thread
		   (lambda ()
		     (print "ping: sending string \"" key "\", expecting " (current-process-id))
		     (nn-send req key)
		     (let ((result  (nn-recv req)))
		       (if (equal? (conc (current-process-id)) result)
			   (begin
			     (print "ping, success: received \"" result "\"")
			     (set! success #t))
			   (begin
			     (print "ping, failed: received key \"" result "\"")
			     (set! keepwaiting #f)
			     (set! success #f)))))
		   "ping"))
	 (timeout (make-thread (lambda ()
				 (let loop ((count 0))
				   (thread-sleep! 1)
				   (print "still waiting after " count " seconds...")
				   (if (and keepwaiting (< count 10))
				       (loop (+ count 1))))
				 (if keepwaiting
				     (begin
				       (print "timeout waiting for ping")
				       (thread-terminate! ping))))
			       "timeout")))
    (nn-connect req (conc "tcp://" host ":" port))
    (handle-exceptions
     exn
     (begin
       (print-call-chain)
       (print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
       (print "exn=" (condition->list exn))
       (print "ping failed to connect to " host ":" port))
     (thread-start! timeout)
     (thread-start! ping)
     (thread-join! ping)
     (if success (thread-terminate! timeout)))
    (if return-socket
	(if success req #f)
	(begin
	  (nn-close req)
	  success))))

;;======================================================================
;; C O N F I G U R A T I O N 
;;======================================================================

;; Get the configuration file for a group name, if the group name is "default" and it doesn't 
;; exist, create it and add the current path if it contains megatest.config
;;
(define (dboard:get-config group-name)
  (let* ((fname (conc (getenv "HOME") "/.megatest/" group-name ".dat")))
    (if (file-exists? fname)
	(read-config fname (make-hash-table) #t)
	(if (dboard:create-config fname)
	    (dboard:get-config group-name)
	    (make-hash-table)))))

(define (dboard:create-config fname)
  ;; (handle-exceptions
  ;;  exn
  ;;  
  ;;  #f ;; failed to create - just give up
   (let* ((dirname       (pathname-directory fname))
	  (file-name     (pathname-strip-directory fname))
	  (curr-mtcfgdat (find-config "megatest.config"
				      toppath: (or (get-environment-variable "MT_RUN_AREA_HOME")(current-directory))))
	  (curr-mtcfg    (if (and curr-mtcfgdat (not (null? curr-mtcfgdat)))(cadr curr-mtcfgdat) #f))
	  (curr-mtpath   (if curr-mtcfg (car curr-mtcfgdat) #f)))
     (if curr-mtpath
	 (begin
	   (debug:print-info 0 *default-log-port* "Creating config file " fname)
	   (if (not (file-exists? dirname))
	       (create-directory dirname #t))
	   (with-output-to-file fname
	     (lambda ()
	       (let ((aname (pathname-strip-directory curr-mtpath)))
		 (print "[" aname "]")
		 (print  "path " curr-mtpath))))
	   #t)
	 (begin
	   (debug:print-info 0 *default-log-port* "Need to create a config but no megatest.config found: " curr-mtcfgdat)
	   #f))))
;; )

(define (dboard:read-mtconf apath)
  (let* ((mtconffile  (conc apath "/megatest.config")))
    (call-with-environment-variables
     (list (cons "MT_RUN_AREA_HOME" apath))
     (lambda ()
       (read-config mtconffile (make-hash-table) #f)) ;; megatest.config
     )))
	 

;;======================================================================
;; G U I   S T U F F 
;;======================================================================

;;; main. Theoretically could have multiple windows (each with a group of tags, thus window-id
;;;
(define (dboard:make-window window-id)
  (let* (;; (window-id 0)
	 (groupn    (or (args:get-arg "-group") "default"))
	 (cfgdat    (dboard:get-config groupn))
	 ;; (cfgdat    (if (file-exists? cfname)(read-config cfname (make-hash-table) #t)(make-hash-table)))
	 (data      (make-data
		     cfgdat ;; this is the data from ~/.megatest for the selected group
		     (make-hash-table) ;; areaname -> area-rec
		     0                 ;; current window id
		     0                 ;; current tab id
		     #f                ;; redraw needed for current tab id
		     (make-hash-table) ;; tab-id -> areaname
		     )))
    (hash-table-set! *windows* window-id data)
    (iup:show (dashboard:main-panel data window-id))
    (iup:main-loop)))

;; ease debugging by loading ~/.dashboardrc
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc")))
  (if (file-exists? debugcontrolf)
      (load debugcontrolf)))

(define (main)
  (let-values 
      (((con port)(dboard:server-start #f)))
    (let ((portnum   (if (string? port)(string->number port) port)))
      ;; got here, monitor/dashboard was started
      (mddb:register-dashboard portnum)
      (thread-start! (make-thread (lambda ()(dboard:server-service con portnum)) "server service"))
      (thread-start! (make-thread (lambda ()
				    (let loop ()
				      (dboard:general-updater con portnum)
				      (thread-sleep! 1)
				      (loop))) "general updater"))
      (dboard:make-window 0)
      (mddb:unregister-dashboard (get-host-name) portnum)
      (dboard:server-close con port))))

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

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

(use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest)
(import (prefix sqlite3 sqlite3:))

;; (use nanomsg)

(declare (unit nmsg-transport))

(declare (uses common))
(declare (uses db))
(declare (uses tests))
(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
(declare (uses server))

(include "common_records.scm")
(include "db_records.scm")

;; Transition to pub --> sub with pull <-- push
;;
;;   1. client sends request to server via push to the pull port
;;   2. server puts request in queue or processes immediately as appropriate
;;   3. server puts responses from completed requests into pub port 
;;
;; TODO
;;
;; Done Tested
;; [x]  [ ]    1. Add columns pullport pubport to servers table
;; [x]  [ ]    2. Add rm of monitor.db if older than 11/12/2012 
;; [x]  [ ]    3. Add create of pullport and pubport with finding of available ports
;; [x]  [ ]    4. Add client compose of request
;; [x]  [ ]        - name of client: testname/itempath-test_id-hostname 
;; [x]  [ ]        - name of request: callname, params
;; [x]  [ ]        - request key: f(clientname, callname, params)
;; [x]  [ ]    5. Add processing of subscription hits
;; [x]  [ ]        - done when get key 
;; [x]  [ ]        - return results
;; [x]  [ ]    6. Add timeout processing
;; [x]  [ ]        - after 60 seconds
;; [ ]  [ ]            i. check server alive, connect to new if necessary
;; [ ]  [ ]           ii. resend request
;; [ ]  [ ]    7. Turn self ping back on

(define (nmsg-transport:make-server-url hostport #!key (bindall #f))
  (if (not hostport)
      #f
      (conc "tcp://" (if bindall "*" (car hostport)) ":" (cadr hostport))))

(define *server-loop-heart-beat* (current-seconds))
(define *heartbeat-mutex* (make-mutex))

;;======================================================================
;; S E R V E R
;;======================================================================

(define (nmsg-transport:run dbstruct hostn run-id server-id #!key (retrynum 1000))
  (debug:print 2 *default-log-port* "Attempting to start the server ...")
  (let* ((start-port      (portlogger:open-run-close portlogger:find-port))
	 (server-thread   (make-thread (lambda ()
					 (nmsg-transport:try-start-server dbstruct run-id start-port server-id))
				       "server thread"))
	 (tdbdat          (tasks:open-db)))
    (thread-start! server-thread)
    (thread-sleep! 0.1)
    (if (nmsg-transport:ping hostn start-port timeout: 2 expected-key: (current-process-id))
	(let ((interface (if (equal? hostn "-")(get-host-name) hostn)))
	  (tasks:server-set-interface-port (db:delay-if-busy tdbdat) server-id interface start-port)
	  (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "dbprep")
	  (set! *server-info* (list hostn start-port)) ;; probably not needed anymore? currently used by keep-running
	  (thread-sleep! 3) ;; give some margin for queries to complete before switching from file based access to server based access
	  ;; (set! *inmemdb*  dbstruct)
	  (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "running")
	  (thread-start! (make-thread
			  (lambda ()(nmsg-transport:keep-running server-id run-id))
			  "keep running"))
	  (thread-join! server-thread))
	(if (> retrynum 0)
	    (begin
	      (debug:print 0 *default-log-port* "WARNING: Failed to connect to server (self) on host " hostn ":" start-port ", trying again.")
	      (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id "failed to start, never received server alive signature")
	      (portlogger:open-run-close portlogger:set-failed start-port)
	      (nmsg-transport:run dbstruct hostn run-id server-id))
	    (begin
	      (debug:print-error 0 *default-log-port* "could not find an open port to start server on. Giving up")
	      (exit 1))))))

(define (nmsg-transport:try-start-server dbstruct run-id portnum server-id)
  (let ((repsoc (nn-socket 'rep)))
    (nn-bind repsoc (conc "tcp://*:" portnum))
    (let loop ((msg-in (nn-recv repsoc)))
      (let* ((dat    (db:string->obj msg-in transport: 'nmsg)))
	(debug:print 0 *default-log-port* "server, received: " dat)
	(let ((result (api:execute-requests dbstruct dat)))
	  (debug:print 0 *default-log-port* "server, sending: " result)
	  (nn-send repsoc (db:obj->string result  transport: 'nmsg)))
	(loop (nn-recv repsoc))))))

;; all routes though here end in exit ...
;;
(define (nmsg-transport:launch run-id)
  (let* ((tdbdat   (tasks:open-db))
	 (dbstruct (db:setup run-id))
	 (hostn    (or (args:get-arg "-server") "-")))
    (set! *run-id*   run-id)
    (set! *inmemdb* dbstruct)
    ;; with nbfake daemonize isn't really needed
    ;;
    ;; (if (args:get-arg "-daemonize")
    ;;     (begin
    ;;       (daemon:ize)
    ;;       (if *alt-log-file* ;; we should re-connect to this port, I think daemon:ize disrupts it
    ;;           (begin
    ;;     	(current-error-port *alt-log-file*)
    ;;     	(current-output-port *alt-log-file*)))))
    (if (server:check-if-running run-id)
	(begin
	  (debug:print-info 0 *default-log-port* "Server for run-id " run-id " already running")
	  (exit 0)))
    (let loop ((server-id (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id))
	       (remtries  4))
      (if (not server-id)
	  (if (> remtries 0)
	      (begin
		(thread-sleep! 2)
		(if (not (server:check-if-running run-id))
		    (loop (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id)
			  (- remtries 1))
		    (begin
		      (debug:print-info 0 *default-log-port* "Another server took the slot, exiting")
		      (exit 0))))
	      (begin
		;; since we didn't get the server lock we are going to clean up and bail out
		(debug:print-info 2 *default-log-port* "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue")
		(tasks:server-delete-records-for-this-pid (db:delay-if-busy tdbdat) " http-transport:launch")
		))
	  ;; locked in a server id, try to start up
	  (nmsg-transport:run dbstruct hostn run-id server-id))
      (set! *didsomething* #t)
      (exit))))

;;======================================================================
;; S E R V E R   U T I L I T I E S 
;;======================================================================

(define (nmsg-transport:mk-signature)
  (message-digest-string (md5-primitive) 
			 (with-output-to-string
			   (lambda ()
			     (write (list (current-directory)
					  (argv)))))))

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

;; ping the server at host:port
;;   return the open socket if successful (return-socket == #t)
;;   expect the key expected-key returned in payload
;;   send our-key or #f as payload
;;
(define (nmsg-transport:ping hostn port #!key (timeout 3)(return-socket #t)(expected-key #f)(our-key #f)(socket #f))
  ;; send a random number along with pid and check that we get it back
  (let* ((host    (if (or (not hostn)
			  (equal? hostn "-")) ;; use localhost
		      (get-host-name)
		      hostn))
	 (req     (or socket
		      (let ((soc (nn-socket 'req)))
			(nn-connect soc (conc "tcp://" host ":" port))
			soc)))
	 (success #t)
	 (dat     (vector "ping" our-key))
	 (result  (condition-case 
		   (nmsg-transport:client-api-send-receive-raw req dat timeout: timeout)
		   ((timeout)(set! success #f) #f)))
	 (key     (if success 
		      (vector-ref result 1)
		      #f)))
    (debug:print 0 *default-log-port* "success=" success ", key=" key ", expected-key=" expected-key ", equal? " (equal? key expected-key))
    (if (and success
	     (or (not expected-key) ;; just getting a reply is good enough then
		 (equal? key expected-key)))
	(if return-socket
	    req
	    (begin
	      (if (not socket)(nn-close req)) ;; don't want a side effect of closing socket if handed it
	      #t))
	(begin
	  (if (not socket)(nn-close req)) ;; failed to ping, close socket as side effect
	  #f))))

;; send data to server, wait max of timeout seconds for a response.
;; return #( success/fail result )
;;
;; for effiency it is easier to do the obj->string and string->obj here.
;;
(define (nmsg-transport:client-api-send-receive-raw socreq indat #!key (enable-send #t)(timeout 25))
  (let* ((success     #f)
	 (result      #f)
	 (keepwaiting #t)
	 (dat         (db:obj->string indat transport: 'nmsg))
	 (send-recv   (make-thread
		       (lambda ()
			 (nn-send socreq dat)
			 (let* ((res (nn-recv socreq)))
			   (set! success #t)
			   (set! result (db:string->obj res transport: 'nmsg))))
		       "send-recv"))
	 (timeout     (make-thread
		       (lambda ()
			 (let loop ((count 0))
			   (thread-sleep! 1)
			   (debug:print-info 1 *default-log-port* "send-receive-raw, still waiting after " count " seconds...")
			   (if (and keepwaiting (< count timeout)) ;; yes, this is very aproximate
			       (loop (+ count 1))))
			 (if keepwaiting
			     (begin
			       (print "timeout waiting for ping")
			       (thread-terminate! send-recv))))
		       "timeout")))
    ;; replace with condition-case?
    (handle-exceptions
     exn
     (set! result "timeout")
     (thread-start! timeout)
     (thread-start! send-recv)
     (thread-join! send-recv)
     (if success (thread-terminate! timeout)))
    ;; raise timeout error if timed out
    (if success
	(if (and (vector? result)
		 (vector-ref result 0)) ;; did it fail at the server?
	    result                ;; nope, all good
	    (begin
	      (debug:print-error 0 *default-log-port* "error occured at server, info=" (vector-ref result 2))
	      (debug:print 0 *default-log-port* " client call chain:")
	      (print-call-chain (current-error-port))
	      (debug:print 0 *default-log-port* " server call chain:")
	      (pp (vector-ref result 1) (current-error-port))
	      (signal (vector-ref result 0))))
	(signal (make-composite-condition
		 (make-property-condition 'timeout 'message "nmsg-transport:client-api-send-receive-raw timed out talking to server"))))))

;; run nmsg-transport:keep-running in a parallel thread to monitor that the db is being 
;; used and to shutdown after sometime if it is not.
;;
(define (nmsg-transport:keep-running server-id run-id)
  ;; if none running or if > 20 seconds since 
  ;; server last used then start shutdown
  ;; This thread waits for the server to come alive
  (let* ((server-info (let loop ()
                        (let ((sdat #f))
                          (mutex-lock! *heartbeat-mutex*)
                          (set! sdat *server-info*)
                          (mutex-unlock! *heartbeat-mutex*)
                          (if sdat 
			      (begin
				(debug:print-info 0 *default-log-port* "keep-running got sdat=" sdat)
				sdat)
                              (begin
                                (thread-sleep! 0.5)
                                (loop))))))
         (iface       (car server-info))
         (port        (cadr server-info))
         (last-access 0)
	 (tdbdat      (tasks:open-db))
	 (server-timeout (let ((tmo (configf:lookup  *configdat* "server" "timeout")))
			   (if (and (string? tmo)
				    (string->number tmo))
			       (* 60 60 (string->number tmo))
			       ;; (* 3 24 60 60) ;; default to three days
			       (* 60 1)         ;; default to one minute
			       ;; (* 60 60 25)      ;; default to 25 hours
			       ))))
    (print "Keep-running got server pid " server-id ", using iface " iface " and port " port)
    (let loop ((count 0))
      (thread-sleep! 4) ;; no need to do this very often
      ;; NB// sync currently does NOT return queue-length
      (let () ;; (queue-len (cdb:client-call server-info 'sync #t 1)))
      ;; (print "Server running, count is " count)
        (if (< count 1) ;; 3x3 = 9 secs aprox
            (loop (+ count 1)))
        
        (mutex-lock! *heartbeat-mutex*)
        (set! last-access *last-db-access*)
        (mutex-unlock! *heartbeat-mutex*)
	(db:sync-touched *inmemdb* run-id force-sync: #t)
        (if (and *server-run*
	       (> (+ last-access server-timeout)
		  (current-seconds)))
            (begin
              (debug:print-info 0 *default-log-port* "Server continuing, seconds since last db access: " (- (current-seconds) last-access))
              (loop 0))
            (begin
              (debug:print-info 0 *default-log-port* "Starting to shutdown the server.")
              (set! *time-to-exit* #t)
	      (db:sync-touched *inmemdb* run-id force-sync: #t)
              (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id " http-transport:keep-running")
              (debug:print-info 0 *default-log-port* "Server shutdown complete. Exiting")
              (exit)
	      ))))))

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

(define (nmsg-transport:client-connect iface portnum)
  (let* ((reqsoc      (nmsg-transport:ping iface portnum return-socket: #t)))
    (vector iface portnum #f #f #f (current-seconds) reqsoc)))

;; returns result, there is no sucess/fail flag - handled via excpections
;;
(define (nmsg-transport:client-api-send-receive run-id connection-info cmd param #!key (remtries 5))
  ;; NB// In the html version of this routine there is a call to 
  ;;      tasks:kill-server-run-id when there is an exception
  (mutex-lock! *http-mutex*)
  (let* ((packet  (vector cmd param))
	 (reqsoc  (http-transport:server-dat-get-socket connection-info))
	 (res     (nmsg-transport:client-api-send-receive-raw reqsoc packet)))
;;	 (status  (vector-ref rawres 0))
;;	 (result  (vector-ref rawres 1)))
    (mutex-unlock! *http-mutex*)
    res)) ;; (vector status (if status (db:string->obj result transport: 'nmsg) result))))
	
;;======================================================================
;; J U N K 
;;======================================================================

;; DO NOT USE
;;
(define (nmsg-transport:client-signal-handler signum)
  (handle-exceptions
   exn
   (debug:print 0 *default-log-port* " ... exiting ...")
   (let ((th1 (make-thread (lambda ()
			     (if (not *received-response*)
				 (receive-message* *runremote*))) ;; flush out last call if applicable
			   "eat response"))
	 (th2 (make-thread (lambda ()
			     (debug:print-error 0 *default-log-port* "Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.")
			     (thread-sleep! 3) ;; give the flush three seconds to do it's stuff
			     (debug:print 0 *default-log-port* "       Done.")
			     (exit 4))
			   "exit on ^C timer")))
     (thread-start! th2)
     (thread-start! th1)
     (thread-join! th2))))

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

(declare (unit env))

(use sql-de-lite) ;; srfi-1 posix regex regex-case srfi-69 srfi-18 call-with-environment-variables)

(define (env:open-db fname)
  (let* ((db-exists (file-exists? fname))
	 (db        (open-database fname)))
    (if (not db-exists)
	(begin
	  (exec (sql db "CREATE TABLE envvars (

    ((LAUNCHED)         (list "101 123 142"  state))
    ((CHECK)            (list "255 100 50"   state))
    ((REMOTEHOSTSTART)  (list "50 130 195"   state))
    ((RUNNING)          (list "9 131 232"    state))
    ((KILLREQ)          (list "39 82 206"    state))
    ((KILLED)           (list "234 101 17"   state))
    ((NOT_STARTED)      (list "240 240 240"  state))
    ;; for xor mode below
    ;;
    ((CLEAN)
     (case (string->symbol status)
       ((CLEAN-FAIL CLEAN-CHECK CLEAN-ABORT)  (list "200 130 13" status)) ;; orange requested for these
       (else  (list "60  235 63" status))))
    ((DIRTY-BETTER)     (list "160  255 153" status))
    ((DIRTY-WORSE)      (list "165 42  42" status))
    ((BOTH-BAD)         (list "180 33 49" status))

    (else               (list "192 192 192"  state))))

;;======================================================================
;; launch a task - this runs on the originating host, tests themselves
;;
;;======================================================================

(use regex regex-case base64 sqlite3 srfi-18 directory-utils posix-extras z3 call-with-environment-variables csv)
(use typed-records pathname-expand)

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

(declare (unit launch))
(declare (uses common))
(declare (uses configf))

    (if (file-exists? cname)
	(let* ((dat  (read-config cname #f #f))
	       (csvr (db:logpro-dat->csv dat stepname))
	       (csvt (let-values (( (fmt-cell fmt-record fmt-csv) (make-format ",")))
				 (fmt-csv (map list->csv-record csvr))))
	       (status (configf:lookup dat "final" "exit-status"))
	       (msg     (configf:lookup dat "final" "message")))
          ;;(if csvt  ;; this if blocked stack dump caused by .dat file from logpro being 0-byte.  fixed by upgrading logpro
              (rmt:csv->test-data run-id test-id csvt)
            ;;  (BB> "Error: run-id/test-id/stepname="run-id"/"test-id"/"stepname" => bad csvr="csvr)
            ;;  )
	  (cond
	   ((equal? status "PASS") "PASS") ;; skip the message part if status is pass
	   (status (conc (configf:lookup dat "final" "exit-status") ": " (if msg msg "no message")))
	   (else #f)))
	#f)))

(define (launch:runstep ezstep run-id test-id exit-info m tal testconfig)

;;   returns:
;;     *toppath*
;;   side effects:
;;     sets; *configdat*    (megatest.config info)
;;           *runconfigdat* (runconfigs.config info)
;;           *configstatus* (status of the read data)
;;
(define (launch:setup #!key (force #f))
  (let* ((toppath  (or *toppath* (getenv "MT_RUN_AREA_HOME"))) ;; preserve toppath
	 (runname  (common:args-get-runname))
	 (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))

    (if (and *toppath*
	     (directory-exists? *toppath*))
	(setenv "MT_RUN_AREA_HOME" *toppath*)
	(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)))
	 (minspace (let ((m (configf:lookup confdat "setup" "minspace")))
		     (string->number (or m "10000")))))
    (if disks 
	(let ((res (common:get-disk-with-most-free-space disks minspace))) ;; min size of 1000, seems tad dumb

;; 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.6201)

      (set! *didsomething* #t)))

;;======================================================================
;; Start a repl
;;======================================================================

;; fakeout readline
(include "readline-fix.scm")

(if (or (getenv "MT_RUNSCRIPT")
	(args:get-arg "-repl")
	(args:get-arg "-load"))
    (let* ((toppath (launch:setup))
	   (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: (args:get-arg "-local")) #f)))
      (if dbstruct

	      (set! *db* dbstruct)
	      (set! *client-non-blocking-mode* #t)
	      (import extras) ;; might not be needed
	      ;; (import csi)
	      (import readline)
	      (import apropos)
	      ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ...


	      (if *use-new-readline*
		  (begin
		    (install-history-file (get-environment-variable "HOME") ".megatest_history") ;;  [homedir] [filename] [nlines])
		    (current-input-port (make-readline-port "megatest> ")))
		  (begin
		    (gnu-history-install-file-manager

;;======================================================================
;; Copyright 2006-2013, 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 json format) ;; RADT => purpose of json format??

(declare (unit rmt))
(declare (uses api))
(declare (uses tdb))
(declare (uses http-transport))
;;(declare (uses nmsg-transport))

;;
;; THESE ARE ALL CALLED ON THE CLIENT SIDE!!!
;;

;; ;; For debugging add the following to ~/.megatestrc
;;
;; (require-library trace)

	;; NB// can cache the answer for server running for 10 seconds ...
	;;  ;; (and (not (rmt:write-frequency-over-limit? cmd run-id))
	(if (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id)
	    (client:setup run-id)
	    #f))))

(define *send-receive-mutex* (make-mutex)) ;; should have separate mutex per run-id

;; RA => e.g. usage (rmt:send-receive 'get-var #f (list varname))
;;
(define (rmt:send-receive cmd rid params #!key (attemptnum 1)) ;; start attemptnum at 1 so the modulo below works as expected
  ;; clean out old connections
  ;; (mutex-lock! *db-multi-sync-mutex*)
  (let ((expire-time (- (current-seconds) (server:get-timeout) 10))) ;; don't forget the 10 second margin
    (for-each 
     (lambda (run-id)
       (let ((connection (hash-table-ref/default *runremote* run-id #f)))
         (if (and (vector? connection)
        	  (< (http-transport:server-dat-get-last-access connection) expire-time))
             (begin
               (debug:print-info 0 *default-log-port* "Discarding connection to server for run-id " run-id ", too long between accesses")
               ;; bb- disabling nanomsg
               ;; SHOULD CLOSE THE CONNECTION HERE 
	       ;; (case *transport-type*
	       ;;   ((nmsg)(nn-close (http-transport:server-dat-get-socket 
	       ;;  		   (hash-table-ref *runremote* run-id)))))
               (hash-table-delete! *runremote* run-id)))))
     (hash-table-keys *runremote*)))
  ;; (mutex-unlock! *db-multi-sync-mutex*)
  ;; (mutex-lock! *send-receive-mutex*)
  (let* ((run-id          (if rid rid 0))
	 (connection-info (rmt:get-connection-info run-id)))
    ;; the nmsg method does the encoding under the hood (the http method should be changed to do this also)
    (if connection-info
	;; use the server if have connection info
	(let* ((dat     (case *transport-type*
			  ((http)(condition-case
				  (http-transport:client-api-send-receive run-id connection-info cmd params)
				  ((commfail)(vector #f "communications fail"))
				  ((exn)(vector #f "other fail"))))
			  ;; ((nmsg)(condition-case
			  ;;         (nmsg-transport:client-api-send-receive run-id connection-info cmd params)
			  ;;         ((timeout)(vector #f "timeout talking to server"))))
			  (else  (exit))))
	       (success (if (vector? dat) (vector-ref dat 0) #f))
	       (res     (if (vector? dat) (vector-ref dat 1) #f)))
	  (if (vector? connection-info)(http-transport:server-dat-update-last-access connection-info))
	  (if success
	      (begin
		;; (mutex-unlock! *send-receive-mutex*)
		(case *transport-type* 
		  ((http) res) ;; (db:string->obj res))
		  ;; ((nmsg) res)
                  )) ;; (vector-ref res 1)))
	      (begin ;; let ((new-connection-info (client:setup run-id)))
		(debug:print 0 *default-log-port* "WARNING: Communication failed, trying call to rmt:send-receive again.")
		;; (case *transport-type*
		;;   ((nmsg)(nn-close (http-transport:server-dat-get-socket connection-info))))
		(hash-table-delete! *runremote* run-id) ;; don't keep using the same connection
		;; NOTE: killing server causes this process to block forever. No idea why. Dec 2. 
		;; (if (eq? (modulo attemptnum 5) 0)

;; This login does no retries under the hood - it acts a bit like a ping.
;; Deprecated for nmsg-transport.
;;
(define (rmt:login-no-auto-client-setup connection-info run-id)
  (case *transport-type*
    ((http)(rmt:send-receive-no-auto-client-setup connection-info 'login run-id (list *toppath* megatest-version run-id *my-client-signature*)))
    ;;((nmsg)(nmsg-transport:client-api-send-receive run-id connection-info 'login (list *toppath* megatest-version run-id *my-client-signature*)))
    ))

;; hand off a call to one of the db:queries statements
;; added run-id to make looking up the correct db possible 
;;
(define (rmt:general-call stmtname run-id . params)
  (rmt:send-receive 'general-call run-id (append (list stmtname run-id) params)))

(declare (uses common))
(declare (uses db))
(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
(declare (uses synchash))
(declare (uses http-transport))
(declare (uses rpc-transport))
;;(declare (uses nmsg-transport))
(declare (uses launch))
(declare (uses daemon))

(include "common_records.scm")
(include "db_records.scm")

(define (server:make-server-url hostport)

;; all routes though here end in exit ...
;;
;; start_server
;;
(define (server:launch run-id)
  (case *transport-type*
    ((http)(http-transport:launch run-id))
    ;;((nmsg)(nmsg-transport:launch run-id))
    ((rpc)  (rpc-transport:launch run-id))
    (else (debug:print-error 0 *default-log-port* "unknown server type " *transport-type*))))
;;       (else   (debug:print-error 0 *default-log-port* "No known transport set, transport=" transport ", using rpc")
;; 	      (rpc-transport:launch run-id)))))

;;======================================================================
;; S E R V E R   U T I L I T I E S 

	;;
	;; client:start returns #t if login was successful.
	;;
	(let ((res (case *transport-type*
		     ((http)(server:ping-server run-id 
						(tasks:hostinfo-get-interface server)
						(tasks:hostinfo-get-port      server)))
		     ;; ((nmsg)(nmsg-transport:ping (tasks:hostinfo-get-interface server)
		     ;;    			 (tasks:hostinfo-get-port      server)
		     ;;    			 timeout: 2))
                     )))
	  ;; if the server didn't respond we must remove the record
	  (if res
	      #t
	      (begin
		(debug:print-info 0 *default-log-port* "server at " server " not responding, removing record")
		(tasks:server-force-clean-running-records-for-run-id (db:delay-if-busy tdbdat) run-id 
				" server:check-if-running")

;; NOTE: Run this local with #f for db !!!
(define (tdb:load-test-data run-id test-id)
  (let loop ((lin (read-line)))
    (if (not (eof-object? lin))
	(begin
	  (debug:print 4 *default-log-port* lin)
          ;;(when lin ;; this when blocked stack dump caused by .dat file from logpro being 0-byte.  fixed by upgrading logpro
          (rmt:csv->test-data run-id test-id lin)
          ;;)
	  (loop (read-line)))))
  ;; roll up the current results.
  ;; FIXME: Add the status too 
  (rmt:test-data-rollup run-id test-id #f))

;; NOTE: Run this local with #f for db !!!
(define (tdb:load-logpro-data run-id test-id)
  (let loop ((lin (read-line)))
    (if (not (eof-object? lin))
	(begin
	  (debug:print 4 *default-log-port* lin)
          ;;(when lin  ;; this when blocked stack dump caused by .dat file from logpro being 0-byte.  fixed by upgrading logpro
          (rmt:csv->test-data run-id test-id lin)
          ;;)
	  (loop (read-line)))))
  ;; roll up the current results.
  ;; FIXME: Add the status too 
  (rmt:test-data-rollup run-id test-id #f))

(define (tdb:get-prev-tol-for-test tdb test-id category variable)
  ;; Finish me?

#======================================================================
# N  A N O M S G
#======================================================================

# https://github.com/nanomsg/nanomsg/releases/download/0.6-beta/nanomsg-0.6-beta.tar.gz
# https://github.com/nanomsg/nanomsg/releases/download/0.8-beta/nanomsg-0.8-beta.tar.gz

# nanomsg-0.6-beta.tar.gz :
# 	wget http://download.nanomsg.org/nanomsg-0.6-beta.tar.gz

# nanomsg-0.6-beta/COPYING : nanomsg-0.6-beta.tar.gz
# 	tar xf nanomsg-0.6-beta.tar.gz

# $(PREFIX)/bin/nanocat : nanomsg-0.6-beta/COPYING
# 	cd nanomsg-0.6-beta;./configure --prefix=$(PREFIX);make;make install

# $(PREFIX)/lib/nanomsg.so : $(PREFIX)/bin/nanocat
# 	CSC_OPTIONS="-I$(PREFIX)/include -L$(PREFIX)/lib" $(CHICKEN_INSTALL) $(PROX) nanomsg

# # LD_LIBRARY_PATH=/mfs/pkgs/chicken/4.10.0-amd64/lib CSC_OPTIONS="-I/mfs/pkgs/chicken/4.10.0-amd64/include -L/mfs/pkgs/chicken/4.10.0-amd64/lib -C \"-fPIC\"" /mfs/pkgs/chicken/4.10.0-amd64/bin/chicken-install  -D no-library-checks nanomsg

#======================================================================
# M A T T S   U T I L S
#======================================================================

# opensrc

$(CHICKEN_EGG_DIR)/sqlite3.so : $(PREFIX)/bin/sqlite3
	CSC_OPTIONS="-I$(PREFIX)/include -L$(PREFIX)/lib" $(CHICKEN_INSTALL) $(PROX) sqlite3

#======================================================================
# N  A N O M S G
#======================================================================

# # https://github.com/nanomsg/nanomsg/releases/download/0.6-beta/nanomsg-0.6-beta.tar.gz
# # https://github.com/nanomsg/nanomsg/releases/download/0.8-beta/nanomsg-0.8-beta.tar.gz

# nanomsg-0.6-beta.tar.gz :
# 	wget http://download.nanomsg.org/nanomsg-0.6-beta.tar.gz

# nanomsg-0.6-beta/COPYING : nanomsg-0.6-beta.tar.gz
# 	tar xf nanomsg-0.6-beta.tar.gz

# $(PREFIX)/bin/nanocat : nanomsg-0.6-beta/COPYING
# 	cd nanomsg-0.6-beta;./configure --prefix=$(PREFIX);make;make install

# $(PREFIX)/lib/nanomsg.so : $(PREFIX)/bin/nanocat
# 	CSC_OPTIONS="-I$(PREFIX)/include -L$(PREFIX)/lib" $(CHICKEN_INSTALL) $(PROX) nanomsg

# # LD_LIBRARY_PATH=/mfs/pkgs/chicken/4.10.0-amd64/lib CSC_OPTIONS="-I/mfs/pkgs/chicken/4.10.0-amd64/include -L/mfs/pkgs/chicken/4.10.0-amd64/lib -C \"-fPIC\"" /mfs/pkgs/chicken/4.10.0-amd64/bin/chicken-install  -D no-library-checks nanomsg

#======================================================================
# M A T T S   U T I L S
#======================================================================

# opensrc

$(CHICKEN_EGG_DIR)/sqlite3.so : $(PREFIX)/bin/sqlite3
	CSC_OPTIONS="-I$(PREFIX)/include -L$(PREFIX)/lib" $(CHICKEN_INSTALL) $(PROX) sqlite3

#======================================================================
# N  A N O M S G
#======================================================================

# # https://github.com/nanomsg/nanomsg/releases/download/0.6-beta/nanomsg-0.6-beta.tar.gz
# # https://github.com/nanomsg/nanomsg/releases/download/0.8-beta/nanomsg-0.8-beta.tar.gz

# nanomsg-0.6-beta.tar.gz :
# 	wget http://download.nanomsg.org/nanomsg-0.6-beta.tar.gz

# nanomsg-0.6-beta/COPYING : nanomsg-0.6-beta.tar.gz
# 	tar xf nanomsg-0.6-beta.tar.gz

# $(PREFIX)/bin/nanocat : nanomsg-0.6-beta/COPYING
# 	cd nanomsg-0.6-beta;./configure --prefix=$(PREFIX);make;make install

# $(PREFIX)/lib/nanomsg.so : $(PREFIX)/bin/nanocat
# 	CSC_OPTIONS="-I$(PREFIX)/include -L$(PREFIX)/lib" $(CHICKEN_INSTALL) $(PROX) nanomsg

# # LD_LIBRARY_PATH=/mfs/pkgs/chicken/4.10.0-amd64/lib CSC_OPTIONS="-I/mfs/pkgs/chicken/4.10.0-amd64/include -L/mfs/pkgs/chicken/4.10.0-amd64/lib -C \"-fPIC\"" /mfs/pkgs/chicken/4.10.0-amd64/bin/chicken-install  -D no-library-checks nanomsg

#======================================================================
# M A T T S   U T I L S
#======================================================================

# opensrc

#  This program is distributed WITHOUT ANY WARRANTY; without even the
#  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
#  PURPOSE.

echo You may need to do the following first:
echo sudo apt-get install libreadline-dev
echo sudo apt-get install libwebkitgtk-dev 
echo sudo apt-get install libpangox-1.0-0 zlib1g-dev libfreetype6-dev cmake
echo sudo apt-get install libssl-dev
echo sudo apt-get install libmotif3 -OR- set KTYPE=26g4
echo
echo Set OPTION to std, currently OPTION=$OPTION
echo
echo Additionally, if you want mysql-client, you will need to make sure
echo mysql_config is in your path
echo
echo You are using PREFIX=$PREFIX
echo You are using proxy="$proxy"
echo 
echo "Set additional_libpath to help find gtk or other libraries, don't forget a leading :"

SYSTEM_TYPE=$(lsb_release -irs |tr ' ' '_' |tr '\n' '-')$(uname -i)-$OPTION

# Set up variables
#
case $SYSTEM_TYPE in
Ubuntu-16.04-x86_64-std)
	KTYPE=32
	CDVER=5.10
	IUPVER=3.17
	IMVER=3.11
	;;
Ubuntu-16.04-i686-std)
	KTYPE=32
	CDVER=5.10
	IUPVER=3.17
	IMVER=3.11
	;;
SUSE_LINUX_11-x86_64-std)
  KTYPE=26g4 
	CDVER=5.10
	IUPVER=3.17
	IMVER=3.11
  ;;
CentOS_5.11-x86_64-std)
  KTYPE=24g3 
  CDVER=5.4.1
  IUPVER=3.5
  IMVER=3.6.3
  ;; 
esac
			   
echo KTYPE=$KTYPE			  
echo CDVER=$CDVER
echo IUPVER=$IUPVER
echo IMVER=$IMVER	
# NOTES:
#
# Centos with security setup may need to do commands such as following as root:
#
# NB// fix the paths first
#
# for a in /localdisk/chicken/4.8.0/lib/*.so;do chcon -t textrel_shlib_t $a; done 

else
  export http_proxy=http://$proxy
  export PROX="-proxy $proxy"
fi

if [[ $KTYPE == "" ]]; then
  echo 'Using KTYPE=26'
  export KTYPE=26g4
else
  echo Using KTYPE=$KTYPE
fi

# Put all the downloaded tar files in tgz
mkdir -p tgz

# http://code.call-cc.org/releases/4.8.0/chicken-4.8.0.5.tar.gz
export CHICKEN_VERSION=4.11.0
export CHICKEN_BASEVER=4.11.0
chicken_targz=chicken-${CHICKEN_VERSION}.tar.gz
if ! [[ -e tgz/$chicken_targz ]]; then 
    wget http://code.call-cc.org/releases/${CHICKEN_BASEVER}/${chicken_targz}
    mv $chicken_targz tgz
fi 

BUILDHOME=$PWD
DEPLOYTARG=$BUILDHOME/deploy

if [[ $PREFIX == "" ]]; then
   PREFIX=$PWD/inst
fi

export PATH=$PREFIX/bin:$PATH
export LIBPATH=$PREFIX/lib:$PREFIX/lib64:$ADDITIONAL_LIBPATH
export LD_LIBRARY_PATH=$LIBPATH
export CHICKEN_INSTALL=$PREFIX/bin/chicken-install
mkdir -p $PREFIX
echo "export PATH=$PREFIX/bin:\$PATH" > $PREFIX/setup-chicken4x.sh
echo "export LD_LIBRARY_PATH=$LD_LIBRARY_PATH:\$LD_LIBRARY_PATH" >> $PREFIX/setup-chicken4x.sh
echo "export CHICKEN_DOC_PAGER=cat" >> $PREFIX/setup-chicken4x.sh

echo "setenv PATH $PREFIX/bin:\$PATH" > $PREFIX/setup-chicken4x.csh
echo "setenv LD_LIBRARY_PATH $LD_LIBRARY_PATH:\$LD_LIBRARY_PATH" >> $PREFIX/setup-chicken4x.csh
echo "setenv CHICKEN_DOC_PAGER cat" >> $PREFIX/setup-chicken4x.csh

echo PATH=$PATH
echo LD_LIBRARY_PATH=$LD_LIBRARY_PATH

if ! [[ -e $PREFIX/bin/csi ]]; then
    tar xfz tgz/$chicken_targz
    cd chicken-${CHICKEN_VERSION}
    # make PLATFORM=linux PREFIX=$PREFIX spotless
    make PLATFORM=linux PREFIX=$PREFIX
    make PLATFORM=linux PREFIX=$PREFIX install
    cd $BUILDHOME
fi
cd $BUILDHOME
#wget --no-check-certificate https://github.com/nanomsg/nanomsg/archive/1.0.0.tar.gz 
#mv 1.0.0 1.0.0.tar.gz
# if ! [[ -e $PREFIX/lib64/libnanomsg.so.1.0.0 ]]; then
#         wget --no-check-certificate https://github.com/nanomsg/nanomsg/archive/1.0.0.tar.gz 
#         mv 1.0.0 1.0.0.tar.gz
# 	tar xf 1.0.0.tar.gz 
# 	cd nanomsg-1.0.0
# 	./configure --prefix=$PREFIX
# 	make
# 	make install
# fi
# cd $BUILDHOME

export SQLITE3_VERSION=3090200
if ! [[ -e $PREFIX/bin/sqlite3 ]]; then
	echo Install sqlite3
	sqlite3_tgz=sqlite-autoconf-$SQLITE3_VERSION.tar.gz
	if ! [[ -e tgz/$sqlite3_tgz ]]; then
	    wget http://www.sqlite.org/2015/$sqlite3_tgz
	    mv $sqlite3_tgz tgz
	fi

	if ! [[ -e $PREFIX/bin/sqlite3 ]] ; then
	    if [[ -e tgz/sqlite-autoconf-$SQLITE3_VERSION.tar.gz ]]; then
		tar xfz tgz/sqlite-autoconf-$SQLITE3_VERSION.tar.gz 
		(cd sqlite-autoconf-$SQLITE3_VERSION;./configure --prefix=$PREFIX;make;make install)
	    fi
	fi
fi
cd $BUILDHOME

# Some eggs are quoted since they are reserved to Bash
# for f in matchable readline apropos base64 regex-literals format "regex-case" "test" coops trace csv dot-locking posix-utils posix-extras directory-utils hostinfo tcp rpc csv-xml fmt json md5; do
# $CHICKEN_INSTALL $PROX -keep-installed matchable readline apropos base64 regex-literals format "regex-case" "test" coops trace csv dot-locking posix-utils posix-extras directory-utils hostinfo tcp rpc csv-xml fmt json md5 awful http-client spiffy uri-common intarweb http-client spiffy-request-vars md5 message-digest http-client spiffy-directory-listing
for egg in matchable readline apropos base64 regex-literals format "regex-case" "test" \
	coops trace csv dot-locking posix-utils posix-extras directory-utils hostinfo \

	tcp rpc csv-xml fmt json md5 awful http-client spiffy uri-common intarweb http-client \
	spiffy-request-vars s md5 message-digest spiffy-directory-listing ssax sxml-serializer \
	sxml-modifications logpro z3 call-with-environment-variables \
	pathname-expand typed-records simple-exceptions numbers crypt parley srfi-42 \
	alist-lib ansi-escape-sequences args basic-sequences bindings chicken-doc chicken-doc-cmd \
	cock condition-utils debug define-record-and-printer easyffi easyffi-base \
	expand-full ezxdisp filepath foof-loop ini-file irc lalr lazy-seq \
	locale locale-builtin locale-categories locale-components locale-current locale-posix \
	locale-timezone loops low-level-macros procedural-macros refdb rfc3339 scsh-process \
	sexp-diff sha1 shell slice srfi-101 srfi-19 srfi-19-core srfi-19-date srfi-19-io \
	srfi-19-period srfi-19-support srfi-19-time srfi-19-timezone srfi-29 srfi-37 srfi-78 syslog \
	udp uuid uuid-lib zlib


do
	echo "Installing $egg"
	$CHICKEN_INSTALL $PROX -keep-installed $egg

	#$CHICKEN_INSTALL $PROX $egg


	if [ $? -ne 0 ]; then

		echo "$egg failed to install"



		exit 1
	fi
done

if [[ -e `which mysql_config` ]]; then
  $CHICKEN_INSTALL $PROX -keep-installed mysql-client
fi

for egg in "sqlite3" sql-de-lite # nanomsg
do
	echo "Installing $egg"
	CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib -L$PREFIX/lib64"  $CHICKEN_INSTALL $PROX -keep-installed $egg
	#CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib -L$PREFIX/lib64"  $CHICKEN_INSTALL $PROX $egg
	if [ $? -ne 0 ]; then
		echo "$egg failed to install"
		exit 1
	fi
done
cd $BUILDHOME
cd `$PREFIX/bin/csi -p '(chicken-home)'`
curl http://3e8.org/pub/chicken-doc/chicken-doc-repo.tgz | tar zx
cd $BUILDHOME



# $CHICKEN_INSTALL $PROX sqlite3
cd $BUILDHOME
# # IUP versions
# if [[ x$USEOLDIUP == "x" ]];then
#   CDVER=5.10
#   IUPVER=3.17
#   IMVER=3.11
# else
#   CDVER=5.10
#   IUPVER=3.17
#   IMVER=3.11
# fi
# if [[ x$KTYPE == "x24g3" ]];then
#   CDVER=5.4.1
#   IUPVER=3.5
#   IMVER=3.6.3
# fi

if [[ `uname -a | grep x86_64` == "" ]]; then 
    export ARCHSIZE=''
else
    export ARCHSIZE=64_
fi
    # export files="cd-5.4.1_Linux${KTYPE}_lib.tar.gz im-3.6.3_Linux${KTYPE}_lib.tar.gz iup-3.5_Linux${KTYPE}_lib.tar.gz"
if [[ x$USEOLDIUP == "x" ]];then
   export files="cd/cd-${CDVER}_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz im/im-${IMVER}_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz iup/iup-${IUPVER}_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz"
else
   echo WARNING: Using old IUP libraries
   export files="cd/cd-5.4.1_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz im/im-3.6.3_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz iup/iup-3.5_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz"
fi
echo $files

mkdir -p $PREFIX/iuplib
mkdir -p iup/
for a in `echo $files` ; do
    if ! [[ -e tgz/$a ]] ; then
        echo wget -c -O tgz/$a http://www.kiatoa.com/matt/chicken-build/$a
	wget -c http://www.kiatoa.com/matt/chicken-build/$a
        mv `echo $a | cut -d'/' -f2` tgz/
    fi
    echo Untarring tgz/$a into $BUILDHOME/lib
    tar -xzf tgz/`echo $a | cut -d'/' -f2` -C iup/
    #(cd $PREFIX/lib;tar xfvz $BUILDHOME/tgz/$a;mv include/* ../include)
    # (cd $DEPLOYTARG;tar xfvz $BUILDHOME/$a)
done
cp iup/include/* $PREFIX/include/
cp iup/*.so $PREFIX/lib/
cp iup/*.a $PREFIX/lib/
cp iup/ftgl/lib/*/* $PREFIX/lib/
cd $BUILDHOME
# ffcall obtained from:
# cvs -z3 -d:pserver:anonymous@cvs.savannah.gnu.org:/sources/libffcall co ffcall 
#exit
if ! [[ -e $PREFIX/include/callback.h ]] ; then
	#fossil clone http://www.kiatoa.com/fossils/ffcall ffcall.fossil


	wget -c -O ffcall.tar.gz 'http://www.kiatoa.com/fossils/ffcall/tarball?name=ffcall&uuid=trunk'
	tar -xzf ffcall.tar.gz
	#mkdir -p ffcall
	cd ffcall
	#fossil open ../ffcall.fossil
	./configure --prefix=$PREFIX --enable-shared
	make CC="gcc -fPIC"
	make install
fi
cd $BUILDHOME
#wget -c -O opensrc.tar.gz 'http://www.kiatoa.com/fossils/opensrc/tarball?name=opensrc&uuid=trunk'
# Not working due to login problems.
if ! [[ -e $PREFIX/bin/hs ]] ; then
	#fossil clone http://www.kiatoa.com/fossils/opensrc opensrc.fossil
	#mkdir -p opensrc
	wget -c -O opensrc.tar.gz 'http://www.kiatoa.com/fossils/opensrc/tarball?name=opensrc&uuid=trunk'
	tar -xzf opensrc.tar.gz
	cd opensrc
	#fossil open ../opensrc.fossil
	cd histstore
	$PREFIX/bin/csc histstore.scm -o hs 
	cp -f hs $PREFIX/bin/hs 
	cd ../mutils
	$PREFIX/bin/chicken-install
	cd ../dbi 
	$PREFIX/bin/chicken-install
	cd ../margs
	$PREFIX/bin/chicken-install
fi
cd $BUILDHOME

if ! [[ -e $PREFIX/bin/stmlrun ]] ; then
	#fossil clone http://www.kiatoa.com/fossils/stml stml.fossil
	wget -c -O stml.tar.gz 'http://www.kiatoa.com/fossils/stml/tarball?name=stml&uuid=trunk'
	tar -xzf stml.tar.gz
	cd stml
	#fossil open ../stml.fossil
	cp install.cfg.template install.cfg
	echo "TARGDIR=$PREFIX/bin" > install.cfg
	echo "LOGDIR=/tmp/stmlrun" >> install.cfg
	echo "SQLITE3=$PREFIX/bin/sqlite3" >> install.cfg
	cp requirements.scm.template requirements.scm
	which csc
	make clean
	CSCOPTS="-C -fPIC" make
fi

cd $BUILDHOME
export CSCLIBS=`echo $LD_LIBRARY_PATH | sed 's/:/ -L/g'`
IUPEGGVER='iup'
if [[ $IUPVER == "3.5" ]]; then
  IUPEGGVER='iup:1.2.1'
fi

#CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX -D no-library-checks -feature disable-iup-web iup
CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib" $CHICKEN_INSTALL $PROX -D no-library-checks -feature disable-iup-web $IUPEGGVER

# CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX -D no-library-checks -feature disable-iup-web -deploy -prefix $DEPLOYTARG iup
# iup:1.0.2 
CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib" $CHICKEN_INSTALL $PROX -D no-library-checks canvas-draw
# CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX -D no-library-checks -deploy -prefix $DEPLOYTARG canvas-draw



cd $BUILDHOME  




































echo You may need to add $LD_LIBRARY_PATH to your LD_LIBRARY_PATH variable, a setup-chicken4x.sh 
echo file can be found in the current directory which should work for setting up to run chicken4x

echo Testing iup
$PREFIX/bin/csi -b -eval '(use iup)(print "Success")'