Megatest

;; open or create the disk db file
;; create and fill the inmemory db
;; assemble into dbr:dbdat struct and return
;; 
(define (db:open-dbdat apath dbfile dbinit-proc)
  (let* (;; (dbfile   (db:run-id->path apath run-id))
	 (db       (db:open-run-db dbfile dbinit-proc))
	 ;; (inmem    (db:open-inmem-db dbinit-proc))
	 (dbdat    (make-dbr:dbdat
		    db:     #f ;; db
		    inmem:  db ;; inmem
		    ;; run-id: run-id  ;; no can do, there are many run-id values that point to single db
		    fname:  dbfile)))
    ;; now sync the disk file data into the inmemory db
    ;; (db:sync-tables (db:sync-all-tables-list) '("last_update" . 0) db inmem)
    ;; (sqlite3:finalize! db) ;; open and close every sync
    dbdat))
;; (define (db:open-dbdat apath dbfile dbinit-proc)
;;   (let* (;; (dbfile   (db:run-id->path apath run-id))
;; 	 (db       (db:open-run-db dbfile dbinit-proc))
;; 	 (inmem    (db:open-inmem-db dbinit-proc))
;; 	 (dbdat    (make-dbr:dbdat
;; 		    db:     #f ;; db
;; 		    inmem:  inmem
;; 		    ;; run-id: run-id  ;; no can do, there are many run-id values that point to single db
;; 		    fname:  dbfile)))
;;     ;; now sync the disk file data into the inmemory db
;;     (db:sync-tables (db:sync-all-tables-list) '("last_update" . 0) db inmem)
;;     (sqlite3:finalize! db) ;; open and close every sync
;;     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* ((parent-dir (pathname-directory dbfile)))
    (if (not (directory-exists? parent-dir))
	(create-directory parent-dir #t))
    (let* ((exists  (file-exists? dbfile))
	   (db      (sqlite3:open-database dbfile))
	   (handler (sqlite3:make-busy-timeout 3600)))
      (sqlite3:set-busy-handler! db handler)
      ;; (db:set-sync db) ;; we don't mind that this is slow?
      (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 dbinit-proc)
  (let* ((db      (sqlite3:open-database ":memory:"))
	 (handler (sqlite3:make-busy-timeout 3600)))
    (sqlite3:set-busy-handler! db handler)
    (dbinit-proc db) ;; NOTE: inmem must always be initialized (db:initialize-db db)
    db))

;; for debugging we have a local mode. these routines support that mode
(define *dbcache* (make-hash-table))

(define (db:cache-get-dbstruct rid apath)
  (let* ((dbname (db:run-id->dbname rid))
	 (dbfile (db:dbname->path apath dbname)))
    (or (hash-table-ref/default *dbcache* dbfile #f)
	(let* ((dbstruct (db:setup dbfile))) ;; (db:open-dbdat apath dbfile db:initialize-db)))
	  (hash-table-set! *dbcache* dbfile dbstruct)
	  dbstruct))))

(define (db:finalize-all-cache-dbstruct)
  #f)
	  

;; get and initalize dbstruct for a given run-id
;;
;;  - uses db:initialize-db to create the schema
;;
;; Make the dbstruct, call for main db at least once
;; sync disk db to inmem
;;
;; called in http-transport and replicated in rmt.scm for *local* access. 
;;
(define (db:setup db-file) ;; run-id)
  (assert *toppath* "FATAL: db:setup called before toppath is available.")
  (let* ((dbstruct (or *dbstruct-db* (make-dbr:dbstruct)))
	 #;(db-file  (db:run-id->path *toppath* run-id)))
    (db:get-dbdat dbstruct *toppath* db-file)
    (if (not *dbstruct-db*)(set! *dbstruct-db* dbstruct))
    dbstruct))

;;======================================================================
;; setting/getting a lock on the db for only one server per db
;;

  (db:with-lock-db dbfile
		(lambda (dbh dbfile)
		  (db:get-iam-server-lock dbh dbfile))))

(define (db:with-lock-db dbfile proc)
  (let* ((dbh (db:open-run-db dbfile db:initialize-db))
	 (res (proc dbh dbfile)))
    ;; (sqlite3:finalize! dbh)
    res))

;; called before db is open?
;;
(define (db:get-iam-server-lock dbh dbfname)
  (sqlite3:with-transaction
   dbh

;; ;;     (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 apath dbfile #!key (force-sync #f))
  #f) ;; disabled
;;   (let* ((dbdat       (db:get-dbdat dbstruct apath dbfile))
;; 	 (dbfullname  (conc apath "/" dbfile))
;; 	 (db          (db:open-run-db dbfullname db:initialize-db)) ;; (dbr:dbdat-db dbdat))
;; 	 (inmem       (dbr:dbdat-inmem dbdat))
;; 	 (start-t     (current-seconds))
;; 	 (last-update (dbr:dbdat-last-write dbdat))
;; 	 (last-sync   (dbr:dbdat-last-sync dbdat)))
;;     (debug:print-info 0 *default-log-port* "Syncing for dbfile: "dbfile", last-update: "last-update", last-sync: "last-sync)
;;     (mutex-lock! *db-multi-sync-mutex*)
;;     (let* ((update_info (cons "last_update" (if force-sync 0 last-update))) ;;  "last_update"))
;;     	   (need-sync   (or force-sync (>= last-update last-sync))))
;;       (if need-sync
;; 	  (begin
;; 	    (db:sync-tables (db:sync-all-tables-list) update_info inmem db)
;; 	    (dbr:dbdat-last-sync-set! dbdat start-t))
;; 	  (debug:print 0 *default-log-port* "Skipping sync as nothing touched.")))
;;     (sqlite3:finalize! db)
;;     (mutex-unlock! *db-multi-sync-mutex*)))

;; TODO: Add final sync to this
;;
#;(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.

	   (sqlite3:execute "DELETE FROM servers WHERE state LIKE 'defunct%';"))
	  (else
	   (sqlite3:execute db "vacuum;")))
	 
	 (sqlite3:finalize! db)
	 #t))))))

;; last-update is *always* a pair ( fieldname|#f . last-update-seconds|#f)
(define (db:sync-one-table fromdb todb tabledat last-update numrecs)
  (assert (pair? last-update) "FATAL: last-update must always be a pair.")
  (let* ((tablename        (car tabledat))
	 (fields           (cdr tabledat))
	 (has-last-update  (member "last_update" fields))
	 (last-update-field (or (car last-update)
				(if has-last-update
				    "last_update"










				    #f)))


	 (has-field         (member last-update-field fields))
	 (last-update-value (cdr last-update))

	 (use-last-update   (and has-field last-update-field last-update-value))




	 (num-fields (length fields))
	 (field->num (make-hash-table))
	 (num->field (apply vector (map car fields))) ;; BBHERE
	 (full-sel   (conc "SELECT " (string-intersperse (map car fields) ",") 
			   " FROM " tablename (if use-last-update ;; apply last-update criteria
						  (conc " WHERE " last-update-field " >= " last-update-value)
						  "")

			   (not (equal? (vector-ref fromrow i)(vector-ref curr i))))
		       (set! same #f))
		   (if (and same
			    (< i (- num-fields 1)))
		       (loop (+ i 1))))
		 (if (not same)
		     (begin
		       (debug:print 0 *default-log-port* "applying data "fromrow"to table "tablename", numrecs="numrecs)
		       (apply sqlite3:execute stmth (vector->list fromrow))
		       (hash-table-set! numrecs tablename (+ 1 (hash-table-ref/default numrecs tablename 0)))))))
	     fromdat-lst))))
       fromdats)
      (sqlite3:finalize! stmth)
      (if (member "last_update" field-names)
	  (db:create-trigger db tablename)))))

;; 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)
  (assert (pair? last-update) "FATAL: last-update must always be a pair")
  ;; NOTE: I'm moving all the checking OUT of this routine. Check for read/write access, existance, etc
  ;;       BEFORE calling this sync
  
  (let ((stmts       (make-hash-table)) ;; table-field => stmt
	(all-stmts   '())              ;; ( ( stmt1 value1 ) ( stml2 value2 ))
	(numrecs     (make-hash-table))
	(start-time  (current-milliseconds))

      (if should-print (debug:print 3 *default-log-port* "INFO: db sync, total run time " runtime " ms"))
      (for-each 
       (lambda (dat)
	 (let ((tblname (car dat))
	       (count   (cdr dat)))
	   (set! tot-count (+ tot-count count))
	   (if (> count 0)
	       (if should-print (debug:print 0 *default-log-port* "   "tblname" "count))))) ;; (format #f "    ~10a ~5a" tblname count))))))
       (sort (hash-table->alist numrecs)(lambda (a b)(> (cdr a)(cdr b))))))
    tot-count))

(define (db:patch-schema-rundb frundb)
  ;;
  ;; remove this some time after September 2016 (added in version v1.6031
  ;;

			  (string->number res)
			  #f)))
          (if newres
              newres
              res))
        res)))

#;(define (db:no-sync-close-db db stmt-cache)
  (db:safely-close-sqlite3-db db stmt-cache))

;; transaction protected lock aquisition
;; either:
;;    fails    returns  (#f . lock-creation-time)
;;    succeeds (returns (#t . lock-creation-time)
;; use (db:no-sync-del! db keyname) to release the lock

    (debug:print 2 *default-log-port* "NOTE: using target " (string-intersperse (map cadr keyvals) "/") " for this run")
    (if (and runname (null? (filter (lambda (x)(not x)) keyvals))) ;; there must be a better way to "apply and"
	(db:with-db
	 dbstruct #f #f
	 (lambda (db)
	   (let ((res #f))
	     (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time,contour" comma keystr ") VALUES (?,?,?,?,strftime('%s','now'),?" comma valslots ");")
		    allvals)
	     (apply sqlite3:for-each-row 
		    (lambda (id)
		      (set! res id))
		    db
		    (let ((qry (conc "SELECT id FROM runs WHERE (runname=? " andstr key=?str ");")))
		      qry)
		    qryvals)
	     (sqlite3:execute db "UPDATE runs SET state=?,status=?,event_time=strftime('%s','now') WHERE id=? AND state='deleted';" state status res)
	     res))) 
	(begin
	  (debug:print-error 0 *default-log-port* "Called without all necessary keys")
	  #f))))

;; register a test run with the db, this accesses the main.db and does NOT
;; use server api
;;
(define (db:insert-run dbstruct run-id keyvals runname state status user contour-in)
  (let* ((keys      (map car keyvals))
	 (keystr    (keys->keystr keys))
	 (contour   (or contour-in ""))  ;; empty string to force no hierarcy and be backwards compatible.
	 (comma     (if (> (length keys) 0) "," ""))
	 (andstr    (if (> (length keys) 0) " AND " ""))
	 (valslots  (keys->valslots keys)) ;; ?,?,? ...
	 (allvals   (append (list runname state status user contour) (map cadr keyvals)))
	 (qryvals   (append (list runname) (map cadr keyvals)))
	 (key=?str  (string-intersperse (map (lambda (k)(conc k "=?")) keys) " AND ")))
    (debug:print 3 *default-log-port* "keys: " keys " allvals: " allvals " keyvals: " keyvals " key=?str is " key=?str)
    (debug:print 2 *default-log-port* "NOTE: using target " (string-intersperse (map cadr keyvals) "/") " for this run")
    (if (and runname (null? (filter (lambda (x)(not x)) keyvals))) ;; there must be a better way to "apply and"
	(db:with-db
	 dbstruct #f #f
	 (lambda (db)
	   (let ((res #f))
	     (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (id,runname,state,status,owner,event_time,contour" comma keystr ") VALUES (?,?,?,?,?,strftime('%s','now'),?" comma valslots ");")
		    run-id
		    allvals)
	     (apply sqlite3:for-each-row 
		    (lambda (id)
		      (set! res id))
		    db
		    (let ((qry (conc "SELECT id FROM runs WHERE (runname=? " andstr key=?str ");")))
		      qry)

		(debug:print-info 0 *default-log-port* "Server already running at "sinfo ", while trying to register server " host":"port)
		#f) ;; server already registered
	      (begin
		(sqlite3:execute db "INSERT INTO servers (host,port,servkey,pid,ipaddr,apath,dbname) VALUES (?,?,?,?,?,?,?);"
				 host port servkey pid ipaddr apath dbname)
		(db:get-server-info dbstruct apath dbname)))))))))
  
;; run this one in a transaction where first check if host:port is taken
(define (db:deregister-server dbstruct host port servkey pid ipaddr apath dbname)
  (db:with-db
   dbstruct
   #f #f
   (lambda (db)
     (sqlite3:with-transaction
      db
      (lambda ()
	(let* ((sinfo      (db:get-server-info dbstruct apath dbname)))
	  (if (not sinfo)
	      (begin
		(debug:print-info 0 *default-log-port* "Server already removed for "apath", "dbname) ;; at "sinfo ", while trying to register server " host":"port)
		#f) ;; server already deregistered
	      (begin
		(sqlite3:execute db "DELETE FROM servers WHERE apath=? AND dbname=?;" ;; (host,port,servkey,pid,ipaddr,apath,dbname) VALUES (?,?,?,?,?,?,?);"
				 ;; host port servkey pid ipaddr
				 apath dbname)
		#;(db:get-server-info dbstruct apath dbname)))))))))

(define (db:get-server-info dbstruct apath dbname)
  (db:with-db
   dbstruct
   #f #f
   (lambda (db)
     (sqlite3:fold-row
      (lambda (res host port servkey pid ipaddr apath dbpath)
	(list host port servkey pid ipaddr apath dbpath))
      #f
      db
      "SELECT host,port,servkey,pid,ipaddr,apath,dbname FROM servers WHERE apath=? AND dbname=?;"
      apath dbname))))

(define (db:get-count-servers dbstruct apath)
  (db:with-db
   dbstruct
   #f #f
   (lambda (db)
     (sqlite3:fold-row
      (lambda (res count)
	(max res count))
      0
      db
      "SELECT count(*) FROM servers WHERE apath=?;"
      apath))))

)