;;======================================================================
;; 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))
;; (declare (uses debugprint))
(module dbfile
*
(import scheme chicken data-structures extras)
(import (prefix sqlite3 sqlite3:)
posix typed-records srfi-18
srfi-69
stack
)
;; (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)
(read-only #f)
(subdbs (make-hash-table))
)
;; NOTE: Need one dbr:subdb per main.db, 1.db ...
;;
(defstruct dbr:subdb
(dbname #f) ;; .db/1.db
(mtdb #f) ;; mtrah/.db/1.db
;; (dbdats (make-hash-table)) ;; id => dbdat
(tmpdb #f) ;; /tmp/.../.db/1.db
(refndb #f) ;; /tmp/.../.db/1.db_ref
(dbstack (make-stack)) ;; stack for tmp db handles, ????? why => do not initialize with a stack
(homehost #f) ;; not used yet
(on-homehost #f) ;; not used yet
(read-only #f)
(last-sync 0)
(last-write (current-seconds))
) ;; goal is to converge on one struct for an area but for now it is too confusing
;; need to keep dbhandles and cached statements together
(defstruct dbr:dbdat
(dbfile #f)
(dbh #f)
(stmt-cache (make-hash-table))
(read-only #f))
(define *dbstruct-dbs* #f)
(define (dbfile:run-id->key run-id)
(or run-id 'main))
(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)
(if (dbr:dbstruct? dbstruct)
;; (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* ((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))))
(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))))))
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))
;; (dbstruct (hash-table-ref/default dbstructs dbname #f)))
;; (if dbstruct
;; dbstruct
;; (let* ((dbstruct-new (make-dbr:dbstruct)))
;; (db:open-db dbstruct-new run-id areapath: areapath do-sync: #t)
;; (hash-table-set! dbstructs dbname dbstruct-new)
;; dbstruct-new))))
;; ; 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)))
;; 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 (dbfile:setup do-sync areapath)
(cond
(*dbstruct-dbs* *dbstruct-dbs*);; TODO: when multiple areas are supported, this optimization will be a hazard
(else ;;(common:on-homehost?)
(let* ((dbstructs (make-dbr:dbstruct)))
#;(when (not *toppath*)
(debug:print-info 0 *default-log-port* "in db:setup, *toppath* not set; calling launch:setup")
(launch:setup areapath: areapath))
(set! *dbstruct-dbs* dbstructs)
(dbr:dbstruct-areapath-set! dbstructs areapath)
dbstructs))))
#;(define (dbfile:get-subdb dbstruct run-id)
(let* ((res (hash-table-ref/default (dbr:dbstruct-subdbs dbstruct) (dbfile:run-id->key run-id) #f)))
(if res
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)))
(hash-table-ref/default (dbr:dbstruct-subdbs dbstruct) dbfname #f)))
;; 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-dbh dbstruct run-id) ;; RENAME TO db:get-dbh
(let* ((subdb (dbfile:get-subdb dbstruct run-id)))
(if (stack? (dbr:subdb-dbstack subdb))
(if (stack-empty? (dbr:subdb-dbstack subdb))
#f
(stack-pop! (dbr:subdb-dbstack subdb)))
#f)))
(define (dbfile:add-dbh dbstruct run-id dbh)
(let* ((subdb (dbfile:get-subdb dbstruct run-id)))
(if (not (stack? (dbr:subdb-dbstack subdb)))
(dbr:subdb-dbstack-set! subdb (make-stack)))
(stack-push! (dbr:subdb-dbstack subdb) dbh)))
;;======================================================================
;; no-sync.db - small bits of data to be shared between servers
;;======================================================================
(define (dbfile:open-no-sync-db dbpath)
(let* (;; (dbpath (db:dbfile-path))
(dbname (conc dbpath "/no-sync.db"))
(db-exists (file-exists? dbname))
(db (sqlite3:open-database dbname)))
(sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000))
(if (not db-exists)
(begin
(sqlite3:execute db "PRAGMA synchronous = 0;")
(sqlite3:execute db "CREATE TABLE IF NOT EXISTS no_sync_metadat (var TEXT,val TEXT, CONSTRAINT no_sync_metadat_constraint UNIQUE (var));")
(sqlite3:execute db "PRAGMA journal_mode=WAL;")))
db))
)