Megatest

(declare (uses tasks))

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

(define api:write-queries
  '(

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

(define *time-zero* (current-seconds))
(define *waiting-queue*     (make-hash-table))
(define *test-meta-updated* (make-hash-table))
(define *globalexitstatus*  0) ;; attempt to work around possible thread issues
(define *passnum*           0) ;; when running track calls to run-tests or similar
(define *write-frequency*   (make-hash-table)) ;; run-id => (vector (current-seconds) 0))
(define *alt-log-file* #f)  ;; used by -log
(define *common:denoise*    (make-hash-table)) ;; for low noise printing

      (args:get-arg "-use-db-cache") ;; feels like a bad idea ...
      ))

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

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

(define (common:watchdog)
  (thread-sleep! 0.05) ;; delay for startup
  (let ((legacy-sync (common:legacy-sync-required))
	(debug-mode  (debug:debug-mode 1))
	(last-time   (current-seconds)))
    (if (or (common:legacy-sync-recommended)
	    legacy-sync)
	(let loop ()
	  ;; sync for filesystem local db writes
	  ;;
	  (let ((start-time   (current-seconds)))
	    (common:sync-to-megatest.db 'local-sync-flags)
	    (if (and debug-mode
		     (> (- start-time last-time) 60))
		(begin
		  (set! last-time start-time)
		  (debug:print-info 4 *default-log-port* "timestamp -> " (seconds->time-string (current-seconds)) ", time since start -> " (seconds->hr-min-sec (- (current-seconds) *time-zero*))))))

	  ;; keep going unless time to exit
	  ;;
	  (if (not *time-to-exit*)
	      (let delay-loop ((count 0))
		(if (and (not *time-to-exit*)
			 (< count 4)) ;; was 11, changing to 4. 
		    (begin
		      (thread-sleep! 1)
		      (delay-loop (+ count 1))))
		(loop)))
	  (if (common:low-noise-print 30)
	      (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*))))))

(define (std-exit-procedure)
  (let ((no-hurry  (if *time-to-exit* ;; hurry up
		       #f
		       (begin
			 (set! *time-to-exit* #t)
			 #t))))

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

(use canvas-draw)

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

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

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

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

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

  (dboard:tabdat-monitor-db-path-set! tabdat (conc (dboard:tabdat-dbdir tabdat) "/monitor.db"))

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

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

	(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     (db:dispatch-query (db:get-access-mode) rmt:get-key-vals db:get-key-vals run-id))
		 (tests-ht     (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals))
		 ;; GET RID OF dboard:get-tests-dat - it is superceded by dboard:get-tests-for-run-duplicate
		 ;;  dboard:get-tests-for-run-duplicate - returns a hash table
		 ;;  (dboard:get-tests-dat tabdat run-id last-update))
		 (all-test-ids (hash-table-keys tests-ht))
		 (num-tests    (length all-test-ids)))
	    ;; (print "run-struct: " run-struct)

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

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

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

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

;;
(define (db:setup run-id #!key (local #f))
  (let* ((dbdir    (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
	 (dbstruct (make-dbr:dbstruct path: dbdir local: local)))
    dbstruct))

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

  (if (eq? access-mode 'cached)
      (apply db:call-with-cached-db db-cmd params)
      (apply rmt-cmd params)))

;; return the target db handle so it can be used
;;
(define (db:cache-for-read-only source target #!key (use-last-update #f))

  (if (and (hash-table-ref/default *global-db-store* target #f)
	   (>= (file-modification-time target)(file-modification-time source)))
      (hash-table-ref *global-db-store* target)
      (let* ((toppath   (launch:setup))
	     (targ-db-last-mod (if (file-exists? target)
				   (file-modification-time target)
				   0))

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

;; options:
;;
;;  'killservers  - kills all servers
;;  'dejunk       - removes junk records

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

;; The watchdog is to keep an eye on things like db sync etc.
;;

(define *watchdog* (make-thread common:watchdog "Watchdog thread"))
































(thread-start! *watchdog*)


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

				 (cons newmax-cmd currmax)
				 (cons 'none 0))
			     (loop (car tal)(cdr tal) newmax-cmd currmax)))))))
    (mutex-unlock! *db-stats-mutex*)
    res))
	  
(define (rmt:open-qry-close-locally cmd run-id params #!key (remretries 5))
  (let* ((qry-is-write   (not (member cmd api:read-only-queries)))
	 (dbdir          (db:dbfile-path #f))
	 (dbstruct-local (if *dbstruct-db*
			     *dbstruct-db*

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

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


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

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