Megatest

(define (common:false-on-exception thunk #!key (message #f))
  (handle-exceptions exn
                     (begin
                       (if message
                           (debug:print-info 0 *default-log-port* message))
                       #f) (thunk) ))

(define (common:file-exists? path-string #!key (quiet-mode #f))
  ;; this avoids stack dumps in the case where 

  ;;;; TODO: catch permission denied exceptions and emit appropriate warnings, eg:  system error while trying to access file: "/nfs/pdx/disks/icf_env_disk001/bjbarcla/gwa/issues/mtdev/randy-slow/reproduce/q...
  (common:false-on-exception
   (lambda () (file-exists? path-string))
   message: (if quiet-mode
		#f
		(conc "Unable to access path: " path-string))))


(define (common:directory-exists? path-string #!key (quiet-mode #f))
  ;;;; TODO: catch permission denied exceptions and emit appropriate warnings, eg:  system error while trying to access file: "/nfs/pdx/disks/icf_env_disk001/bjbarcla/gwa/issues/mtdev/randy-slow/reproduce/q...
  (common:false-on-exception
   (lambda () (directory-exists? path-string))
   message: (if quiet-mode
		#f
		(conc "Unable to access path: " path-string))))


;; does the directory exist and do we have write access?
;;
;;    returns the directory or #f
;;
(define (common:directory-writable? path-string)
  (handle-exceptions

				     #f))))))
	   (at-home  (or (equal? homehost currhost)
			 (equal? homehost bestadrs))))
      (set! *home-host* (cons homehost at-home))
      (mutex-unlock! *homehost-mutex*)
      *home-host*))))

;; get homehost info for a given area - but only if .homehost file already exists
(define (common:minimal-get-homehost toppath)
  (let ((hh-file (conc toppath "/.homehost")))
    (if (common:file-exists? hh-file quiet-mode: #t)
	(with-input-from-file hh-file read-line)
	#f)))

;; are we on the given host?
(define (common:on-host? hh)
  (let* ((currhost (get-host-name))
	 (bestadrs (server:get-best-guess-address currhost)))
    (or (equal? hh currhost)
	(equal? hh bestadrs))))
    
;; am I on the homehost?
;;
(define (common:on-homehost?)
  (let ((hh (common:get-homehost)))
    (if hh
	(cdr hh)
	#f)))

;; minimal loading of megatest.config
;;
(define (common:simple-setup toppath #!key (cfgf-ovrd #f))
  (let* ((mtconfigf (or cfgf-ovrd "megatest.config"))
	 (mtconfdat (find-and-read-config
		     mtconfigf
		     ;; environ-patt: "env-override"
		     given-toppath: toppath
		     ;; pathenvvar: "MT_RUN_AREA_HOME"
		     ))
	 (mtconf    (if mtconfdat (car mtconfdat) #f)))
    (if mtconf
	(configf:section-var-set! mtconf "dyndat" "toppath" start-dir))
    mtconfdat))

;; do we honor the caches of the config files?
;;
(define (common:use-cache?)
  (let ((res #t)) ;; priority by order of evaluation
    (if *configdat* ;; sillyness here. can't use setup/use-cache to know if we can use the cached files!
	(if (equal? (configf:lookup *configdat* "setup" "use-cache") "no")

;;======================================================================
;; AREAS
;;======================================================================

(define (dashboard:areas-summary-updater commondat tabdat tb cell-lookup run-matrix)
  (dashboard:areas-do-update-rundat tabdat) ;; )
  (dboard:areas-summary-control-panel-updater tabdat)
  (let* ((last-runs-update  (dboard:tabdat-last-runs-update tabdat))
	 (runs-dat     (mrmt: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:areas-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))

	
	(debug:print-info 13 *default-log-port* "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 (mrmt:get-run-info run-id))
	       (target   (mrmt:get-target run-id))
	       (runname  (db:get-value-by-header (db:get-rows run-info)
						 (db:get-header run-info) "runname"))
	       (test-info  (mrmt:get-test-info-by-id run-id test-id))
	       (test-name (db:test-get-testname test-info))
	       (testpatt  (let ((tlast (mrmt: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 (mrmt: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 " &")))
	  (debug:print-info 13 *default-log-port* "status-chars=["status-chars"] status=["status"]")
	  (cond

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

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

                                   dbkeys)
                         res))))
       fres))))

(define (dashboard:areas-get-runs-hash tabdat)
  (let* ((access-mode       (dboard:tabdat-access-mode tabdat))
         (last-runs-update  0);;(dboard:tabdat-last-runs-update tabdat))
	 (runs-dat     (mrmt: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)))

			  (let* ((record-a (hash-table-ref runs-hash a))
				 (record-b (hash-table-ref runs-hash b))
				 (time-a   (db:get-value-by-header record-a runs-header "event_time"))
				 (time-b   (db:get-value-by-header record-b runs-header "event_time")))
			    (< time-a time-b)))))
         (changed      #f)
	 (last-runs-update  (dboard:tabdat-last-runs-update tabdat))
	 (runs-dat     (mrmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f 0)) ;; last-runs-update))
	 (runs-header  (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
         (runs         (vector-ref runs-dat 1))
	 (new-run-ids  (map (lambda (run)
			      (db:get-value-by-header run runs-header "id"))
			    runs))
	 (areas        (configf:get-section *configdat* "areas")))
    (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2))

	       (hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path run-id)
	       ;; (set! colnum (+ colnum 1))
	       ))))
     (append new-run-ids run-ids)))) ;; for-each run-id
  
(define (dashboard:areas-run-id->tests-mindat run-id tabdat runs-hash)
  (let* ((run          (hash-table-ref/default runs-hash run-id #f))
         (key-vals     (mrmt: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))

    (lambda (obj)
      (dcommon:examine-xterm run-id test-id)))

   (iup:menu-item
    (conc "Kill " item-test-path)
    #:action
    (lambda (obj)
      ;; (mrmt: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,NOT_STARTED"))))

   

               " -runname " runname
	       " -testpatt " item-test-path
	       " -preclean -clean-cache"))))
     (iup:menu-item
      (conc "Kill " item-test-path)
      #:action
      (lambda (obj)
        ;; (mrmt: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
      (conc "Delete data : " item-test-path)

        (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
                                  (mrmt:get-run-name-from-id curr-run-id)
                                  "None"))
                (prev-runname (if prev-run-id
                                  (mrmt: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" ""))))))

  (tmpdb       #f)
  (dbstack     #f) ;; stack for tmp db handles, do not initialize with a stack
  (mtdb        #f)
  (refndb      #f)
  (homehost    #f) ;; not used yet
  (on-homehost #f) ;; not used yet
  (read-only   #f)
  (configdat   #f)
  (keys        #f)
  (area-path   #f)
  )                ;; goal is to converge on one struct for an area but for now it is too confusing
  

;; record for keeping state,status and count for doing roll-ups in
;; iterated tests
;;
(defstruct dbr:counts

;;   tmpdb       - local to this machine, all reads to this
;;   mtdb        - full db from mtrah
;;   no-sync-db  -
;;   on-homehost - enable reading from other users /tmp db if files are readable
;;
;;   areas is hash of areas => dbstruct, the dashboard-open-db will register the dbstruct in that hash
;;
;;   NOTE: This returns the tmpdb path/handle pair.
;;   NOTE: This does do a sync (the db:open-db proc only does an initial sync if called with do-sync: #t
;;   NOTE: Longer term consider replacing db:open-db with this
;;
(define (db:dashboard-open-db areas area-path)
  ;; 0. check for already existing dbstruct in areas hash, return it if found
  ;; 1. do minimal read of megatest.config, store configdat, keys in dbstruct
  ;; 2. get homehost
  ;; 3. create /tmp db area  (if needed)
  ;; 4. sync data to /tmp db (or update if exists)
  ;; 5. return dbstruct
  (if (hash-table-exists? areas area-path)
      (hash-table-ref areas area-path)
      (if (common:file-exists? (conc area-path "/megatest.config") quiet-mode: #t)
	  (let* ((homehost (common:minimal-get-homehost toppath))
		 (on-hh    (common:on-host? homehost))
		 (mtconfig (common:simple-setup area-path)) ;; returns ( configdat toppath configfile configf-name )
		 (dbstruct (make-dbr:dbstruct
			    area-path: area-path
			    homehost:  homehost
			    configdat: (car mtconfig)))
		 (tmpdb    (db:open-db dbstruct area-path: area-path do-sync: #t)))
	    tmpdb)
	  (begin
	    (debug:print-info 0 *default-log-port* "attempt to open megatest.db in " area-path " but no megatest.config found.")
	    #f))))

;; sync all the areas listed in area-paths
;;
(define (db:dashboard-sync-dbs areas area-paths)
  #f)

;; close all area db's

;;     (dbr:dbstruct-olddb-set!  dbstruct olddb)
;;     ;;; (mutex-unlock! *rundb-mutex*) ;;; why did we need a mutex on opening db's?
;;     (db:sync-tables db:sync-tests-only *megatest-db* db)
;;     db))

;; This routine creates the db if not already present. It is only called if the db is not already opened
;;
(define (db:open-db dbstruct #!key (area-path #f)(do-sync #t)) ;; TODO: actually use areapath
  (let ((tmpdb-stack (dbr:dbstruct-dbstack dbstruct))) ;; RA => Returns the first reference in dbstruct
    (if (stack? tmpdb-stack)
	(db:get-db tmpdb-stack) ;; get previously opened db (will create new db handle if all in the stack are already used
        (let* ((toppath      (or area-path (dbr:dbstruct-area-path dbstruct) *toppath*))
	       (dbpath       (db:dbfile-path ))      ;; path to tmp db area
               (dbexists     (common:file-exists? dbpath))
	       (tmpdbfname   (conc dbpath "/megatest.db"))
	       (dbfexists    (common:file-exists? tmpdbfname))  ;; (conc dbpath "/megatest.db")))
               (mtdbexists   (common:file-exists? (conc toppath "/megatest.db")))
               
               (mtdb         (db:open-megatest-db path: area-path))
               (mtdbpath     (db:dbdat-get-path mtdb))
               (tmpdb        (db:open-megatest-db path: dbpath)) ;; lock-create-open dbpath db:initialize-main-db))
               (refndb       (db:open-megatest-db path: dbpath name: "megatest_ref.db"))
               (write-access (file-write-access? mtdbpath))
	       (mtdbmodtime  (if mtdbexists (common:lazy-sqlite-db-modification-time mtdbpath)   #f))
	       (tmpdbmodtime (if dbfexists  (common:lazy-sqlite-db-modification-time tmpdbfname) #f))
	       (modtimedelta (and mtdbmodtime tmpdbmodtime (- mtdbmodtime tmpdbmodtime))))

					'())))
				(filter cdr args-data)))))
;; (print  "Alldat: " alldat
;;         " args-data: " args-data)
    (add-z-card
     (apply construct-sdat alldat))))

;; merge/consolidate with common:simple-setup
(define (simple-setup start-dir-in)
  (let* ((start-dir (or start-dir-in "."))
	 (mtconfig  (or (args:get-arg "-config") "megatest.config"))
	 (mtconfdat (find-and-read-config        ;; NB// sets MT_RUN_AREA_HOME as side effect -> NOPE! Not if pathenvvar is #f
		     mtconfig
		     ;; environ-patt: "env-override"
		     given-toppath: start-dir
		     ;; pathenvvar: "MT_RUN_AREA_HOME"
		     ))
	 (mtconf    (if mtconfdat (car mtconfdat) #f)))
    ;; we set some dynamic data in a section called "dyndata"