Megatest

           process.scm runs.scm tasks.scm tests.scm genexample.scm	\
           http-transport.scm filedb.scm tdb.scm client.scm mt.scm	\
           ezsteps.scm lock-queue.scm sdb.scm rmt.scm api.scm		\
           subrun.scm portlogger.scm archive.scm env.scm		\
           diff-report.scm cgisetup/models/pgdb.scm

# module source files
MSRCFILES = dbmod.scm dbfile.scm
# ftail.scm rmtmod.scm commonmod.scm removed
# MSRCFILES = ducttape-lib.scm pkts.scm stml2.scm cookie.scm mutils.scm	\
#             mtargs.scm commonmod.scm dbmod.scm adjutant.scm ulex.scm	\
#             rmtmod.scm apimod.scm

GUISRCF = dashboard-context-menu.scm dashboard-tests.scm		\
          dashboard-guimonitor.scm gutils.scm dcommon.scm tree.scm	\

tests.o db.o launch.o runs.o dashboard-tests.o				\
dashboard-context-menu.o dashboard-guimonitor.o dashboard-main.o	\
monitor.o dashboard.o archive.o megatest.o : db_records.scm megatest-fossil-hash.scm

tests.o runs.o dashboard.o dashboard-tests.o dashboard-context-menu.o dashboard-main.o  : run_records.scm

db.o ezsteps.o keys.o launch.o megatest.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm
db.o api.o : mofiles/dbmod.o mofiles/dbfile.o

tests.o tasks.o dashboard-tasks.o : task_records.scm

runs.o : test_records.scm

megatest.o : megatest-fossil-hash.scm megatest-version.scm

rmt.scm client.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.scm http-transport.scm index-tree.scm items.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm newdashboard.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm : common_records.scm megatest-version.scm

common_records.scm : altdb.scm

# mofiles/stml2.o : mofiles/cookie.o
# configf.o : mofiles/commonmod.o

vg.o dashboard.o : vg_records.scm megatest-version.scm

   (let* ((bup-exe               (or (configf:lookup *configdat* "archive" "bup") "bup"))
         (archive-internal-path (conc (common:get-testsuite-name) "-megatest-db/" ts "/megatest.db" ))
         (bup-restore-params  (list "-d" archive-path "restore" "-C" *toppath* archive-internal-path)))
		 (debug:print-info 2 *default-log-port* "Restoring archived data to " *toppath* " from archive in " archive-path " ... " archive-internal-path)
		 (run-n-wait bup-exe params: bup-restore-params print-cmd: "Running:"))
      (sleep 2)
      (db:multi-db-sync 
       (db:setup-db *dbstruct-dbs* *toppath* #f)
       'killservers
       ;'dejunk
       ;'adj-testids
       'old2new
       )
      (debug:print-info 1 *default-log-port* "dropping triggers to update linktree") 
      (rmt:drop-all-triggers)

;; (define *alt-log-file* #f)  ;; used by -log
(define *common:denoise*    (make-hash-table)) ;; for low noise printing
(define *default-log-port*  (current-error-port))
(define *time-zero* (current-seconds)) ;; for the watchdog
(define *default-area-tag* "local")

;; DATABASE
(define *dbstruct-dbs*         #f) ;; used to cache the dbstruct in db:setup. Goal is to remove this.
;; db stats
(define *db-stats*            (make-hash-table)) ;; hash of vectors < count duration-total >
(define *db-stats-mutex*      (make-mutex))
;; db access
(define *db-last-access*      (current-seconds)) ;; last db access, used in server
(define *db-write-access*     #t)
;; db sync

;; Force a megatest cleanup-db if version is changed and skip-version-check not specified
;; Do NOT check if not on homehost!
;;
(define (common:exit-on-version-changed)
  (if (common:on-homehost?)
      (if (common:api-changed?)
	  (let* ((mtconf (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.config"))
                 (dbfile  (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.db"))
                 (read-only (not (file-write-access? dbfile)))
                 (dbstruct (db:setup-db *dbstruct-dbs* *toppath* #f))) ;;  #t)))
	    (debug:print 0 *default-log-port*
			 "WARNING: Version mismatch!\n"
			 "   expected: " (common:version-signature) "\n"
			 "   got:      " (common:get-last-run-version))
            (cond
             ((get-environment-variable "MT_SKIP_DB_MIGRATE") #t)
             ((and (common:file-exists? mtconf) (common:file-exists? dbfile) (not read-only)

					  (string-translate *toppath* "/" "."))
				    (conc "/tmp/" (current-process-id) ;; just in case we have an issue with the dir by own user name
					  "/megatest_localdb/"
					  tsname
					  (string-translate *toppath* "/" "."))
				    ))))
		(set! *db-cache-path* dbpath)
		;; ensure megatest area has .db
		(let ((dbarea (conc *toppath* "/.db")))
		  (if (not (file-exists? dbarea))
		      (create-directory dbarea)))
		;; ensure tmp area has .db
		(let ((dbarea (conc dbpath "/.db")))
		  (if (not (file-exists? dbarea))
		      (create-directory dbarea)))
		dbpath))
	  #f)))

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

(define (common:get-signature str)

;;======================================================================
;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage
(define (common:watchdog)
  (debug:print-info 13 *default-log-port* "common:watchdog entered.")
  (if (launch:setup)
      (if (common:on-homehost?)
	  (let ((dbstruct (db:setup-db *dbstruct-dbs* *toppath* #f))) ;;  #t)))
	    (debug:print-info 13 *default-log-port* "after db:setup with dbstruct=" dbstruct)
	    (cond
	     ((dbr:dbstruct-read-only dbstruct)
	      (debug:print-info 13 *default-log-port* "loading read-only watchdog")
	      (common:readonly-watchdog dbstruct))
	     (else
	      (debug:print-info 13 *default-log-port* "loading writable-watchdog.")
              (let* ((syncer (or (configf:lookup *configdat* "server" "sync-method") "delta-sync"))) ;; "brute-force-sync")))
                (cond
                 ((equal? syncer "brute-force-sync")
                  (server:writable-watchdog-bruteforce dbstruct))
                 ((equal? syncer "delta-sync")
                  (server:writable-watchdog-deltasync dbstruct))
                 (else
                  (debug:print-error 0 *default-log-port* "Unknown server/sync-method specified ("syncer") - valid values are brute-force-sync and delta-sync.")

		       (begin
			 (set! *time-to-exit* #t)
			 #t))))
    (debug:print-info 4 *default-log-port* "starting exit process, finalizing databases.")
    (if (and no-hurry (debug:debug-mode 18))
	(rmt:print-db-stats))
    (let ((th1 (make-thread (lambda () ;; thread for cleaning up, give it five seconds
                              (if *dbstruct-dbs* (db:close-all *dbstruct-dbs*)) ;; one second allocated
			      (if *task-db*    
				  (let ((db (cdr *task-db*)))
				    (if (sqlite3:database? db)
					(begin
					  (sqlite3:interrupt! db)
					  (sqlite3:finalize! db #t)
					  ;; (vector-set! *task-db* 0 #f)

;;======================================================================
;; Copyright 2017, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

;;======================================================================

(declare (unit configfmod))
;; (declare (uses mtargs))
;; (declare (uses debugprint))
;; (declare (uses keysmod))

(module configfmod
*	

(import srfi-1
  
;;        scheme
;;
;;	big-chicken        ;; more of a reminder than anything ...
;;	chicken.base
;;	chicken.condition
;;	chicken.file
;;	chicken.io
;;	chicken.pathname
;;	chicken.port
;;	chicken.pretty-print
;;	chicken.process
;;	chicken.process-context
;;	chicken.process-context.posix
;;	chicken.sort
;;	chicken.string
;;	chicken.time
;;	chicken.eval
;;	
;;	debugprint
;;	(prefix mtargs args:)
;;	pkts
;;	keysmod
;;
;;	(prefix base64 base64:)
;;	(prefix dbi dbi:)
;;	(prefix sqlite3 sqlite3:)
;;	(srfi 18)
;;	directory-utils
;;	format
;;	matchable
;;	md5
;;	message-digest
;;	regex
;;	regex-case
;;	sparse-vectors
;;	srfi-1
;;	srfi-13
;;	srfi-69
;;	stack
;;	typed-records
;;	z3
	
	)
)

;;======================================================================
;; Database access
;;======================================================================

;; dbstruct vector containing all the relevant dbs like main.db, megatest.db, run.db etc

(use (srfi 18)
     extras
     tcp
     stack
     (prefix sqlite3 sqlite3:)
     srfi-1
     posix
     regex
     regex-case
     srfi-69
     csv-xml
     s11n
     md5
     message-digest
     (prefix base64 base64:)
     format
     dot-locking
     z3
     typed-records
     matchable)

(declare (unit db))
(declare (uses common))
(declare (uses dbmod))
(declare (uses dbfile))
(declare (uses keys))
(declare (uses ods))
(declare (uses client))
(declare (uses mt))

(include "common_records.scm")
(include "db_records.scm")
(include "key_records.scm")
(include "run_records.scm")

(define *number-of-writes* 0)
(define *number-non-write-queries* 0)




(import dbmod)













(import dbfile)

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








;;======================================================================
;; hash of hashs
;;======================================================================


(define (db:hoh-set! dat key1 key2 val)
  (let* ((subhash (hash-table-ref/default dat key1 #f)))

     (if (eq? err-status 'done)
	 default
	 (begin
	   (debug:print-error 0 *default-log-port* " query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)
	   (print-call-chain (current-error-port))
	   default)))
   (apply sqlite3:first-result db stmt params)))

(define (db:generic-error-printout exn . message)
  (print-call-chain (current-error-port))
  (apply debug:print-error 0 *default-log-port* message)
  (debug:print-error 0 *default-log-port* ;; "   params: " params
		     ", error: "     ((condition-property-accessor 'exn 'message)   exn)
		     ", arguments: " ((condition-property-accessor 'exn 'arguments) exn)
		     ", location: "  ((condition-property-accessor 'exn 'location)  exn)
		     ))

;; Get/open a database
;;    if run-id => get run specific db
;;    if #f     => get main db
;;    if run-id is a string treat it as a filename
;;    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* ((dbname (db:run-id->dbname run-id))
		 (newdb  (db:open-megatest-db path: (db:dbfile-path)
					      name: dbname)))
            ;; (stack-push! (dbr:dbstruct-dbstack dbstruct) newdb)
            newdb)
          (stack-pop! (dbr:dbstruct-dbstack dbstruct)))
      (db:open-db dbstruct run-id)))

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

;; (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 run-id)
			#f))
	 (db        (if have-struct
			(db:dbdat-get-db dbdat)
			dbstruct))
	 (fname     (db:dbdat-get-path dbdat))
	 (use-mutex (> *api-process-request-count* 25))) ;; was 25
    (if (and use-mutex

	  (db:generic-error-printout exn "ERROR: database " fname
				     " is locked. Try copying to another location, remove original and copy back."))
     (exn (permission)(db:generic-error-printout exn "ERROR: database " fname " has some permissions problem."))
     (exn ()
	  (db:generic-error-printout exn "ERROR: Unknown error with database " fname " message: "
		       ((condition-property-accessor 'exn 'message) exn))))))
      
























;; 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)

         (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 run-id #!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 run-id) ;; 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
	       (dbname       (db:run-id->dbname run-id))
               (dbexists     (common:file-exists? dbpath))
	       (mtdbfname    (conc *toppath* "/"dbname))

               (mtdbexists   (common:file-exists? mtdbfname))

               (mtdbmodtime  (if mtdbexists (common:lazy-sqlite-db-modification-time mtdbfname)  #f))

               (mtdb         (db:open-megatest-db mtdbfname))
	       ;; the reference db for syncing
	       (refdbfname   (conc dbpath "/"dbname"_ref"))
               (refndb       (db:open-megatest-db refdbfname))
               ;; (mtdbpath     (db:dbdat-get-path mtdb))
	       ;; the tmpdb
	       (tmpdbfname   (conc dbpath"/"dbname)) ;; /tmp/<stuff>/.db/[main|1,2...].db 
               (tmpdb        (db:open-megatest-db tmpdbfname)) ;; lock-create-open dbpath db:initialize-main-db))
	       (dbfexists    (common:file-exists? tmpdbfname))  ;; (conc dbpath "/megatest.db")))
	       (tmpdbmodtime (if dbfexists  (common:lazy-sqlite-db-modification-time tmpdbfname) #f))

               (write-access (file-write-access? mtdbfname))
	       ;(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)
          (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))
;))

;; set up a single db (e.g. main.db, 1.db ... etc.)
;;
(define (db:setup-db dbstructs areapath run-id)
  (let* ((dbname   (db:run-id->dbname run-id))
	 (dbstruct (or (hash-table-ref/default dbstructs dbname #f)
		       (make-dbr:dbstruct))))
    (db:open-db dbstruct run-id areapath: areapath do-sync: #t)
    (hash-table-set! dbstructs dbname dbstruct)
    dbstruct))
    

;; 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-dbs* *dbstruct-dbs*);; TODO: when multiple areas are supported, this optimization will be a hazard
   (else ;;(common:on-homehost?)

    (let* ((dbstructs (make-hash-table)))
      (when (not *toppath*)
        (debug:print-info 13 *default-log-port* "in db:setup, *toppath* not set; calling launch:setup")
        (launch:setup areapath: areapath))



      (set! *dbstruct-dbs* dbstructs)
      ;;(debug:print-info 13 *default-log-port* "new dbstruct = "(dbr:dbstruct->alist dbstruct))
      dbstructs))))
   ;; (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-megatest-db dbpath)


  (let* ((dbexists     (common:file-exists? dbpath))
	 (db           (db:lock-create-open dbpath
					    (lambda (db)
                                              (db:initialize-main-db db))))


	 (write-access (file-write-access? dbpath)))
    (debug:print-info 13 *default-log-port* "db:open-megatest-db "dbpath)
    (if (and dbexists (not write-access))
	(set! *db-write-access* #f))
    (cons db dbpath)))

;; sync run to disk if touched
;;
(define (db:sync-touched dbstruct run-id #!key (force-sync #f))
  (let ((tmpdb   (db:get-db dbstruct run-id))
	(mtdb    (dbr:dbstruct-mtdb   dbstruct))
        (refndb  (dbr:dbstruct-refndb dbstruct))
	(start-t (current-seconds)))
    (debug:print-info 4 *default-log-port* "Syncing for run-id: " run-id)
    (mutex-lock! *db-multi-sync-mutex*)
    (let ((update_info (cons (if force-sync 0 *db-last-sync*) "last_update")))
      (mutex-unlock! *db-multi-sync-mutex*)

;;  'closeall     - close all opened dbs
;;  'schema       - attempt to apply schema changes
;;  run-ids: '(1 2 3 ...) or #f (for all)
;;
(define (db:multi-db-sync dbstruct . options)
  ;; (if (not (launch:setup))
  ;;    (debug:print 0 *default-log-port* "ERROR: not able to setup up for megatest.")
  (assert #f "FATAL: Call to db:multi-db-sync which is not completed yet.")
  (let* ((mtdb     (dbr:dbstruct-mtdb dbstruct))
	 (tmpdb    (db:get-db dbstruct))
	 (refndb   (dbr:dbstruct-refndb dbstruct))
	 (allow-cleanup #t) ;; (if run-ids #f #t))
	 (servers (server:get-list *toppath*)) ;; (tasks:get-all-servers (db:delay-if-busy tdbdat)))
	 (data-synced 0)) ;; count of changed records (I hope)
    

	  (db:patch-schema-rundb  (db:dbdat-get-db tmpdb))
	  (db:patch-schema-rundb  (db:dbdat-get-db refndb))))
       
       (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb))
     options)
    data-synced))

;; Sync all changed db's
;;
(define (db:tmp->megatest.db-sync dbstruct run-id last-update)
  (let* ((dbname (db:run-id->dbname run-id))
	 (mtdb        (dbr:dbstruct-mtdb dbstruct))
	 
	 
	 ;; more to do here?
	 
	 
	 (tmpdb       (db:get-db dbstruct run-id))
	 (refndb      (dbr:dbstruct-refndb dbstruct))
	 (res         (db:sync-tables (db:sync-all-tables-list dbstruct) last-update tmpdb refndb mtdb)))
    (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb)
    res))

;;;; run-ids
;;    if #f use *db-local-sync* : or 'local-sync-flags

;;======================================================================

;; dneeded is minimum space needed, scan for existing archives that 
;; are on disks with adequate space and already have this test/itempath
;; archived
;;
(define (db:archive-get-allocations dbstruct testname itempath dneeded)
  (let* ((dbdat        (db:get-db dbstruct #f)) ;; archive tables are in main.db
	 (db           (db:dbdat-get-db dbdat))
	 (res          '())
	 (blocks       '())) ;; a block is an archive chunck that can be added too if there is space
    (sqlite3:for-each-row
     (lambda (id archive-disk-id disk-path last-du last-du-time)
       (set! res (cons (vector id archive-disk-id disk-path last-du last-du-time) res)))
     db

    (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat)
    blocks))
    
;; returns id of the record, register a disk allocated to archiving and record it's last known
;; available space
;;
(define (db:archive-register-disk dbstruct bdisk-name bdisk-path df)
  (let* ((dbdat        (db:get-db dbstruct #f)) ;; archive tables are in main.db
	 (db           (db:dbdat-get-db dbdat))
	 (res          #f))
    (sqlite3:for-each-row
     (lambda (id)
       (set! res id))
     db
     "SELECT id FROM archive_disks WHERE archive_area_name=? AND disk_path=?;"

	  (db:archive-register-disk dbstruct bdisk-name bdisk-path df)))))

;; record an archive path created on a given archive disk (identified by it's bdisk-id)
;; if path starts with / then it is full, otherwise it is relative to the archive disk
;; preference is to store the relative path.
;;
(define (db:archive-register-block-name dbstruct bdisk-id archive-path #!key (du #f))
  (let* ((dbdat        (db:get-db dbstruct #f)) ;; archive tables are in main.db
	 (db           (db:dbdat-get-db dbdat))
	 (res          #f))
    ;; first look to see if this path is already registered
    (sqlite3:for-each-row
     (lambda (id)
       (set! res id))
     db

;;======================================================================

;; NOT REWRITTEN YET!!!!!

;; runspatt is a comma delimited list of run patterns
;; keypatt-alist must contain *all* keys with an associated pattern: '( ("KEY1" "%") .. )
(define (db:extract-ods-file dbstruct outputfile keypatt-alist runspatt pathmod)
  (assert #f "FATAL: call to db:extract-ods-file which is not ported yet.")
  (let* ((keysstr  (string-intersperse (map car keypatt-alist) ","))
	 (keyqry   (string-intersperse (map (lambda (p)(conc (car p) " LIKE ? ")) keypatt-alist) " AND "))
	 (numkeys  (length keypatt-alist))
	 (test-ids '())
	 (dbdat    (db:get-db dbstruct))
	 (db       (db:dbdat-get-db dbdat))
	 (windows  (and pathmod (substring-index "\\" pathmod)))

;;======================================================================
;; Copyright 2017, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

;;======================================================================

(declare (unit dbfile))

(module dbfile
	*
	
(import scheme chicken data-structures extras)
(import (prefix sqlite3 sqlite3:)
	posix typed-records srfi-18
	srfi-69)

;;======================================================================
;;  R E C O R D S
;;======================================================================

;; each db entry is a pair ( db . dbfilepath )
;; NOTE: Need one dbr:dbstruct per main.db, 1.db ...
;;
(defstruct dbr:dbstruct
  (dbname      #f)
  (dbdats      (make-hash-table))  ;; id => dbdat
  (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)
  (stmt-cache  (make-hash-table))
  )                ;; goal is to converge on one struct for an area but for now it is too confusing
  
(defstruct dbr:dbdat
  (db          #f)    ;; should rename this to oddb for on disk db
  (tmpdb       #f)
  (dbhstack    #f)    ;; do not init with a stack
  (last-sync   0)
  (last-write  (current-seconds))
  (run-id      #f)
  (fname       #f))

; Returns the dbdat for a particular dbfile inside the area
;;
(define (dbr:dbstruct-get-dbdat dbstruct dbfile)
  (hash-table-ref/default (dbr:dbstruct-dbdats dbstruct) dbfile #f))

(define (dbr:dbstruct-dbdat-put! dbstruct dbfile db)
  (hash-table-set! (dbr:dbstruct-dbdats dbstruct) dbfile db))

(define (db:run-id->first-num run-id)
  (let* ((s (number->string run-id))
	 (l (string-length s)))
    (substring s (- l 1) l)))

;; 1234 => 4/1234.db
;;   #f => 0/main.db
;;   (abandoned the idea of num/db)
;; 
(define (db:run-id->path apath run-id)
  (conc apath"/"(db:run-id->dbname run-id)))

(define (db:dbname->path apath dbname)
  (conc apath"/"dbname))

(define (db:run-id->dbname run-id)
  (cond
   ((number? run-id) (conc ".db/" (modulo run-id 100) ".db"))
   ((not run-id)     (conc ".db/main.db"))
   (else             run-id)))
 
)

				 ;; This is were we set up the database connections
			       (let* (($   (request-vars source: 'both))
				      (dat ($ 'dat))
				      (res #f))
				 (cond
				  ((equal? (uri-path (request-uri (current-request)))
					   '(/ "api"))
				   (send-response body:    (api:process-request *dbstruct-dbs* $) ;; the $ is the request vars proc
						  headers: '((content-type text/plain)))
				   (mutex-lock! *heartbeat-mutex*)
				   (set! *db-last-access* (current-seconds))
				   (mutex-unlock! *heartbeat-mutex*))
				  ((equal? (uri-path (request-uri (current-request))) 
					   '(/ ""))
				   (send-response body: (http-transport:main-page)))

      (with-output-to-file started-file (lambda ()(print (current-process-id)))))

    (let loop ((count         0)
	       (server-state 'available)
	       (bad-sync-count 0)
	       (start-time     (current-milliseconds)))
      ;; Use this opportunity to sync the tmp db to megatest.db
      (if (not server-going) ;; *dbstruct-dbs* 
	  (begin
	    (debug:print 0 *default-log-port* "SERVER: dbprep")
	    (set! *dbstruct-dbs*  (db:setup #t)) ;;  run-id)) FIXME!!!
	    (set! server-going #t)
	    (debug:print 0 *default-log-port* "SERVER: running, megatest version: " (common:get-full-version)) ;; NOTE: the server is NOT yet marked as running in the log. We do that in the keep-running routine.
	    (thread-start! *watchdog*)))
      
      ;; when things go wrong we don't want to be doing the various queries too often
      ;; so we strive to run this stuff only every four seconds or so.
      (let* ((sync-time (- (current-milliseconds) start-time))

;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

;; Always use two or four digit decimal
;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00..

;; (declare (unit megatest-version))

(define megatest-version 1.7001)

(declare (uses tdb))
(declare (uses mt))
(declare (uses api))
(declare (uses tasks)) ;; only used for debugging.
(declare (uses env))
(declare (uses diff-report))
(declare (uses dbmod))
(declare (uses dbmod.import))
(declare (uses dbfile))
(declare (uses dbfile.import))

;; (declare (uses ftail))
;; (import ftail)

(import dbmod
	dbfile)

(define *db* #f) ;; this is only for the repl, do not use in general!!!!

(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")

    (begin
      (if (not (launch:setup))
	  (begin
	    (debug:print 0 *default-log-port* "Failed to setup, exiting") 
	    (exit 1)))
      ;; keep this one local
      ;; (open-run-close patch-db #f)
      (let ((dbstructs (db:setup #f areapath: *toppath*)))
        (common:cleanup-db dbstructs full: #t))
      (set! *didsomething* #t)))

(if (args:get-arg "-cleanup-db")
    (begin
      (if (not (launch:setup))
	  (begin
	    (debug:print 0 *default-log-port* "Failed to setup, exiting") 
	    (exit 1)))
      (let ((dbstructs (db:setup #f areapath: *toppath*)))
        (common:cleanup-db dbstructs))
      (set! *didsomething* #t)))

(if (args:get-arg "-mark-incompletes")
    (begin
      (if (not (launch:setup))
	  (begin
	    (debug:print 0 *default-log-port* "Failed to setup, exiting")

    (set! *didsomething* #t)
    (exit 0)))

(if (or (getenv "MT_RUNSCRIPT")
	(args:get-arg "-repl")
	(args:get-arg "-load"))
    (let* ((toppath (launch:setup))
	   (dbstructs (if (and toppath
                               (common:on-homehost?))
                          (db:setup #t)
                          #f))) ;; make-dbr:dbstruct path: toppath local: (args:get-arg "-local")) #f)))
      (if *toppath*
	  (cond
	   ((getenv "MT_RUNSCRIPT")
	    ;; How to run megatest scripts
	    ;;
	    ;; #!/bin/bash
	    ;;
	    ;; export MT_RUNSCRIPT=yes
	    ;; megatest << EOF
	    ;; (print "Hello world")
	    ;; (exit)
	    ;; EOF

	    (repl))
	   (else
	    (begin
	      (set! *db* dbstructs)
	      (import extras) ;; might not be needed
	      ;; (import csi)
	      (import readline)
	      (import apropos)
	      (import dbfile)
	      ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ...

	      (if *use-new-readline*
		  (begin
		    (install-history-file (get-environment-variable "HOME") ".megatest_history") ;;  [homedir] [filename] [nlines])
		    (current-input-port (make-readline-port "megatest> ")))
		  (begin

				 (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)))
	 (db-file-path    (db:dbfile-path)) ;;  0))
	 (dbstructs-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 dbstructs-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
				 (begin
				   (debug:print 0 *default-log-port* "ERROR: bad data from server " v " message: "  ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)
				   (vector #t '())) ;; should always get a vector but if something goes wrong return a dummy
				 (if (and (vector? v)
					  (> (vector-length v) 1))
				     (let ((newvec (vector (vector-ref v 0)(vector-ref v 1))))
				       newvec)           ;; by copying the vector while inside the error handler we should force the detection of a corrupted record
				     (vector #t '()))))  ;; we could also check that the returned types are valid
			      (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)

cleanup :
	killall mtest dboard -v -9 || true
	rm -rf *.log *.bak NB* logs/* .meta .db ../simpleruns/* lt

(module junk
	*

(import big-chicken
	rmtmod
	apimod
	dbmod
	srfi-18
	trace)

(trace-call-sites #t)
(trace 
  ;; db:get-tests-for-run
  ;; rmt:general-open-connection
  ;; rmt:open-main-connection
  ;; rmt:drop-conn
  ;; rmt:send-receive
  ;; rmt:log-to-main
  )

(define (make-run-id)
  (let* ((s (conc (current-process-id)))
	 (l (string-length s)))
    (string->number (substring s (- l 3) l))
    ))

(define (run)
  (let* ((th1 (make-thread
	       (lambda ()
		 (let loop ((r 0)
			    (i 1)
			    (s 0)) ;; sum
		   (let ((start-time (current-milliseconds))
			 (run-id     (+ r (make-run-id))))
		     (rmt:register-test run-id "test1" (conc "item_" i))
		     (thread-sleep! 0.01)
		     (let* ((qry-time (- (current-milliseconds) start-time))
			    (tot-query-time (+ qry-time s))
			    (avg-query-time (* 1.0 (/ tot-query-time (max i 1)))))
		       (if (> qry-time 500)
			   (print "WARNING: rmt:register-test took more than 500ms, "qry-time"ms, i="i", avg-query-time="avg-query-time))
		       (if (eq? (modulo i 100) 0)
			   (print "For run-id="run-id", "(rmt:get-keys-write)" num tests registered="i" avg-query-time="avg-query-time))
		       (if (< i 500)
			   (loop r (+ i 1) tot-query-time)
			   (if (< r 100)
			       (let* ((start-time (current-milliseconds)))
				 (print "rmt:get-keys "(rmt:get-keys)" in "(- (current-milliseconds) start-time))
				 ;;                                          run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode
				 (print "Got "(length (rmt:get-tests-for-run run-id "%"     '()    '()       #f      #f    #f     #f      #f         #f      0           #f))" tests for run "run-id)
				 (print "Average query time: "avg-query-time)
				 (loop (+ r 1) 0 tot-query-time))))))))
	       )))
    (thread-start! th1)
    (thread-join! th1)))

(run)
)

SYSTEM TEXT
RELEASE TEXT

[setup]
# Adjust max_concurrent_jobs to limit how much you load your machines
max_concurrent_jobs 50

[server]
timeout 3600
# Uncomment this to make the in-mem db into a disk based db (slower but good for debug)
# be aware that some unit tests will fail with this due to persistent data
#
# tmpdb /tmp

# This is your link path, you can move it but it is generally better to keep it stable
linktree #{getenv MT_RUN_AREA_HOME}/../simplelinks

# Valid values for state and status for steps, NB// It is not recommended you use this
[validvalues]
state start end completed

# Job tools are more advanced ways to control how your jobs are launched
[jobtools]
# useshell yes
launcher nbfake

# You can override environment variables for all your tests here
[env-override]
EXAMPLE_VAR example value

# As you run more tests you may need to add additional disks, the names are arbitrary but must be unique
[disks]
disk0 #{getenv MT_RUN_AREA_HOME}/../simpleruns

# Test requirements are specified here
[requirements]
# waiton setup
priority 0

# Iteration for your tests are controlled by the items section
# [items]
# PARTOFDAY morning noon afternoon evening night

# test_meta is a section for storing additional data on your test
[test_meta]
author matt
owner  matt
description An example test