Megatest

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

;; each db entry in the hash is a dbr:dbdat
;; this record will evolve into the area record
;;
(defstruct dbr:dbstruct 
  (mtdb        #f)
  (dbdats      (make-hash-table)) ;; id => dbdat
  (read-only   #f)                ;; the area is read-only
  (stmt-cache  (make-hash-table)))

(defstruct dbr:dbdat
  (db          #f)
  (inmem       #f)
  (last-sync   0)
  (last-write  (current-seconds))
  (run-id      #f)
  (fname       #f))
  
;; Returns the dbdat for a particular run-id from dbstruct
;;
(define (dbr:dbstruct-get-dbdat v run-id)
  (hash-table-ref/default (dbr:dbstruct-dbs v) run-id #f))

(define (dbr:dbstruct-dbdat-put! v run-id db)
  (hash-table-set! (dbr:dbstruct-dbs v) run-id db))

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

(define (db:run-id->path run-id)
  (let ((firstnum (db:run-id->first-num run-id)))
    (conc *toppath* "/.dbs/"firstnum"/"run-id".db")))

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

;; Retrieve a db handle for inmemory db given run-id, open and setup both inmemory and
;; db file if needed
;;
;;    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-dbdat dbstruct run-id)
  (let* ((dbfile   (db:run-id->path run-id))
	 (dbdat    (dbr:dbstruct-get-dbdat dbstruct run-id))
	 (newdbdat (if dbdat
		       #f
		       (db:open-dbdat run-id db:setup-schema))))
    (if dbdat
	dbdat
	(begin
	  (dbr:dbstruct-dbdat-put! dbstruct newdbdat)
	  newdbdat))))


;; get the inmem db for actual db operations
;;
(define (db:get-inmem dbstruct run-id)
  (dbr:dbdat-inmem (db:get-dbdat dbstruct run-id)))

;; get the handle for the on-disk db
;;
(define (db:get-db dbstruct run-id)
  (dbr:dbdat-db (db:get-dbdat dbstruct run-id)))


;; open or create the disk db file
;; create and fill the inmemory db
;; assemble into dbr:dbdat struct and return

;; 
(define (db:open-dbdat run-id dbinit-proc)
  (let* ((dbfile   (db:run-id->path run-id))
	 (db       (db:open-run-db dbfile dbinit-proc))
	 (inmem    (db:open-inmem-db dbinit-proc))
	 (dbdat    (dbr:dbdat-make
		    db:     db
		    inmem:  inmem
		    run-id: run-id
		    fname:  dbfile)))
    ;; now sync the disk file data into the inmemory db
    (db:sync-tables (db:sync-all-tables-list) #f db inmem)
    dbdat))
    

;; open the disk database file

;; NOTE: May need to add locking to file create process here
;; returns an sqlite3 database handle
;;
(define (db:open-run-db dbfile dbinit-proc)
  (let* ((exists (file-exists? dbfile))
	 (db     (sqlite3:open-database dbfile))
	 (handler (make-busy-timeout 3600)))
    (sqlite3:set-busy-handler! db handler)
    (db:set-sync db)
    (if (not exists)

	(dbinit-proc db))

    db))
    


;; open and initialize the inmem db

;; NOTE: Does NOT sync in the data from the disk 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)
    db))

;;======================================================================
;; SQLITE3 HELPERS
;;======================================================================

(define (db:general-sqlite-error-dump exn stmt . params)
  (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) ;; RADT ... how does this work?

		     ", location: "  ((condition-property-accessor 'exn 'location)  exn)
		     ))

;; (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)
  (assert (dbr:dbstruct? dbstruct) "FATAL: db:with-db called with bad dbstruct")
  (let* ((dbdat     (db:get-dbdat dbstruct))


	 (db        (dbr:dbdat-inmem dbdat))


	 (fname     (db:dbdat-fname dbdat))
	 (use-mutex (> *api-process-request-count* 25))) ;; was 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*))
    (condition-case

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
























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




;; get last time a record was updated in either tests or runs table
;;

;;    NOTE: Takes a sqlite3 db handle, not dbstruct or dbdat







































































;;











































(define (db:get-last-update-time 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))


























;; NOTE: opens the legacy megatest.db at the top of *toppath*

;;
;;  - NOT ready for use
;;



(define (db:open-legacy-megatest-db fname)
  (let* ((dbexists     (if (equal? fname ":inmem:")
			   #f
			   (common:file-exists? dbpath)))
	 (db           (db:lock-create-open dbpath
					    (lambda (db)
                                              (db:initialize-main-db db)
					      ;;(db:initialize-run-id-db db)
					      )))
	 (write-access (file-writable? 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))
;; ;; 	(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*)
;; ;;       (db:sync-tables (db:sync-all-tables-list dbstruct) update_info tmpdb refndb mtdb))
;; ;;     (mutex-lock! *db-multi-sync-mutex*)
;; ;;     (set! *db-last-sync* start-t)
;; ;;     (set! *db-last-access* start-t)
;; ;;     (mutex-unlock! *db-multi-sync-mutex*)
;; ;;     (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb)))

;; NOTE: touched logic is disabled/not done
;; sync run to disk if touched
;;
(define (db:sync-inmem->disk dbstruct run-id #!key (force-sync #f))
  (let ((dbdat   (db:get-dbdat dbstruct run-id))
	(db      (dbr:dbdat-db dbstruct))
	(inmem   (dbr:dbdat-inmem 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"))
    ;;	   (need-sync   (or force-sync (>= last_update (dbr:dbdat-last-write dbdat)))))
    ;;  (mutex-unlock! *db-multi-sync-mutex*)
    (if #t ;; need-sync
	(db:sync-tables (db:sync-all-tables-list) update_info inmem db)
	(debug:print 0 *default-log-port* "Skipping sync as nothing touched."))
    (mutex-lock! *db-multi-sync-mutex*)
    (dbr:dbdat-last-sync-set! dbdat start-t)
    (dbr:dbdat-last-write-set! dbdat start-t)
    (mutex-unlock! *db-multi-sync-mutex*)))


(define (db:safely-close-sqlite3-db db stmt-cache #!key (try-num 3))
  (if (<= try-num 0)
      #f
      (handle-exceptions
	  exn
	(begin
	  (print "Attempt to safely close sqlite3 db failed. Trying again. exn=" exn)
	  (thread-sleep! 3)
	  (sqlite3:interrupt! db)
	  (db:safely-close-sqlite3-db db stmt-cache try-num: (- try-num 1)))
	(if (sqlite3:database? db)
	    (let* ((stmts (and stmt-cache (hash-table-ref/default stmt-cache db #f))))
	      (if stmts (map sqlite3:finalize! (hash-table-values stmts)))
	      (sqlite3:finalize! db)
	      #t)
	    #f))))

;; close all opened run-id dbs
(define (db:close-all dbstruct)
  (assert (dbr:dbstruct? dbstruct) "FATAL: db:close-all called with dbstruct not set up.")
  (handle-exceptions
   exn
   (begin
     (debug:print 0 *default-log-port* "WARNING: Finalizing failed, "  ((condition-property-accessor 'exn 'message) exn) ", note - exn=" exn)
     (print-call-chain *default-log-port*))
   ;; (db:sync-touched dbstruct 0 force-sync: #t) ;; NO. Do not do this here. Instead we rely on a server to be started when there are writes, even if the server itself is not going to be used as a server.
   (let ((tdbs       (map db:dbdat-db 
			  (hash-table-values (dbr:dbstruct-dbdats dbstruct))))


	 (stmt-cache (dbr:dbstruct-stmt-cache dbstruct)))
     (map (lambda (db)
	    (db:safely-close-sqlite3-db db stmt-cache))
	  tdbs))))
















;; just tests, test_steps and test_data tables
(define db:sync-tests-only
  (list
   ;; (list "strs"
   ;;       '("id"             #f)
   ;;       '("str"            #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  (common:get-fields *configdat*))) ;; (db:get-keys dbstruct)))
    (list
     (list "keys"
	   '("id"        #f)
	   '("fieldname" #f)
	   '("fieldtype" #f))
     (list "metadat" '("var" #f) '("val" #f))
     (append (list "runs" 

	  (else
	   (sqlite3:execute db "vacuum;")))
	 
	 (sqlite3:finalize! db)
	 #t))))))
    
;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) )
;; db's are sqlite3 handles
;;
;; if last-update specified ("field-name" . time-in-seconds)
;;    then sync only records where field-name >= time-in-seconds
;;    IFF field-name exists
;;
(define (db:sync-tables tbls last-update fromdb todb . slave-dbs)
  (handle-exceptions

     0)
   ;; this is the work to be done
   (cond
    ((not fromdb) (debug:print 3 *default-log-port* "WARNING: db:sync-tables called with fromdb missing")
     -1)
    ((not todb)   (debug:print 3 *default-log-port* "WARNING: db:sync-tables called with todb missing")
     -2)
    #;((or (not (file-exists? fromdb))(not (file-exists? todb)))
     (debug:print-info 0 *default-log-port* "db:sync-tables called but db files do not exist.") 0)
    ((not (sqlite3:database? (db:dbdat-db fromdb)))
     (debug:print-error 0 *default-log-port* "db:sync-tables called with fromdb not a database " fromdb)
     -3)
    ((not (sqlite3:database? (db:dbdat-db todb)))
     (debug:print-error 0 *default-log-port* "db:sync-tables called with todb not a database " todb)
     -4)
    ((not (file-writable? (db:dbdat-get-path todb)))
     (debug:print-error 0 *default-log-port* "db:sync-tables called with todb not a read-only database " todb)
     -5)
    ((not (null? (let ((readonly-slave-dbs
                        (filter

(define (db:dispatch-query access-mode rmt-cmd db-cmd . params)
  (if (eq? access-mode 'cached)
      (debug:print 2 *default-log-port* "not doing cached calls right now"))
;;      (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))
;; ;;   (assert *toppath* "ERROR: db:cache-for-read-only called before launch:setup. This is fatal.")
;; ;;   (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  *toppath*) ;;  (launch:setup))
;; ;; 	     (targ-db-last-mod (if (common:file-exists? target)
;; ;; 				   (file-modification-time target)
;; ;; 				   0))
;; ;; 	     (cache-db  (or (hash-table-ref/default *global-db-store* target #f)
;; ;; 			    (db:open-megatest-db path: target)))
;; ;; 	     (source-db (db:open-megatest-db path: source))
;; ;; 	     (curr-time (current-seconds))
;; ;; 	     (res      '())
;; ;; 	     (last-update (if use-last-update (cons "last_update" targ-db-last-mod) #f)))
;; ;; 	(db:sync-tables (db:sync-main-list source-db) last-update source-db cache-db)
;; ;; 	(db:sync-tables db:sync-tests-only last-update source-db cache-db)
;; ;; 	(hash-table-set! *global-db-store* target cache-db)
;; ;; 	cache-db)))

;; ;; call a proc with a cached db
;; ;;
;; (define (db:call-with-cached-db proc . params)
;;   ;; first cache the db in /tmp
;;   (let* ((cname-part (conc "megatest_cache/" (common:get-area-name)))
;; 	 (fname      (conc  (common:get-area-path-signature) ".db"))

;;  'adj-testids  - move test-ids into correct ranges
;;  'old2new      - sync megatest.db to /tmp/.../megatest.db and /tmp/.../megatest_ref.db
;;  'new2old      - sync /tmp/.../megatest.db to megatest.db and /tmp/.../megatest_ref.db (and update data_synced)
;;  '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.")
;; ;;   (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)
;; ;;     
;; ;;     (for-each
;; ;;      (lambda (option)
;; ;; 
;; ;;        (case option
;; ;; 	 ;; kill servers
;; ;; 	 ((killservers)
;; ;; 	  (for-each
;; ;; 	   (lambda (server)
;; ;;              (handle-exceptions
;; ;;              exn
;; ;;              (begin 
;; ;;                (debug:print-info 0 *default-log-port*  "Unable to get host and/or port from " server ", exn=" exn)     
;; ;;                #f)
;; ;; 	     (match-let (((mod-time host port start-time server-id 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-writable? (db:dbdat-get-path mtdb)) (db:clean-up mtdb))
;; ;; 	  (db:clean-up tmpdb)
;; ;; 	  (db:clean-up refndb))
;; ;; 
;; ;; 	 ;; sync runs, test_meta etc.
;; ;; 	 ;;
;; ;; 	 ((old2new)
;; ;; 	  (set! data-synced
;; ;; 	    (+ (db:sync-tables (db:sync-all-tables-list dbstruct) #f mtdb tmpdb refndb)
;; ;; 	       data-synced)))
;; ;; 	 
;; ;; 	 ;; now ensure all newdb data are synced to megatest.db
;; ;; 	 ;; do not use the run-ids list passed in to the function
;; ;; 	 ;;
;; ;; 	 ((new2old)
;; ;; 	  (set! data-synced
;; ;; 	    (+ (db:sync-tables (db:sync-all-tables-list dbstruct) #f tmpdb refndb mtdb)
;; ;; 	       data-synced)))
;; ;; 
;; ;; 	 ((adj-target)
;; ;; 	  (db:adj-target (db:dbdat-get-db mtdb))
;; ;; 	  (db:adj-target (db:dbdat-get-db tmpdb))
;; ;; 	  (db:adj-target (db:dbdat-get-db refndb)))
;; ;; 	 
;; ;; 	 ((schema)
;; ;; 	  (db:patch-schema-maindb (db:dbdat-get-db mtdb))
;; ;; 	  (db:patch-schema-maindb (db:dbdat-get-db tmpdb))
;; ;; 	  (db:patch-schema-maindb (db:dbdat-get-db refndb))
;; ;; 	  (db:patch-schema-rundb  (db:dbdat-get-db mtdb))
;; ;; 	  (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))
;; ;; 
;; ;; (define (db:tmp->megatest.db-sync dbstruct last-update)
;; ;;   (let* ((mtdb        (dbr:dbstruct-mtdb dbstruct))
;; ;; 	 (tmpdb       (db:get-db dbstruct))
;; ;; 	 (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
;; ;; ;;    if #t use timestamps      : or 'timestamps
;; ;; ;;
;; ;; ;;  NB// no-sync-db is the db handle, not a flag!
;; ;; ;;
;; ;; (define (db:sync-to-megatest.db dbstruct #!key (no-sync-db #f)) 
;; ;;   (let* ((start-time         (current-seconds))
;; ;; 	 (last-full-update   (if no-sync-db
;; ;; 				 (db:no-sync-get/default no-sync-db "LAST_FULL_UPDATE" 0)
;; ;; 				 0))
;; ;; 	 (full-sync-needed   (> (- start-time last-full-update) 3600)) ;; every hour do a full sync
;; ;; 	 (last-update        (if full-sync-needed

;; ;; 				 0
;; ;; 				 (if no-sync-db
;; ;; 				     (db:no-sync-get/default no-sync-db "LAST_UPDATE" 0)
;; ;; 				     0))) ;; (or (db:get-var dbstruct "LAST_UPDATE") 0))
;; ;; 	 (sync-needed        (> (- start-time last-update) 6))
;; ;; 	 (res                (if (or sync-needed ;; don't sync if a sync already occurred in the past 6 seconds
;; ;; 				     full-sync-needed)
;; ;; 				 (begin
;; ;; 				   (if no-sync-db
;; ;; 				       (begin
;; ;; 					 (if full-sync-needed (db:no-sync-set no-sync-db "LAST_FULL_UPDATE" start-time))
;; ;; 					 (db:no-sync-set no-sync-db "LAST_UPDATE" start-time)))
;; ;; 				   (db:tmp->megatest.db-sync dbstruct last-update))
;; ;; 				 0))
;; ;; 	 (sync-time           (- (current-seconds) start-time)))
;; ;;       (debug:print-info 3 *default-log-port* "Sync of newdb to olddb completed in " sync-time " seconds pid="(current-process-id))
;; ;;       (if (common:low-noise-print 30 "sync new to old")
;; ;;           (if sync-needed
;; ;;               (debug:print-info 0 *default-log-port* "Sync of " res " records from newdb to olddb completed in " sync-time " seconds pid="(current-process-id))
;; ;;               (debug:print-info 0 *default-log-port* "No sync needed, last updated " (- start-time last-update) " seconds ago")))
;; ;;       res))

;; keeping it around for debugging purposes only
#;(define (open-run-close-no-exception-handling  proc idb . params)
  (debug:print-info 11 *default-log-port* "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params)
  (print "I don't work anymore. open-run-close-no-exception-handling needs fixing or removing...")
  (exit)
  (if (or *db-write-access*

		       (add-to-queue pdb pktdat uuid (or ptype 'cmd) #f 0)
		       (debug:print 4 *default-log-port* "Added " uuid " of type " ptype " to queue"))
		     (debug:print 4 *default-log-port* "pkt: " uuid " exists, skipping...")
		     )))
	     pkts)))))
      pktsdirs))
   use-lt: use-lt))

;; ;; open an sql database inside a file lock
;; ;; returns: db existed-prior-to-opening
;; ;; RA => Returns a db handler; sets the lock if opened in writable mode
;; ;;
;; ;; (define *db-open-mutex* (make-mutex))
;; 
;; (define (db:lock-create-open fname initproc)
;;   (let* ((parent-dir   (or (pathname-directory fname)(current-directory))) ;; no parent? go local
;;          (raw-fname    (pathname-file fname))
;; 	 (dir-writable (file-writable? parent-dir))
;; 	 (file-exists  (common:file-exists? fname))
;; 	 (file-write   (if file-exists
;; 			   (file-writable? fname)
;; 			   dir-writable )))
;;     ;; (mutex-lock! *db-open-mutex*) ;; tried this mutex, not clear it helped.
;;     (if file-write ;; dir-writable
;; 	(condition-case
;;          (let* ((lockfname   (conc fname ".lock"))
;;                 (readyfname  (conc parent-dir "/.ready-" raw-fname))
;;                 (readyexists (common:file-exists? readyfname)))
;;            (if (not readyexists)
;;                (common:simple-file-lock-and-wait lockfname))
;;            (let ((db      (sqlite3:open-database fname)))
;;              (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000))
;;              (sqlite3:execute db "PRAGMA synchronous = 0;")
;;              #;(if (and (configf:lookup *configdat* "setup" "tmp_mode") (string-match "^/tmp/.*" fname))
;;                  (begin
;;                    ;;(print "DEBUG: Setting tmp_mode for " fname) 
;;                    (sqlite3:execute db (configf:lookup *configdat* "setup" "tmp_mode"))
;;                    )
;;                  )  
;;              #;(if (and (configf:lookup *configdat* "setup" "nfs_mode") (not (string-match "^/tmp/.*" fname)))
;;                  (begin
;;                    ;;(print "DEBUG: Setting nfs_mode for " fname)
;;                    (sqlite3:execute db (configf:lookup *configdat* "setup" "nfs_mode"))
;;                    )
;;                  )  
;;              #;(if (and (not (or (configf:lookup *configdat* "setup" "tmp_mode") (configf:lookup *configdat* "setup" "nfs_mode")))  
;;                       (configf:lookup *configdat* "setup" "use-wal")
;;                       (string-match "^/tmp/.*" fname)) ;; this is a file in /tmp
;;                  (sqlite3:execute db "PRAGMA journal_mode=WAL;")
;;                  (debug:print 2 *default-log-port* "Creating " fname " in NON-WAL mode."))
;;              (if (not file-exists)
;;                  (initproc db))
;;              (if (not readyexists)
;;                  (begin
;;                    (common:simple-file-release-lock lockfname)
;;                    (with-output-to-file
;;                        readyfname
;;                      (lambda ()
;;                        (print "Ready at " 
;;                               (seconds->year-work-week/day-time 
;;                                (current-seconds)))))))
;;              db))
;;          (exn (io-error)  (debug:print 0 *default-log-port* "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again."))
;;          (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))))
;;         
;; 	(condition-case
;;          (begin
;;            (debug:print 2 *default-log-port* "WARNING: opening db in non-writable dir " fname)
;;            (let ((db (sqlite3:open-database fname)))
;;              (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000))
;;              (sqlite3:execute db "PRAGMA synchronous = 0;")
;; 	     ;; (mutex-unlock! *db-open-mutex*)
;;              db))
;;          (exn (io-error)  (debug:print 0 *default-log-port* "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again."))
;;          (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 run-id)
;;   (let* ((max-stale-tmp (configf:lookup-number *configdat* "server" "filling-db-max-stale-seconds" default: 10))
;; 	 (dbpath       (common:get-db-tmp-area ))      ;; 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-writable? mtdbpath))
;; 	 (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"))
;;           
;; 	  (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)
;;           (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-times! 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))))

;; 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)))
;;       (assert *toppath* "ERROR: db:setup called before launch:setup. This is fatal.")
;;       #;(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

;;======================================================================
;; 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
;; 	db
;; 	(let ((fdb (filedb:open-db (conc *toplevel* "/db/files.db"))))
;; 	  (vector-set! dbstruct 2 fdb)
;; 	  fdb))))
;; 
;; ;; Can also be used to save arbitrary strings
;; ;;
;; (define (db:save-path dbstruct path)
;;   (let ((fdb (db:get-filedb dbstruct)))b
;;     (filedb:register-path fdb path)))
;; 
;; ;; Use to get a path. To get an arbitrary string see next define
;; ;;
;; (define (db:get-path dbstruct id)
;;   (let ((fdb (db:get-filedb dbstruct)))
;;     (filedb:get-path db id)))

;;======================================================================
;; alist-of-alists
;;======================================================================
;; 
;; (define (db:aa-set! dat key1 key2 val)
;;   (let loop ((

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

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

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

(define (db:get-cache-stmth dbstruct db stmt)
  (let* ((stmt-cache        (dbr:dbstruct-stmt-cache dbstruct))
	 (stmth             (db:hoh-get stmt-cache db stmt)))
    (or stmth
	(let* ((newstmth (sqlite3:prepare db stmt)))
	  (db:hoh-set! stmt-cache db stmt newstmth)
	  newstmth))))


)