Megatest

(define (db:setup do-sync)
  (assert *toppath* "FATAL: db:setup called before launch:setup has been run.")
  (dbfile:setup do-sync *toppath*))

;; looks up subdb and returns it, if not found then set up
;; and then return it.
;;
(define (db:get-db dbstruct run-id)
#;(define (db:get-db dbstruct run-id)
  (let* ((res (dbfile:get-subdb dbstruct run-id)))
    (if res
	res
	(let* ((newsubdb (make-dbr:subdb)))
	  (dbfile:set-subdb dbstruct run-id newsubdb)
	  (db:open-db dbstruct run-id areapath: (dbr:dbstruct-areapath dbstruct) do-sync: #t)
	  newsubdb))))

;; (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                ;; this stuff just allows us to call with a db handle directly
			(db:get-db dbstruct run-id)
			(db:get-subdb dbstruct run-id)
			#f))
	 (db        (if have-struct                ;; this stuff just allows us to call with a db handle directly
			(dbr:dbdat-dbh dbdat)
			dbstruct))
	 (fname     (if dbdat
			(dbr:dbdat-dbfile dbdat)
			"nofilenameavailable"))

;; 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)
#;(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-write-access? parent-dir))
	 (file-exists  (common:file-exists? fname))
	 (file-write   (if file-exists
			   (file-write-access? fname)
			   dir-writable )))

         (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 #!key (areapath #f)(do-sync #t))
#;(define (db:open-db dbstruct run-id #!key (areapath #f)(do-sync #t))
  (let* ((subdb       (dbfile:get-subdb dbstruct run-id))
	 (tmpdb-stack (dbr:subdb-dbstack subdb))) 
    (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
	(db:get-subdb 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))

    ;; (cons db dbpath)))
    (make-dbr:dbdat dbfile: dbpath dbh: db read-only: (not write-access))))

;; sync run to disk if touched
;;
(define (db:sync-touched dbstruct run-id #!key (force-sync #f))
  (let* ((subdb   (dbfile:get-subdb dbstruct run-id))
	 (tmpdb   (db:get-db dbstruct run-id))
	 (tmpdb   (db:get-subdb dbstruct run-id))
	 (mtdb    (dbr:subdb-mtdb subdb))
	 (refndb  (dbr:subdb-refndb subdb))
	 (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*)

(define (db:tmp->megatest.db-sync dbstruct run-id last-update)
  (let* ((subdbs (hash-table-values (dbr:dbstruct-subdbs dbstruct)))
	 (res    '()))
    (for-each
     (lambda (subdb)
       (let* ((dbname (db:run-id->dbname run-id))
	      (mtdb   (dbr:subdb-mtdb subdb))
	      (tmpdb  (db:get-db dbstruct run-id))
	      (tmpdb  (db:get-subdb dbstruct run-id))
	      (refndb (dbr:subdb-refndb subdb))
	      (newres (db:sync-tables (db:sync-all-tables-list dbstruct) last-update tmpdb refndb mtdb)))
	 (stack-push! (dbr:subdb-dbstack subdb) tmpdb)
	 (set! res (cons newres res))))
     subdbs)
    res))

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

;; 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
  (let* ((dbdat        (db:get-subdb dbstruct #f)) ;; archive tables are in main.db
	 (db           (dbr:dbdat-dbh 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
  (let* ((dbdat        (db:get-subdb dbstruct #f)) ;; archive tables are in main.db
	 (db           (dbr:dbdat-dbh 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
  (let* ((dbdat        (db:get-subdb dbstruct #f)) ;; archive tables are in main.db
	 (db           (dbr:dbdat-dbh dbdat))
	 (res          #f))
    ;; first look to see if this path is already registered
    (sqlite3:for-each-row
     (lambda (id)
       (set! res id))
     db

	  (set! res (vector id archive-disk-id disk-path last-du last-du-time creation-time)))
	db
	"SELECT id,archive_disk_id,disk_path,last_du,last_du_time,creation_time FROM archive_blocks WHERE id=?;"
	archive-block-id)
       res))))

;; (define (db:archive-allocate-testsuite/area-to-block block-id testsuite-name areakey)
;;   (let* ((dbdat        (db:get-db dbstruct #f)) ;; archive tables are in main.db
;;   (let* ((dbdat        (db:get-subdb dbstruct #f)) ;; archive tables are in main.db
;; 	 (db           (dbr:dbdat-dbh dbdat))
;; 	 (res          '())
;; 	 (blocks       '())) ;; a block is an archive chunck that can be added too if there is space
;;     (sqlite3:for-each-row  #f)

;;======================================================================
;; L O G G I N G    D B 

	   msg))) ;; crude reply for when things go awry
    ((zmq nmsg)(with-input-from-string msg (lambda ()(deserialize))))
    (else msg))) ;; rpc

;; ; This is to be the big daddy call NOPE: Replaced by db:set-state-status-and-roll-up-items
;; ;
;; define (db:test-set-state-status dbstruct run-id test-id state status msg)
;;  (let ((dbdat  (db:get-db dbstruct run-id)))
;;  (let ((dbdat  (db:get-subdb dbstruct run-id)))
;;    (if (member state '("LAUNCHED" "REMOTEHOSTSTART"))
;; 	(db:general-call dbdat 'set-test-start-time (list test-id)))
;;    ;; (if msg
;;    ;; 	(db:general-call dbdat 'state-status-msg (list state status msg test-id))
;;    ;; 	(db:general-call dbdat 'state-status     (list state status test-id)))
;;    (db:set-state-status-and-roll-up-items dbstruct run-id test-id #f state status msg)
;;    ;; process the test_data table

;; 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))
	 (dbdat    (db:get-subdb dbstruct))
	 (db       (dbr:dbdat-dbh dbdat))
	 (windows  (and pathmod (substring-index "\\" pathmod)))
	 (tempdir  (conc "/tmp/" (current-user-name) "/" runspatt "_" (random 10000) "_" (current-process-id)))
	 (runsheader (append (list "Run Id" "Runname") ; 0 1
			     (map car keypatt-alist)   ; + N = length keypatt-alist
			     (list "Testname"          ; 2
				   "Item Path"         ; 3 

	*
	
(import scheme chicken data-structures extras)
(import (prefix sqlite3 sqlite3:)
	posix typed-records srfi-18
	srfi-69
	stack
	files
	ports
	)

;; (import debugprint)

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

;; a single Megatest area with it's multiple dbs is
;; managed in a dbstruct
;;
(defstruct dbr:dbstruct
  (areapath  #f)
  (homehost  #f)
  (tmppath   #f)
  (read-only #f)
  (subdbs (make-hash-table))
  )

;; NOTE: Need one dbr:subdb per main.db, 1.db ...
;;
(defstruct dbr:subdb

;; 	    (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* ((subdbs     (hash-table-values (dbr:dbstruct-subdbs dbstruct))))
	  (for-each
	   (lambda (subdb)
	     (let* ((tdbs       (stack->list (dbr:subdb-dbstack subdb)))
		    (mdb        (dbr:dbdat-dbh (dbr:subdb-mtdb subdb)))
		    (rdb        (dbr:dbdat-dbh (dbr:subdb-refndb subdb))))
		    (mtdbdat    (dbr:dbdat-dbh (dbr:subdb-mtdbdat subdb)))
		    #;(rdb        (dbr:dbdat-dbh (dbr:subdb-refndb subdb))))
		    
	       (map (lambda (dbdat)
		      (let* ((stmt-cache (dbr:dbdat-stmt-cache dbdat))
			     (dbh        (dbr:dbdat-dbh        dbdat)))
			(db:safely-close-sqlite3-db dbh stmt-cache)))
		    tdbs)
	       (db:safely-close-sqlite3-db mdb #f) ;; stmt-cache)     ;; (if (sqlite3:database? mdb) (sqlite3:finalize! mdb))
	       (db:safely-close-sqlite3-db rdb #f))) ;; stmt-cache))))) ;; (if (sqlite3:database? rdb) (sqlite3:finalize! rdb))))))
	       (db:safely-close-sqlite3-db mtdbdat #f) ;; stmt-cache)     ;; (if (sqlite3:database? mdb) (sqlite3:finalize! mdb))
	       #;(db:safely-close-sqlite3-db rdb #f))) ;; stmt-cache))))) ;; (if (sqlite3:database? rdb) (sqlite3:finalize! rdb))))))
	   subdbs))))
;; )

;; ;; set up a single db (e.g. main.db, 1.db ... etc.)
;; ;;
;; (define (db:setup-db dbstruct areapath run-id)
;;   (let* ((dbname   (db:run-id->dbname 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 (dbfile:run-id->path apath run-id)
  (conc apath"/"(dbfile:run-id->dbname run-id)))

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

(define (db:run-id->dbname run-id)
(define (dbfile: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)))

;; Make the dbstruct, setup up auxillary db's and call for main db at least once
;;

	res
	(let* ((newsubdb (make-dbr:subdb)))
	  (db:open-db newsubdb run-id areapath: (dbr:dbstruct-areapath dbstruct) do-sync: #t)
	  (hash-table-set! (dbr:dbstruct-subdbs dbstruct) (dbfile:run-id->key run-id) newsubdb)
	  newsubdb))))

(define (dbfile:get-subdb dbstruct run-id)
  (let* ((dbfname (db:run-id->dbname run-id)))
  (let* ((dbfname (dbfile:run-id->dbname run-id)))
    (hash-table-ref/default (dbr:dbstruct-subdbs dbstruct) dbfname #f)))

(define (dbfile:set-subdb dbstruct run-id subdb)
  (hash-table-set! (dbr:dbstruct-subdbs dbstruct) (db:run-id->dbname run-id) subdb))
  (hash-table-set! (dbr:dbstruct-subdbs dbstruct) (dbfile:run-id->dbname run-id) subdb))

;; 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 (dbfile:get-dbdat dbstruct run-id)
  (let* ((subdb (dbfile:get-subdb dbstruct run-id)))
    (if (stack-empty? (dbr:subdb-dbstack subdb))
	#f
	(stack-pop! (dbr:subdb-dbstack subdb)))))

;; return a previously opened db handle to the stack of available handles
(define (dbfile:add-dbdat dbstruct run-id dbdat)
  (let* ((subdb (dbfile:get-subdb dbstruct run-id)))
    (stack-push! (dbr:subdb-dbstack subdb) dbdat)))

;; set up a subdb
;;
(define (dbfile:init-subdb dbstruct run-id init-proc)
  (let* ((dbname    (dbfile:run-id->dbname run-id))
	 (areapath  (dbr:dbstruct-areapath dbstruct))
	 (tmppath   (dbr:dbstruct-tmppath  dbstruct))
	 (mtdbpath  (dbfile:run-id->path areapath run-id))
	 (tmpdbpath (dbfile:run-id->path tmppath run-id))
	 (mtdbdat   (dbfile:open-sqlite3-db mtdbpath init-proc))
	 (tmpdbdat  (dbfile:open-sqlite3-db tmpdbpath init-proc)) ;; push this on the stack
	 (newsubdb  (make-dbr:subdb dbname:    dbname
				    mtdbfile:  mtdbpath
				    tmpdbfile: tmpdbpath
				    mtdbdat:   mtdbdat)))
    (dbfile:add-dbdat dbstruct run-id tmpdbdat)
    (dbfile:set-subdb dbstruct run-id newsubdb)
    newsubdb)) ;; return the new subdb - but shouldn't really use it
;; returns the dbstruct with needed data populated

;; returns dbdat with dbh and dbfilepath
;;  1. if needed setup the subdb for the given run-id
;;  2. if there is no existing db handle in the stack
;;     create a new handle and return it (do NOT add
;;     it to the stack).
;;
(define (dbfile:open-db dbstruct run-id init-proc)
  (let* ((subdb (dbfile:get-subdb dbstruct run-id)))
    (if (not subdb) ;; not yet defined
	(let* ((dbname    (db:run-id->dbname run-id))
	(begin
	       (areapath  (dbr:dbstruct-areapath dbstruct))
	       (tmppath   (dbr:dbstruct-tmppath  dbstruct))
	       (mtdbpath  (db:run-id->path areapath run-id))
	       (tmpdbpath (db:run-id->path tmppath run-id))
	       (mtdbdat   (dbfile:open-sqlite3-db mtdbpath init-proc))
	       (tmpdbdat  (dbfile:open-sqlite3-db tmpdbpath init-proc)) ;; push this on the stack
	       (newsubdb  (make-dbr:subdb dbname:    dbname
					  mtdbfile:  mtdbpath
					  tmpdbfile: tmpdbpath
					  mtdbdat:   mtdbdat)))
	  (dbfile:add-dbdat dbstruct run-id tmpdbdat)
	  (dbfile:set-subdb dbstruct run-id newsubdb)
	  (dbfile:init-subdb dbstruct run-id init-proc)
	  (dbfile:open-db dbstruct run-id init-proc))
	(let* ((dbdat (dbfile:get-dbdat dbstruct run-id)))
	  (if dbdat
	      dbdat
	      (let* ((tmppath   (dbr:dbstruct-tmppath  dbstruct))
		     (tmpdbpath (db:run-id->path tmppath run-id)))
		     (tmpdbpath (dbfile:run-id->path tmppath run-id)))
		(dbfile:open-sqlite3-db tmpdbpath init-proc)))))))

;; COMBINE dbfile:open-sqlite-db and dbfile:lock-create-open
;;

;; Open the classic megatest.db file (defaults to open in toppath)
;;
;;   NOTE: returns a dbdat not a dbstruct!
;;
(define (dbfile:open-sqlite-db dbpath init-proc)
(define (dbfile:open-sqlite3-db dbpath init-proc)
  (let* ((dbexists     (file-exists? dbpath))
	 (db           ;; need locking here so multiple open
	               ;; do not collide
	               (let* ((db (sqlite3:open-database dbpath)))
			 (init-proc db))
	 (db           (dbfile:lock-create-open dbpath
	               #;(dbfile:lock-create-open dbpath
					    (lambda (db)
                                              (db:initialize-main-db db))))
                                              (init-proc db))))
	 (write-access (file-write-access? dbpath)))
    (dbfile:print-err  "db:open-megatest-db "dbpath)
    (if (and dbexists (not write-access))
    (dbfile:print-err  "db:open-sqlite-db "dbpath)
    #;(if (and dbexists (not write-access))
	(set! *db-write-access* #f))
    ;; (cons db dbpath)))
    (make-dbr:dbdat dbfile: dbpath dbh: db read-only: (not write-access))))

(define (dbfile:print-and-exit . params)
  (with-output-to-port
      (current-error-port)

    
;; 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 (dbfile:lock-create-open fname initproc)
#;(define (dbfile: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-write-access? parent-dir))
	 (file-exists  (file-exists? fname))
	 (file-write   (if file-exists
			   (file-write-access? fname)
			   dir-writable )))

	      (dbfile:print-and-exit
	       "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:init-dbstruct dbstruct run-id init-proc #!key (do-sync #t))
#;(define (db:init-dbstruct dbstruct run-id init-proc #!key (do-sync #t))
  (let* ((subdb          (dbfile:get-subdb dbstruct run-id))
	 (tmpdb-stack    (dbr:subdb-dbstack subdb)) 
	 (max-stale-tmp  (dbr:dbstruct-max-stale-secs dbstruct));; (configf:lookup-number *configdat* "server" "filling-db-max-stale-seconds" default: 10))
	   (dbpath       (dbr:dbstruct-tmppath dbstruct)) ;;  (db:dbfile-path))      ;; path to tmp db area
	   (dbname       (db:run-id->dbname run-id))
	   (dbname       (dbfile:run-id->dbname run-id))
	   (dbexists     (file-exists? dbpath))
	   (areapath     (dbr:dbstruct-areapath dbstruct))
	   (mtdbfname    (conc areapath "/"dbname))
	   (mtdbexists   (file-exists? mtdbfname))
	   (mtdbmodtime  (if mtdbexists (dbfile:lazy-sqlite-db-modification-time mtdbfname)  #f))
	   (mtdb         (db:open-sqlite-db mtdbfname init-proc))
	   ;; the reference db for syncing

(use trace test (prefix sqlite3 sqlite3:))
(import dbfile)
(trace-call-sites #t)

(trace
 ;; dbfile:get-subdb
 )

(test #f #t (dbr:dbstruct? (dbfile:setup #t *toppath*)))
(test #f #t (dbr:dbstruct? (db:setup #t)))
(define dbstruct *dbstruct-dbs*)
(test #f #f (dbfile:get-subdb dbstruct #f)) ;; get main.db (never opened yet)
(test #f #f (dbfile:get-subdb dbstruct 1))  ;; get 1.db
(test #f #t (hash-table? (dbr:dbstruct-subdbs dbstruct)))

(test #f #t (dbr:dbdat? (dbfile:get-dbdat *dbstruct-dbs* #f)))

(test #f #t (sqlite3:database? (db:open-db dbstruct #f)))
(test #f #t (sqlite3:database? (db:open-db dbstruct 1)))

(test #f #t (stack? (dbr:subdb-dbstack subdb
(test #f #f (db:get-subdb dbstruct 1))

;; (test #f #f (stack? (dbr:subdb-dbstack subdb)))
;; test #f #t (sqlite3:database? (db:open-db dbstruct #f)))
;; test #f #t (sqlite3:database? (db:open-db dbstruct 1)))
;; 
;; test #f #t (stack? (dbr:subdb-dbstack subdb
;; test #f #f (db:get-subdb dbstruct 1))
;; 
;; ; (test #f #f (stack? (dbr:subdb-dbstack subdb)))