Megatest

Usage: dashboard [options]
  -h                    : this help
  -test run-id test-id  : open a test control panel on this test
  -skip-version-check   : skip the version check
  -rows R         : set number of rows
  -cols C         : set number of columns
  -start-dir dir  : start dashboard in the given directory
  -target-run target[/run-name]   : filter runs tab to given target/run-name.
  -target target  : filter runs tab to given target.
  -debug  n[,n]   : set debug level(s) e.g. -debug 4 or -debug 0,9
  -repl           : Start a chicken scheme interpreter
"
))


;; process args
(define remargs (args:get-args 
		 (argv)
                 ;; parameters (need arguments)
		 (list  "-rows"
			"-cols"
			"-test" ;; given a run id and test id, open only a test control panel on that test..
			"-debug"
                        "-start-dir"
                        "-target-run"
                        "-target"
			) 
                 ;; switches (don't take arguments)
		 (list  "-h"
			"-skip-version-check"
			"-repl"
			"-:p"     ;; ignore the built in chicken profiling switch
			)
		 args:arg-hash
		 0))

;; ################### Top level code ###################

;; check for MT_* environment variables and exit if found
(if (not (args:get-arg "-test"))
    (begin
      (for-each (lambda (var)
		  ;; (display " ")(display var)
		  (if (get-environment-variable var)
		      (begin
			(print "ERROR: environment variable " var " is set in this terminal, this will cause you problems. Exiting now.")
			(exit 1))))
		'("MT_RUN_AREA_HOME" "MT_MEGATEST" "MT_CMDINFO" "MT_TEST_RUN_DIR" "MT_LINKTREE" "MT_TESTSUITENAME"))
    )
)

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

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

(if (args:get-arg "-start-dir")
    (if (directory-exists? (args:get-arg "-start-dir"))
        (let ((fullpath (common:real-path (args:get-arg "-start-dir"))))
          (setenv "PWD" fullpath)
          (change-directory fullpath))
	(begin
	  (debug:print-error 0 *default-log-port* "non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.")
 	  (exit 1))))

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

;; deal with RH 5.11 gtk lib or iup lib missing detachbox feature
;; first check for the switch
;;
(if (or 
	(configf:lookup *configdat* "dashboard" "no-detachbox")
        (not (file-exists? "/etc/os-release")))
    (set! iup:detachbox iup:vbox))

(if (not (common:on-homehost?))
    (begin
      (debug:print 0 *default-log-port* "WARNING: You are starting the dashboard on a machine that is not the homehost:" (common:get-homehost))
      (debug:print 0 *default-log-port* "It will be slower.")
      ))

;; ########################### end top level code ##############################

    
;; RA => Might require revert for filters 
;; create a watch dog to move changes from lt/.db/*.db to megatest.db
;;
;;;(if (file-write-access? (conc *toppath* "/megatest.db"))
;;(debug:print-info 13 *default-log-port* "Before common:watchdog spawn")

  please-update  
  tabdats
  update-mutex
  updaters 
  updating
  uidat ;; needs to move to tabdat at some time
  hide-not-hide-tabs
  target
  )

(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
   target:               ""
   ))

;;======================================================================
;; buttons color using image
;;======================================================================

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

    (dboard:setup-num-rows dat)
    dat))

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


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

;; RADT => Matrix defstruct addition
(defstruct dboard:graph-dat

  tests-notdrawn ;; list of id's NOT already drawn
  rowsused       ;; hash of lists covering what areas used - replace with quadtree
  hierdat        ;; put hierarchial sorted list here
  tests          ;; hash of id => testdat
  ((tests-by-name (make-hash-table)) : hash-table) ;; hash of testfullname => testdat
  key-vals
  ((last-update   0)                 : number)    ;; last query to db got records from before last-update
  ((last-db-time  0)                 : number)    ;; last timestamp on megatest.db
  ((last-db-time  0)                 : number)    ;; last timestamp on main.db
  ((data-changed  #f)                : boolean)   
  ((run-data-offset  0)              : number)      ;; get only 100 items per call, set back to zero when received less than 100 items
  (db-path #f))

;; for the new runs view lets build up a few new record types and then consolidate later
;;
;; this is a two level deep pipeline for the incoming data:

                        0
                        (dboard:rundat-last-update run-dat)))
	 (last-db-time (if do-not-use-db-file-timestamps
			   0
			   (dboard:rundat-last-db-time run-dat)))
	 (db-path      (or (dboard:rundat-db-path run-dat)
			   (let* ((db-dir (common:get-db-tmp-area))
				  (db-pth (conc db-dir "/megatest.db")))
				  (db-pth (conc db-dir "/.megatest/main.db")))
			     (dboard:rundat-db-path-set! run-dat db-pth)
			     db-pth)))
	 (db-mod-time  (common:lazy-sqlite-db-modification-time db-path))
	 (db-modified  (>= db-mod-time last-db-time))
	 (multi-get    (> (dboard:rundat-run-data-offset run-dat) 0))  ;; multi-get in progress
	 (tmptests     (if (or do-not-use-db-file-timestamps
			       (dboard:tabdat-filters-changed tabdat)

    #:orientation "VERTICAL" ;; "HORIZONTAL"
    #:value 100
    (dboard:runs-tree-new-browser commondat rdat)
    (dboard:runs-new-matrix commondat rdat)
    )))

(define (make-dashboard-buttons commondat) ;;  runs-sum-dat new-view-dat)
  (let* (
  (let* ((stats-dat       (dboard:tabdat-make-data))
         (stats-dat       (dboard:tabdat-make-data))
	 (runs-dat        (dboard:tabdat-make-data))
	 (runs2-dat       (make-dboard:rdat)) ;; (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))

	 (i               0)
	 (btn-height      (dboard:tabdat-runs-btn-height runs-dat))
	 (btn-fontsz      (dboard:tabdat-runs-btn-fontsz runs-dat))
	 (cell-width      (dboard:tabdat-runs-cell-width runs-dat))
	 (use-bgcolor     (equal? (configf:lookup *configdat* "dashboard" "use-bgcolor") "yes")))
    ;; controls (along bottom)
    ;; (set! controls (dboard:make-controls commondat runs-dat))
    
   


    ;; create the left most column for the run key names and the test names 
    (set! lftlst
	  (list (iup:hbox
		 (iup:label) ;; (iup:valuator)
		 (apply iup:vbox 
			(map (lambda (x)		
			       (let ((res (iup:hbox

			  runs-view
			  (dashboard:summary commondat stats-dat tab-num: 1)
			  ;; (make-runs-view commondat runs2-dat 2)
			  (dashboard:runs-summary commondat onerun-dat tab-num: 2)
			  (dashboard:run-controls commondat runcontrols-dat tab-num: 3)
			  (dashboard:run-times commondat runtimes-dat tab-num: 4)
			  additional-views))
             (target-run (args:get-arg "-target-run"))
             (target-run (dboard:commondat-target commondat))
             )
	;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c)))
	(iup:attribute-set! tabs "TABTITLE0" "Runs")
	(iup:attribute-set! tabs "TABTITLE1" "Summary")
	;; (iup:attribute-set! tabs "TABTITLE2" "Runs2")
	(iup:attribute-set! tabs "TABTITLE2" "Run Summary")
	(iup:attribute-set! tabs "TABTITLE3" "Run Control")

	(iup:attribute-set! tabs "BGCOLOR" "190 190 190")
	;; make the iup tabs object available (for changing color for example)
	(dboard:commondat-hide-not-hide-tabs-set! commondat tabs)
	;; now set up the tabdat lookup
	;; (dboard:common-set-tabdat! commondat 0 stats-dat)
        
        (if target-run
          (begin
          (dboard:tabdat-target-set! runs-dat (string-split target-run "/"))
            (dboard:tabdat-target-set! runs-dat (string-split target-run "/"))
          )
        )
	(dboard:common-set-tabdat! commondat 0 runs-dat)
	;;(dboard:common-set-tabdat! commondat 2 runs2-dat)
	(dboard:common-set-tabdat! commondat 2 onerun-dat)
	(dboard:common-set-tabdat! commondat 3 runcontrols-dat)
	(dboard:common-set-tabdat! commondat 4 runtimes-dat)

                              "%"))
	       (testpatt  (or (dboard:tabdat-test-patts tabdat) "%"))
	       (filtrstr  (conc targpatt "/" runpatt "/" testpatt)))
	  ;; (print "targpatt: " targpatt " runpatt: " runpatt " testpatt: " testpatt)

	  (if (not (equal? (dboard:tabdat-last-filter-str tabdat) filtrstr))
	      (let ((dwg (dboard:tabdat-drawing tabdat)))
		(print "resetting drawing")
		(dboard:tabdat-layout-update-ok-set! tabdat #f)
		(vg:drawing-libs-set! dwg (make-hash-table))
		(vg:drawing-insts-set! dwg (make-hash-table))
		(vg:drawing-cache-set! dwg '())
		(dboard:tabdat-allruns-by-id-set! tabdat (make-hash-table))
		;; (dboard:tabdat-allruns-set! tabdat '())
		(dboard:tabdat-max-row-set! tabdat 0)

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

(define (main)
  (print "Starting dashboard main")

  (let ((mtdb-path (conc *toppath* "/megatest.db"))) ;; 
  (let* ((mtdb-path (conc *toppath* "/.megatest/main.db"))
         (target (args:get-arg "-target"))
         (commondat       (dboard:commondat-make)))
    (if target
        (begin
          (args:remove-arg-from-ht "-target")
          (dboard:commondat-target-set! commondat target)
        )
    )

    (if (not (launch:setup))
        (begin
          (print "Failed to find megatest.config, exiting") 
          (exit 1)
        )
    )

    (if (not (common:on-homehost?))
    (begin
      (debug:print 0 *default-log-port* "WARNING: You are starting the dashboard on a machine that is not the homehost:" (common:get-homehost))
      (debug:print 0 *default-log-port* "It will be slower.")
      ))


    (if (and (common:file-exists? mtdb-path)
	     (file-write-access? mtdb-path))
	(if (not (args:get-arg "-skip-version-check"))
            (common:exit-on-version-changed)))

    (let* ((commondat       (dboard:commondat-make)))
    (let* ()
      ;; 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") ",")))) 
			  (if (> (length d) 1)
			      d
			      (list #f #f))))

      (let ((th1 (make-thread (lambda ()
				(thread-sleep! 1)
				(dboard:common-run-curr-updaters commondat 0) ;; force update of summary tab 
				) "update buttons once"))
	    (th2 (make-thread iup:main-loop "Main loop")))
        (print "Starting main loop")
	(thread-start! th2)
	(thread-join! th2)))))

	(thread-join! th2)
        )
        )
        )
        )

;; ########################### top level code ########################
;; check for MT_* environment variables and exit if found
(if (not (args:get-arg "-test"))
    (begin
      (for-each (lambda (var)
		  ;; (display " ")(display var)
		  (if (get-environment-variable var)
		      (begin
			(print "ERROR: environment variable " var " is set in this terminal, this will cause you problems. Exiting now.")
			(exit 1))))
		'("MT_RUN_AREA_HOME" "MT_MEGATEST" "MT_CMDINFO" "MT_TEST_RUN_DIR" "MT_LINKTREE" "MT_TESTSUITENAME"))

    )
)

(setenv "MT_RUN_AREA_HOME" (get-environment-variable "PWD"))

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

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




(if (args:get-arg "-start-dir")
    (if (directory-exists? (args:get-arg "-start-dir"))
        (let ((fullpath (common:real-path (args:get-arg "-start-dir"))))
          (setenv "PWD" fullpath)
          (change-directory fullpath))
	(begin
	  (debug:print-error 0 *default-log-port* "non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.")
 	  (exit 1))))


;; deal with RH 5.11 gtk lib or iup lib missing detachbox feature
;; first check for the switch
;;
(if (or 
	(configf:lookup *configdat* "dashboard" "no-detachbox")
        (not (file-exists? "/etc/os-release")))
    (set! iup:detachbox iup:vbox))



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


(if (args:get-arg "-repl")
    (repl)
    (main))

	  (set! (file-modification-time tmpdbfname) (current-seconds))  
	  (dbfile:print-err "INFO: db:sync-all-tables-list done.")
	  )
	(dbfile:print-err " db, " (dbr:dbdat-dbfile tmpdb) " already exists or fresh enough, not propogating data from\n     " (dbr:dbdat-dbfile mtdb) " mod time delta: " modtimedelta) )
    ;; (db:multi-db-sync subdb 'old2new))  ;; migrate data from megatest.db automatically
    tmpdb))
		
;;======================================================================
;; no-sync.db - small bits of data to be shared between servers
;;======================================================================

;; if we are not a server create a db handle. this is not finalized
;; so watch for problems. I'm still not clear if it is needed to manually
;; finalize sqlite3 dbs with the sqlite3 egg.
;;

(define (dbfile:cautious-open-database fname init-proc #!optional (tries-left 50))

  (let* ((busy-file  (conc fname"-journal"))
	 (delay-time (* (- 51 tries-left) 1.1))
	 (write-access (file-write-access? fname))
	 (retry      (lambda ()
         (retry      (lambda ()
		       (thread-sleep! delay-time)
		       (if (> tries-left 0)
			   (dbfile:cautious-open-database fname init-proc (- tries-left 1))))))
    (assert (>= tries-left 0) (conc "FATAL: too many attempts in dbfile:cautious-open-database of "fname", giving up."))

    (if (and (file-write-access? fname)
	     (file-exists? busy-file))
	(begin
	  (dbfile:print-err "INFO: dbfile:cautious-open-database: journal file " busy-file " exists, trying again in few seconds.")
	  (thread-sleep! 1)
	  (if (eq? tries-left 2)
	      (begin
		(dbfile:print-err "INFO: forcing journal rollup "busy-file)
		(dbfile:brute-force-salvage-db fname)))
	  (dbfile:cautious-open-database fname init-proc (- tries-left 1)))

	(let* ((result (condition-case
			   (if write-access
			   (dbfile:with-simple-file-lock
			    (conc fname ".lock")
			    (lambda ()
			      (let* ((db-exists (file-exists? fname))
				     (db        (sqlite3:open-database fname)))
				(if (and init-proc (not db-exists))
				    (init-proc db))
				db)))
                             (dbfile:with-simple-file-lock
			       (conc fname ".lock")
			        (lambda ()
			          (let* ((db-exists (file-exists? fname))
				         (db        (sqlite3:open-database fname)))
				      (if (and init-proc (not db-exists))
				        (init-proc db))
				   db)))
                                (if (file-exists? fname )
                                   (sqlite3:open-database fname)
                                   #f
                                )
                           )
			 (exn (io-error)
			      (dbfile:print-err exn "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again.")
			      (retry))
			 (exn (corrupt)
			      (dbfile:print-err exn "ERROR: database " fname " is corrupt. Repair it to proceed.")
			      (retry))
			 (exn (busy)

		      (map args:get-arg args)))))

(define (args:get-arg-from ht arg . default)
  (if (null? default)
      (hash-table-ref/default ht arg #f)
      (hash-table-ref/default ht arg (car default))))


(define (args:remove-arg-from-ht arg)
      (hash-table-delete! args:arg-hash arg)
)

(define (args:usage . args)
  (if (> (length args) 0)
      (apply print "ERROR: " args))
  (if (string? help)
      (print help)
      (print "Usage: " (car (argv)) " ... "))
  (exit 0))