;;======================================================================
;; 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 dbmod))
(declare (uses dbfile))
(declare (uses commonmod))
(declare (uses debugprint))
(module dbmod
*
(import scheme
chicken
data-structures
extras
(prefix sqlite3 sqlite3:)
posix
typed-records
srfi-1
srfi-18
srfi-69
commonmod
dbfile
debugprint
)
;; NOTE: This returns only the name "1.db", "main.db", not the path
;;
(define (dbmod:run-id->dbfname run-id)
(conc (dbfile:run-id->dbnum run-id)".db"))
(define (dbmod:get-dbdir dbstruct)
(let* ((areapath (dbr:dbstruct-areapath dbstruct))
(dbdir (conc areapath"/.megatest")))
(if (and (file-write-access? areapath)
(not (file-exists? dbdir)))
(create-directory dbdir))
dbdir))
(define (dbmod:run-id->full-dbfname dbstruct run-id)
(conc (dbmod:get-dbdir dbstruct run-id)"/"(dbmod:run-id->dbfname run-id)))
;;======================================================================
;; Read-only inmem cached direct from disk method
;;======================================================================
(define *dbmod:nfs-db-handles* (make-hash-table)) ;; dbfname -> dbstruct
(define (dbmod:nfs-get-dbstruct run-id keys init-proc areapath)
(assert areapath "FATAL: dbmod:nfs-get-dbstruct called without areapath set.")
(let* ((dbfname (dbmod:run-id->dbfname run-id))
(dbstruct (hash-table-ref/default *dbmod:nfs-db-handles* dbfname #f)))
(if dbstruct
(let* ((last-update (dbr:dbstruct-last-update dbstruct))
(curr-secs (current-seconds)))
(if (> (- curr-secs last-update) 2)
(begin
((dbr:dbstruct-sync-proc dbstruct) last-update)
(dbr:dbstruct-last-update-set! dbstruct curr-secs)))
dbstruct)
(let* ((newdbstruct (dbmod:open-dbmoddb areapath run-id dbfname init-proc keys syncdir: 'fromdisk)))
(hash-table-set! *dbmod:nfs-db-handles* dbfname newdbstruct)
newdbstruct))))
;;======================================================================
;; The inmem one-db file per server method goes in here
;;======================================================================
(define (dbmod:with-db dbstruct run-id r/w proc params)
(let* ((dbdat (dbmod:open-db dbstruct run-id (dbfile:db-init-proc)))
(dbh (dbr:dbdat-dbh dbdat))
(dbfile (dbr:dbdat-dbfile dbdat)))
(apply proc dbdat dbh params)))
(define (dbmod:open-inmem-db initproc)
(let* ((db (sqlite3:open-database ":memory:"))
(handler (sqlite3:make-busy-timeout 3600)))
(sqlite3:set-busy-handler! db handler)
(initproc db)
db))
(define (dbmod:open-db dbstruct run-id dbinit)
(or (dbr:dbstruct-dbdat dbstruct)
(let* ((dbdat (make-dbr:dbdat
dbfile: (dbr:dbstruct-dbfile dbstruct)
dbh: (dbr:dbstruct-inmem dbstruct)
)))
(dbr:dbstruct-dbdat-set! dbstruct dbdat)
dbdat)))
;; Open the inmem db and the on-disk db
;; populate the inmem db with data
;;
;; Updates fields in dbstruct
;; Returns dbstruct
;;
;; * This routine creates the db if not found
;; * Probably can get rid of the dbstruct-in
;;
(define (dbmod:open-dbmoddb areapath run-id dbfname-in init-proc keys
#!key (dbstruct-in #f)
(syncdir 'todisk))
(let* ((dbstruct (or dbstruct-in (make-dbr:dbstruct areapath: areapath)))
(dbfname (or dbfname-in (dbmod:run-id->dbfname run-id)))
(dbpath (dbmod:get-dbdir dbstruct)) ;; directory where all the .db files are kept
(dbfullname (conc dbpath"/"dbfname)) ;; (dbmod:run-id->full-dbfname dbstruct run-id))
(dbexists (file-exists? dbfullname))
(inmem (dbmod:open-inmem-db init-proc))
(write-access (file-write-access? dbpath))
(db (dbfile:with-simple-file-lock
(conc dbfullname".lock")
(lambda ()
(let* ((db (sqlite3:open-database dbfullname))
(handler (sqlite3:make-busy-timeout 136000)))
(sqlite3:set-busy-handler! db handler)
(if write-access
(init-proc db))
db))))
(tables (db:sync-all-tables-list keys)))
(dbr:dbstruct-inmem-set! dbstruct inmem)
(dbr:dbstruct-ondiskdb-set! dbstruct db)
(dbr:dbstruct-dbfile-set! dbstruct dbfullname)
(dbr:dbstruct-sync-proc-set! dbstruct
(lambda (last-update)
(if (eq? syncdir 'todisk) ;; sync to disk normally, sync from in dashboard
(dbmod:sync-tables tables last-update inmem db)
(dbmod:sync-tables tables last-update db inmem))))
(dbmod:sync-tables tables #f db inmem)
(dbr:dbstruct-last-update-set! dbstruct (current-seconds)) ;; should this be offset back in time by one second?
dbstruct))
(define (dbmod:close-db dbstruct)
;; do final sync to disk file
;; (do-sync ...)
(sqlite3:finalize! (dbr:dbstruct-ondiskdb dbstruct)))
;;======================================================================
;; Sync db
;;======================================================================
(define (dbmod:calc-use-last-update has-last-update fields last-update)
(cond
((and has-last-update
(member "last_update" fields))
#t) ;; if given a number, just use it for all fields
((number? last-update) #f) ;; if not matched first entry then ignore last-update for this table
((and (pair? last-update)
(member (car last-update) ;; last-update field name
(map car fields)))
#t)
((and last-update (not (pair? last-update)) (not (number? last-update)))
(debug:print 0 *default-log-port* "ERROR: parameter last-update for db:sync-tables must be a pair or a number, received: " last-update);; found in fields
#f)
(else
#f)))
;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) )
;; dbs are sqlite3 db handles
;;
;; if last-update specified ("field-name" . time-in-seconds)
;; then sync only records where field-name >= time-in-seconds
;; IFF field-name exists
;;
;; Use (db:sync-all-tables-list keys) to get the tbls input
;;
(define (dbmod:sync-tables tbls last-update fromdb todb)
(let ((stmts (make-hash-table)) ;; table-field => stmt
(all-stmts '()) ;; ( ( stmt1 value1 ) ( stml2 value2 ))
(numrecs (make-hash-table))
(start-time (current-milliseconds))
(tot-count 0))
(for-each ;; table
(lambda (tabledat)
(let* ((tablename (car tabledat))
(fields (cdr tabledat))
(has-last-update (member "last_update" fields))
(use-last-update (dbmod:calc-use-last-update has-last-update fields last-update))
(last-update-value (if use-last-update ;; no need to check for has-last-update - it is already accounted for
(if (number? last-update)
last-update
(cdr last-update))
#f))
(last-update-field (if use-last-update
(if (number? last-update)
"last_update"
(car last-update))
#f))
(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)
"")
";"))
(full-ins (conc "INSERT OR REPLACE INTO " tablename " ( " (string-intersperse (map car fields) ",") " ) "
" VALUES ( " (string-intersperse (make-list num-fields "?") ",") " );"))
(fromdat '())
(fromdats '())
(totrecords 0)
(batch-len 100) ;; (string->number (or (configf:lookup *configdat* "sync" "batchsize") "100")))
(todat (make-hash-table))
(count 0)
(field-names (map car fields)))
;; set up the field->num table
(for-each
(lambda (field)
(hash-table-set! field->num field count)
(set! count (+ count 1)))
fields)
;; read the source table
;; store a list of all rows in the table in fromdat, up to batch-len.
;; Then add fromdat to the fromdats list, clear fromdat and repeat.
(sqlite3:for-each-row
(lambda (a . b)
(set! fromdat (cons (apply vector a b) fromdat))
(if (> (length fromdat) batch-len)
(begin
(set! fromdats (cons fromdat fromdats))
(set! fromdat '())
(set! totrecords (+ totrecords 1)))))
fromdb
full-sel)
;; Count less than batch-len as a record
(if (> (length fromdat) 0)
(set! totrecords (+ totrecords 1)))
;; tack on remaining records in fromdat
(if (not (null? fromdat))
(set! fromdats (cons fromdat fromdats)))
(sqlite3:for-each-row
(lambda (a . b)
(hash-table-set! todat a (apply vector a b)))
todb
full-sel)
;; first pass implementation, just insert all changed rows
(let* ((db todb)
(drp-trigger (if (member "last_update" field-names)
(db:drop-trigger db tablename)
#f))
(has-last-update (member "last_update" field-names))
(is-trigger-dropped (if has-last-update
(db:is-trigger-dropped db tablename)
#f))
(stmth (sqlite3:prepare db full-ins))
(changed-rows 0))
(for-each
(lambda (fromdat-lst)
(sqlite3:with-transaction
db
(lambda ()
(for-each ;;
(lambda (fromrow)
(let* ((a (vector-ref fromrow 0))
(curr (hash-table-ref/default todat a #f))
(same #t))
(let loop ((i 0))
(if (or (not curr)
(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
(apply sqlite3:execute stmth (vector->list fromrow))
(hash-table-set! numrecs tablename (+ 1 (hash-table-ref/default numrecs tablename 0)))
(set! changed-rows (+ changed-rows 1))))))
fromdat-lst))))
fromdats)
(sqlite3:finalize! stmth)
(if (member "last_update" field-names)
(db:create-trigger db tablename)))))
tbls)
(let* ((runtime (- (current-milliseconds) start-time))
(should-print (or ;; (debug:debug-mode 12)
(common:low-noise-print 120 "db sync")
(> runtime 500)))) ;; low and high sync times treated as separate.
(for-each
(lambda (dat)
(let ((tblname (car dat))
(count (cdr dat)))
(set! tot-count (+ tot-count count))))
(sort (hash-table->alist numrecs)(lambda (a b)(> (cdr a)(cdr b))))))
tot-count))
;;======================================================================
;; Moved from dbfile
;;======================================================================
)