Megatest

(define *db-sync-in-progress* #f)                ;; if there is a sync in progress do not try to start another
(define *db-multi-sync-mutex* (make-mutex))      ;; protect access to *db-sync-in-progress*, *db-last-sync*
;; task db
(define *task-db*             #f) ;; (vector db path-to-db)
(define *db-access-allowed*   #t) ;; flag to allow access
(define *db-access-mutex*     (make-mutex))
(define *db-transaction-mutex* (make-mutex))
;; (define *db-cache-path*       #f)
(define *db-with-db-mutex*    (make-mutex))
(define *db-api-call-time*    (make-hash-table)) ;; hash of command => (list of times)
;; no sync db
(define *no-sync-db*          #f)

;; SERVER
(define *my-client-signature* #f)

      (getenv "MT_TESTSUITE_NAME")
      (if (string? *toppath* )
          (pathname-file *toppath*)
          #f))) ;; (pathname-file (current-directory)))))

(define common:get-area-name common:get-testsuite-name)

;; WARNING: This code falls back to using the global Megatest
;;          variable *toppath*
;; 
(define (common:get-db-tmp-area dbstruct)
  (if (and dbstruct (dbr:dbstruct-tmpdb-path dbstruct)) ;; *db-cache-path*
      (dbr:dbstruct-tmpdb-path) ;; *db-cache-path*
      (let ((toppath (or (and dbstruct (dbr:dbstruct-area-path dbstruct)) *toppath*))
	    (tsname  (or (and dbstruct (dbr:dbstruct-area-name dbstruct))(common:get-testsuite-name))))
	(if toppath ;; common:get-create-writeable-dir
	    (handle-exceptions
		exn
		(begin
		  (debug:print-error 0 *default-log-port* "Couldn't create path to " dbdir)
		  (exit 1))
	      (let ((dbpath (common:get-create-writeable-dir
			     (list (conc "/tmp/" (current-user-name)
					 "/megatest_localdb/"
					 tsname "/"
					 (string-translate toppath "/" ".")))))) ;;  #t))))
		;; (set! *db-cache-path* dbpath)
		(if dbstruct (dbr:dbstruct-tmpdb-path-set! dbstruct dbpath))
		dbpath))
	    #f))))

(define (common:get-area-path-signature)
  (message-digest-string (md5-primitive) *toppath*))

(define (common:get-signature str)
  (message-digest-string (md5-primitive) str))

					    (dboard:commondat-please-update commondat) 
					    (dboard:get-last-db-update tabdat context-key))))
    ;; (dboard:tabdat-last-db-update tabdat))))
    (if recalc 
	(dboard:set-last-db-update! tabdat context-key run-update-time))
    (dboard:commondat-please-update-set! commondat #f)
    recalc))

;; open the area dbs, given list of areas that are "cared about"
;;    areas: '( (area_name . path) ... ) ;; NOT necessarily the section [areas] from megatest.config
;;
(define (dboard:areas-open-areas commondat tabdat areas)
  (let ((areas-ht (dboard:commondat-areas commondat)))
    (for-each
     (lambda (area-dat)
       (db:dashboard-open-db areas (car area-dat)(cdr area-dat)))
     areas)))



(define (dboard:areas-update-tree tabdat runs-hash runs-header tb)
  (let* ((tree-path     (dboard:tabdat-tree-path tabdat))
	;; (access-mode   (dboard:tabdat-access-mode tabdat))
        ;; (run-ids (sort (filter number? (hash-table-keys runs-hash))
	;; 		(lambda (a b)
	;; 		  (let* ((record-a (hash-table-ref runs-hash a))
	;; 			 (record-b (hash-table-ref runs-hash b))
	;; 			 (time-a   (db:get-value-by-header record-a runs-header "event_time"))
	;; 			 (time-b   (db:get-value-by-header record-b runs-header "event_time")))
	;; 		    (< time-a time-b)))))
        ;; (changed      #f)
	;; (last-runs-update  (dboard:tabdat-last-runs-update tabdat))
	;; (runs-dat     (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))
    (for-each
     (lambda (area)
       (let ((run-path (list area)))
	 (if (not (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) run-path #f))
	     (begin
	       (tree:add-node tb "Areas" run-path)
	       (hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path 0)))))
     (map car areas))
    ;; here the local area
    ;;(for-each
    ;; (lambda (run-id)
    ;;   (let* ((run-record (hash-table-ref/default runs-hash run-id #f))
    ;;	      (key-vals   (map (lambda (key)(db:get-value-by-header run-record runs-header key))
    ;;			       (dboard:tabdat-keys tabdat)))
    ;;	      (run-name   (db:get-value-by-header run-record runs-header "runname"))
    ;;	      (col-name   (conc (string-intersperse key-vals "\n") "\n" run-name))
    ;;	      (run-path   (cons "local " (append key-vals (list run-name)))))
    ;;	 (if (not (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) run-path #f))
    ;;	     ;; (let ((existing   (tree:find-node tb run-path)))
    ;;	     ;;   (if (not existing)
    ;;	     (begin
    ;;	       (hash-table-set! (dboard:tabdat-run-keys tabdat) run-id run-path)
    ;;	       ;; (iup:attribute-set! (dboard:tabdat-runs-matrix tabdat)
    ;;	       ;;    		 (conc rownum ":" colnum) col-name)
    ;;	       ;; (hash-table-set! runid-to-col run-id (list colnum run-record))
    ;;	       ;; Here we update the tests treebox and tree keys
    ;;	       (tree:add-node tb "Areas" 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))
    ;;	       ))))
    ;; (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

  (tabdats            (make-hash-table))
  (update-mutex       (make-mutex))
  (updaters           (make-hash-table))
  (updating           #f)
  uidat                                   ;; needs to move to tabdat at some time
  (hide-not-hide-tabs #f)
  (current-area-path  #f)                 ;; the area of the path where the dashboard was started, if it is a megatest area
  (areas              (make-hash-table))  ;; area-name ==> dbstruct
  ;; (area-dbs           #f)                 ;; use db:dashboard-open-db to add areas to the areas hash  
  )

;; 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))
  (let* ((tnum (or tab-num
		   (dboard:commondat-curr-tab-num commondat)

(define (dboard:tabdat-make-data)
  (let ((dat (make-dboard:tabdat)))
    (dboard:setup-tabdat dat)
    (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.
  (if #f
      (dboard:tabdat-ro-set! tabdat (not (file-read-access? (dboard:tabdat-dbfpath tabdat))))
      (print "FIXME on line 350"))
  
  (dboard:tabdat-keys-set! tabdat (mrmt:get-keys))

  (refndb      #f)
  (homehost    #f) ;; not used yet
  (on-homehost #f) ;; not used yet
  (read-only   #f)
  (configdat   #f)
  (keys        #f)
  (area-path   #f)
  (area-name   #f)
  (tmpdb-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

;; return dbstruct with:
;;   read-only   - flag
;;   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 area_names => 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
;;

;; NOTE: loose ends!!
;;    db:open-db              -> not properly using tmpdb path
;;    common:get-db-tmp-area  -> using *toppath* and common:get-testsuite-area
;;    
(define (db:dashboard-open-db areas area-name 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-name)
      (hash-table-ref areas area-name)
      (if (common:file-exists? (conc area-path "/megatest.config") quiet-mode: #t)
	  (let* ((homehost (common:minimal-get-homehost area-path))
		 (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)))
	    (hash-table-set! areas area-name dbstruct)
	    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
;;

	 (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

;;
;;  should always return ( dbh . path-to-db )


;;
(define (db:get-db dbstruct) ;;  run-id) 
  (if (stack? (dbr:dbstruct-dbstack dbstruct))
      (if (stack-empty? (dbr:dbstruct-dbstack dbstruct))
          (let ((newdb (db:open-megatest-db path: (dbr:dbstruct-area-path dbstruct)))) ;; (db:dbfile-path))))
            ;; (stack-push! (dbr:dbstruct-dbstack dbstruct) newdb)
            newdb)
          (stack-pop! (dbr:dbstruct-dbstack dbstruct)))
      (db:open-db dbstruct)))

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

;;     (dbr:dbstruct-inuse-set!  dbstruct #t)
;;     (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
;;   ALWAYS returns ( dbh . path-to-db )
(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       (or (dbr:dbstruct-tmpdb-path dbstruct)
				 (db:dbfile-path dbstruct)))      ;; 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))

		(sqlite3:execute db "DELETE FROM metadat WHERE var=?;" var))))

;;======================================================================
;; no-sync.db - small bits of data to be shared between servers
;;======================================================================

(define (db:open-no-sync-db)
  (let* ((dbpath (db:dbfile-path #f))
	 (dbname (conc dbpath "/no-sync.db"))
	 (db-exists (common:file-exists? dbname))
	 (db     (sqlite3:open-database dbname)))
    (sqlite3:set-busy-handler! db (make-busy-timeout 136000))
    (if (not db-exists)
	(begin
	  (sqlite3:execute db "PRAGMA synchronous = 0;")

		   )))
    (debug:print-info 11 *default-log-port* "db:get-runs END qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count)
    (vector header res)))

;; TODO: Switch this to use max(update_time) from each run db? Then if using a server there is no disk traffic (using inmem db)
;;
(define (db:get-changed-run-ids since-time)
  (let* ((dbdir      (db:dbfile-path #f)) ;; (configf:lookup *configdat* "setup" "dbdir"))
	 (alldbs     (glob (conc dbdir "/[0-9]*.db")))
	 (changed    (filter (lambda (dbfile)
			       (> (file-modification-time dbfile) since-time))
			     alldbs)))
    (delete-duplicates
     (map (lambda (dbfile)
	    (let* ((res (string-match ".*\\/(\\d)*\\.db" dbfile)))

				 (cons 'none 0))
			     (loop (car tal)(cdr tal) newmax-cmd currmax)))))))
    (mutex-unlock! *db-stats-mutex*)
    res))

(define (mrmt:open-qry-close-locally cmd run-id params #!key (remretries 5))
  (let* ((qry-is-write   (not (member cmd api:read-only-queries)))
	 (db-file-path   (db:dbfile-path #f)) ;;  0))
	 (dbstruct-local (db:setup #t))  ;; make-dbr:dbstruct path:  dbdir local: #t)))
	 (read-only      (not (file-write-access? db-file-path)))
	 (start          (current-milliseconds))
	 (resdat         (if (not (and read-only qry-is-write))
			     (let ((v (api:execute-requests dbstruct-local (vector (symbol->string cmd) params))))
			       (handle-exceptions ;; there has been a long history of receiving strange errors from values returned by the client when things go wrong..
				exn               ;;  This is an attempt to detect that situation and recover gracefully