Megatest

(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
;;======================================================================

;; each db entry is a pair ( db . dbfilepath )
;; I propose this record evolves into the area record
;;


(defstruct dbr:dbstruct 
  (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)
  )                ;; 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
  (state #f)

	 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 (stack? (dbr:dbstruct-dbstack dbstruct))
      (if (stack-empty? (dbr:dbstruct-dbstack dbstruct))
          (let ((newdb (db:open-megatest-db path: (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)
  (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 fgrom 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* ((have-struct (dbr:dbstruct? dbstruct))
         (dbdat (if have-struct 
                    (db:get-db dbstruct)
                    #f))
	 (db    (if have-struct
		    (db:dbdat-get-db dbdat)
		    dbstruct))
	 (use-mutex (> *api-process-request-count* 25)))
    (if (and use-mutex
	     (common:low-noise-print 120 "over-50-parallel-api-requests"))
	(debug:print-info 0 *default-log-port* *api-process-request-count* " parallel api requests being processed in process " (current-process-id) ", throttling access"))
    (if (common:low-noise-print 600 (conc "parallel-api-requests" *max-api-process-requests*))
	(debug:print-info 2 *default-log-port* "Parallel api request count: " *api-process-request-count* " max parallel requests: " *max-api-process-requests*))
    (handle-exceptions
     exn
     (begin
       (print-call-chain (current-error-port))
       (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))
       ;; there is no recovering at this time. exit
       (exit 50))
     (if use-mutex (mutex-lock! *db-with-db-mutex*))
     (let ((res (apply proc db params)))
       (if use-mutex (mutex-unlock! *db-with-db-mutex*))
       ;; (if (vector? dbstruct)(db:done-with dbstruct run-id r/w))
       (if dbdat (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat))
       res))))

;;======================================================================
;; K E E P   F I L E D B   I N   dbstruct
;;======================================================================

;; (define (db:get-filedb dbstruct run-id)
;;   (let ((db (vector-ref dbstruct 2)))
;;     (if db

;;     (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 common:get-db-tmp-area)

(define (db:set-sync db)
  (let ((syncprag (configf:lookup *configdat* "setup" "sychronous")))
    (sqlite3:execute db (conc "PRAGMA synchronous = " (or syncprag 0) ";")))) 

;; open an sql database inside a file lock
;; returns: db existed-prior-to-opening

         (exn (corrupt)   (debug:print 0 *default-log-port* "ERROR: database " fname " is corrupt. Repair it to proceed."))
         (exn (busy)      (debug:print 0 *default-log-port* "ERROR: database " fname " is locked. Try copying to another location, remove original and copy back."))
         (exn (permission)(debug:print 0 *default-log-port* "ERROR: database " fname " has some permissions problem."))
         (exn () (debug:print 0 *default-log-port* "ERROR: Unknown error with database " fname " message: " ((condition-property-accessor 'exn 'message) exn))))
	)))


;; 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 (areapath #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* ((max-stale-tmp (configf:lookup-number *configdat* "server" "filling-db-max-stale-seconds" default: 10))
               (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")))
							 
               (mtdbmodtime  (if mtdbexists (common:lazy-sqlite-db-modification-time (conc *toppath* "/megatest.db"))   #f))
	        		 (tmpdbmodtime (if dbfexists  (common:lazy-sqlite-db-modification-time tmpdbfname) #f)) 
               (mtdb         (db:open-megatest-db))
               (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)) ; moving this before db:open-megatest-db is called. if wal mode is on -WAL and -shm file get created with causing the  tmpdbmodtime timestamp always greater than mtdbmodtime
	       ;(tmpdbmodtime (if dbfexists  (common:lazy-sqlite-db-modification-time tmpdbfname) #f)) 
					;if wal mode is on -WAL and -shm file get created when db:open-megatest-db is called. modtimedelta will always be < 10 so db in tmp not get synced
          ;(tmpdbmodtime (if dbfexists (db:get-last-update-time (car tmpdb)) #f))    
          ;(fmt (file-modification-time tmpdbfname))
	       (modtimedelta (and mtdbmodtime tmpdbmodtime (- mtdbmodtime tmpdbmodtime))))

          (when write-access
            (sqlite3:execute (car mtdb) "drop trigger if exists update_tests_trigger")
            (sqlite3:execute (car mtdb) "drop trigger if exists update_runs_trigger"))
          
         ;(print "mtdbmodtime " mtdbmodtime " tmpdbmodtime " tmpdbmodtime " mtdbpath " mtdbpath " " (conc *toppath* "/megatest.db"))
	        ;;(debug:print-info 13 *default-log-port* "db:open-db>> mtdbpath="mtdbpath" mtdbexists="mtdbexists" and write-access="write-access)
          (if (and dbexists (not write-access))
              (begin
                (set! *db-write-access* #f)
                (dbr:dbstruct-read-only-set! dbstruct #t)))
          (dbr:dbstruct-mtdb-set!   dbstruct mtdb)
          (dbr:dbstruct-tmpdb-set!  dbstruct tmpdb)
          (dbr:dbstruct-dbstack-set! dbstruct (make-stack)) ;; BB: why a stack?  Why would the number of db's be indeterminate?  Is this a legacy of 1.db 2.db .. ?
          (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb) ;; olddb is already a (cons db path)
          (dbr:dbstruct-refndb-set! dbstruct refndb)
          ;;	    (mutex-unlock! *rundb-mutex*)
          (if (and  (or (not dbfexists)
			(and modtimedelta
			     (> modtimedelta max-stale-tmp))) ;; if db in tmp is over ten seconds older than the file in MTRA then do a sync back
		    do-sync)
	      (begin
		(debug:print 1 *default-log-port* "filling db " (db:dbdat-get-path tmpdb) " with data \n    from " (db:dbdat-get-path mtdb) " mod time delta: " modtimedelta)
		(db:sync-tables (db:sync-all-tables-list dbstruct) #f mtdb refndb tmpdb)
    ;touch tmp db to avoid wal mode wierdness  
     (set! (file-modification-time tmpdbfname) (current-seconds))  
                (debug:print-info 13 *default-log-port* "db:sync-all-tables-list done.")
                )
	      (debug:print 4 *default-log-port* " db, " (db:dbdat-get-path tmpdb) " already exists or fresh enough, not propogating data from\n     " (db:dbdat-get-path mtdb) " mod time delta: " modtimedelta) )
	  ;; (db:multi-db-sync dbstruct 'old2new))  ;; migrate data from megatest.db automatically
          tmpdb))))


(define (db:get-last-update-time db)
;	(db:with-db
;   dbstruct #f #f 
;    (lambda (db)
			(let ((last-update-time #f))
      	(sqlite3:for-each-row 
          (lambda (lup) 
             (set! last-update-time lup))     
          db    
					"select max(lup) from ( select max(last_update) as lup  from tests union select max(last_update) as lup from runs);")
        last-update-time))
;))

;; Make the dbstruct, setup up auxillary db's and call for main db at least once
;;
;; called in http-transport and replicated in rmt.scm for *local* access. 
;;
(define (db:setup do-sync #!key (areapath #f))
  ;;
  (cond
   (*dbstruct-db* *dbstruct-db*);; TODO: when multiple areas are supported, this optimization will be a hazard
   (else ;;(common:on-homehost?)
    (debug:print-info 13 *default-log-port* "db:setup entered (first time, not cached.)")
    (let* ((dbstruct (make-dbr:dbstruct)))
      (when (not *toppath*)
        (debug:print-info 13 *default-log-port* "in db:setup, *toppath* not set; calling launch:setup")
        (launch:setup areapath: areapath))
      (debug:print-info 13 *default-log-port* "Begin db:open-db")
      (db:open-db dbstruct areapath: areapath do-sync: do-sync)
      (debug:print-info 13 *default-log-port* "Done db:open-db")
      (set! *dbstruct-db* dbstruct)
      ;;(debug:print-info 13 *default-log-port* "new dbstruct = "(dbr:dbstruct->alist dbstruct))
      dbstruct))))
   ;; (else
   ;;  (debug:print 0 *default-log-port* "ERROR: attempt to open database when not on homehost. Exiting. Homehost: " (common:get-homehost))
   ;;  (exit 1))))

;; Open the classic megatest.db file (defaults to open in toppath)
;;
;;   NOTE: returns a dbdat not a dbstruct!
;;

;;(define (db:reopen-megatest-db

;; (define (db:open-inmem-db)
;;   (let* ((db      (sqlite3:open-database ":memory:"))
;; 	 (handler (make-busy-timeout 3600)))
;;     (sqlite3:set-busy-handler! db handler)
;;     (db:initialize-run-id-db db)
;;     (cons db #f)))

;; just tests, test_steps and test_data tables
(define db:sync-tests-only
  (list
   ;; (list "strs"
   ;;       '("id"             #f)
   ;;       '("str"            #f))
   (list "tests" 
	 '("id"             #f)
	 '("run_id"         #f)
	 '("testname"       #f)
	 '("host"           #f)
	 '("cpuload"        #f)
	 '("diskfree"       #f)
	 '("uname"          #f)
	 '("rundir"         #f)
	 '("shortdir"       #f)
	 '("item_path"      #f)
	 '("state"          #f)
	 '("status"         #f)
	 '("attemptnum"     #f)
	 '("final_logf"     #f)
	 '("logdat"         #f)
	 '("run_duration"   #f)
	 '("comment"        #f)
	 '("event_time"     #f)
	 '("fail_count"     #f)
	 '("pass_count"     #f)
	 '("archived"       #f)
         '("last_update"    #f))
  (list "test_steps"
	 '("id"             #f)
	 '("test_id"        #f)
	 '("stepname"       #f)
	 '("state"          #f)
	 '("status"         #f)
	 '("event_time"     #f)
	 '("comment"        #f)
	 '("logfile"        #f)
         '("last_update"    #f))
   (list "test_data"
	 '("id"             #f)
	 '("test_id"        #f)
	 '("category"       #f)
	 '("variable"       #f)
	 '("value"          #f)
	 '("expected"       #f)
	 '("tol"            #f)
	 '("units"          #f)
	 '("comment"        #f)
	 '("status"         #f)
	 '("type"           #f)
         '("last_update"    #f))))

;; needs db to get keys, this is for syncing all tables
;;
(define (db:sync-main-list dbstruct)
  (let ((keys  (db:get-keys dbstruct)))
    (list
     (list "keys"
	   '("id"        #f)
	   '("fieldname" #f)
	   '("fieldtype" #f))
     (list "metadat" '("var" #f) '("val" #f))
     (append (list "runs" 
		   '("id"  #f))
	     (map (lambda (k)(list k #f))
		  (append keys
			  (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count" "contour" "last_update"))))
     (list "test_meta"
	   '("id"             #f)
	   '("testname"       #f)
	   '("owner"          #f)
	   '("description"    #f)
	   '("reviewed"       #f)
	   '("iterated"       #f)
	   '("avg_runtime"    #f)
	   '("avg_disk"       #f)
	   '("tags"           #f)
	   '("jobgroup"       #f)))))

(define (db:sync-all-tables-list dbstruct)
  (append (db:sync-main-list dbstruct)
	  db:sync-tests-only))

;; use bunch of Unix commands to try to break the lock and recreate the db
;;
(define (db:move-and-recreate-db dbdat)
  (let* ((dbpath   (db:dbdat-get-path        dbdat))
	 (dbdir    (pathname-directory       dbpath))
	 (fname    (pathname-strip-directory dbpath))

	   (lambda (server)
	     (match-let (((mod-time host port start-time pid) server))
	       (if (and host pid)
		   (tasks:kill-server host pid))))
	   servers)

          ;; /tmp/bjbarcla/megatest_localdb/fullrun/.nfs.pdx.disks.icf_env_disk001.bjbarcla.gwa.issues.mtdev.matt-bisect.megatest.ext-tests.runs.all.v1.65.1.6524.dev.bb-24-justrollup-f8.rollup.fullrun/megatest.db.lock
          (delete-file* (common:get-sync-lock-filepath))
          )
	 
	 ;; clear out junk records
	 ;;
	 ((dejunk)
	  (db:delay-if-busy mtdb) ;; ok to delay on mtdb
	  (when (file-write-access? (db:dbdat-get-path mtdb)) (db:clean-up 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))
	 (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;")

;; use a global for some primitive caching, it is just silly to
;; re-read the db over and over again for the keys since they never
;; change

;; why get the keys from the db? why not get from the *configdat*
;; using keys:config-get-fields?

(define (db:get-keys dbstruct)
  (if *db-keys* *db-keys* 
      (let ((res '()))
	(db:with-db dbstruct #f #f
		    (lambda (db)
		      (sqlite3:for-each-row 
		       (lambda (key)
			 (set! res (cons key res)))
		       db
		       "SELECT fieldname FROM keys ORDER BY id DESC;")))
	(set! *db-keys* res)
	res)))

;; look up values in a header/data structure
(define (db:get-value-by-header row header field)
  (if (or (null? header) (not row))
      #f
      (let loop ((hed (car header))
                 (tal (cdr header))
                 (n   0))

		   )))
    (debug:print-info 11 *default-log-port* "db:get-runs END qrystr: " qrystr " target: " target " offset: " offset " limit: " count)
    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)) ;; (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)))

     results)
    ;; brutal clean up
    (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat)
    (system "rm -rf tempdir")))

;; (db:extract-ods-file db "outputfile.ods" '(("sysname" "%")("fsname" "%")("datapath" "%")) "%")