Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -135,11 +135,11 @@ (define *default-log-port* (current-error-port)) (define *time-zero* (current-seconds)) ;; for the watchdog (define *default-area-tag* "local") ;; DATABASE -(define *dbstruct-db* #f) ;; used to cache the dbstruct in db:setup. Goal is to remove this. +(define *dbstruct-dbs* #f) ;; used to cache the dbstruct in db:setup. Goal is to remove this. ;; db stats (define *db-stats* (make-hash-table)) ;; hash of vectors < count duration-total > (define *db-stats-mutex* (make-mutex)) ;; db access (define *db-last-access* (current-seconds)) ;; last db access, used in server @@ -979,10 +979,14 @@ "/megatest_localdb/" tsname (string-translate *toppath* "/" ".")) )))) (set! *db-cache-path* dbpath) + ;; ensure megatest area has .db + (let ((dbarea (conc *toppath* "/.db"))) + (if (not (file-exists? dbarea)) + (create-directory dbarea))) dbpath)) #f))) (define (common:get-area-path-signature) (message-digest-string (md5-primitive) *toppath*)) @@ -1045,11 +1049,11 @@ ((dbr:dbstruct-read-only dbstruct) (debug:print-info 13 *default-log-port* "loading read-only watchdog") (common:readonly-watchdog dbstruct)) (else (debug:print-info 13 *default-log-port* "loading writable-watchdog.") - (let* ((syncer (or (configf:lookup *configdat* "server" "sync-method") "brute-force-sync"))) + (let* ((syncer (or (configf:lookup *configdat* "server" "sync-method") "delta-sync"))) ;; "brute-force-sync"))) (cond ((equal? syncer "brute-force-sync") (server:writable-watchdog-bruteforce dbstruct)) ((equal? syncer "delta-sync") (server:writable-watchdog-deltasync dbstruct)) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -29,10 +29,11 @@ (import (prefix sqlite3 sqlite3:)) (import (prefix base64 base64:)) (declare (unit db)) (declare (uses common)) +(declare (uses dbmod)) (declare (uses keys)) (declare (uses ods)) (declare (uses client)) (declare (uses mt)) @@ -41,45 +42,84 @@ (include "key_records.scm") (include "run_records.scm") (define *number-of-writes* 0) (define *number-non-write-queries* 0) + +(import dbmod) ;;====================================================================== ;; R E C O R D S ;;====================================================================== ;; each db entry is a pair ( db . dbfilepath ) -;; I propose this record evolves into the area record +;; NOTE: Need one dbr:dbstruct per main.db, 1.db ... ;; -(defstruct dbr:dbstruct - (tmpdb #f) - (dbstack #f) ;; stack for tmp db handles, do not initialize with a stack - (mtdb #f) - (refndb #f) +(defstruct dbr:dbstruct + (dbname #f) + (dbdats (make-hash-table)) ;; id => dbdat + ;; (tmpdbs #f) + ;; (dbstack #f) ;; stack for tmp db handles, do not initialize with a stack + ;; (mtdb #f) + ;; (refndb #f) (homehost #f) ;; not used yet (on-homehost #f) ;; not used yet (read-only #f) - (stmt-cache (make-hash-table)) + ;; (stmt-cache (make-hash-table)) ) ;; goal is to converge on one struct for an area but for now it is too confusing +(defstruct dbr:dbdat + (db #f) ;; should rename this to oddb for on disk db + (tmpdb #f) + (dbhstack #f) ;; do not init with a stack + (last-sync 0) + (last-write (current-seconds)) + (run-id #f) + (fname #f)) +; 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)) + +;; (let ((firstnum (if run-id +;; (db:run-id->first-num run-id) +;; "0"))) +;; (conc *toppath* "/.dbs/" ;; firstnum"/" +;; (or run-id "main")".db"))) + +(define (db:run-id->dbname run-id) + (if (number? run-id) + (conc ".db/" (modulo run-id 100) ".db") + (conc ".db/main.db"))) + ;; record for keeping state,status and count for doing roll-ups in ;; iterated tests ;; (defstruct dbr:counts (state #f) (status #f) (count 0)) -;;====================================================================== -;; alist-of-alists -;;====================================================================== -;; -;; (define (db:aa-set! dat key1 key2 val) -;; (let loop (( - ;;====================================================================== ;; hash of hashs ;;====================================================================== @@ -127,26 +167,38 @@ (begin (debug:print-error 0 *default-log-port* " query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn) (print-call-chain (current-error-port)) default))) (apply sqlite3:first-result db stmt params))) + +(define (db:generic-error-printout exn . message) + (print-call-chain (current-error-port)) + (apply debug:print-error 0 *default-log-port* message) + (debug:print-error 0 *default-log-port* ;; " params: " params + ", error: " ((condition-property-accessor 'exn 'message) exn) + ", arguments: " ((condition-property-accessor 'exn 'arguments) exn) + ", location: " ((condition-property-accessor 'exn 'location) exn) + )) ;; 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 (db:get-db dbstruct) ;; run-id) +(define (db:get-db dbstruct run-id) (if (stack? (dbr:dbstruct-dbstack dbstruct)) (if (stack-empty? (dbr:dbstruct-dbstack dbstruct)) - (let ((newdb (db:open-megatest-db path: (db:dbfile-path)))) + (let* ((dbname (db:run-id->dbname run-id)) + (newdb (db:open-megatest-db path: (db:dbfile-path) + name: dbname))) ;; (stack-push! (dbr:dbstruct-dbstack dbstruct) newdb) newdb) (stack-pop! (dbr:dbstruct-dbstack dbstruct))) - (db:open-db dbstruct))) + (db:open-db dbstruct run-id))) ;; ;; legacy handling of structure for managing db's. Refactor this into dbr:? (define (db:dbdat-get-db dbdat) (if (pair? dbdat) (car dbdat) @@ -170,11 +222,11 @@ ;; 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 - (db:get-db dbstruct) + (db:get-db dbstruct run-id) #f)) (db (if have-struct (db:dbdat-get-db dbdat) dbstruct)) (fname (db:dbdat-get-path dbdat)) @@ -202,33 +254,10 @@ (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)))))) -;;====================================================================== -;; 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))) ;; NB// #f => return dbdir only ;; (was planned to be; zeroth db with name=main.db) ;; ;; If run-id is #f return to create and retrieve the path where the db will live. @@ -315,28 +344,33 @@ ))) ;; 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 #!key (areapath #f)(do-sync #t)) ;; TODO: actually use areapath +(define (db:open-db dbstruct run-id #!key (areapath #f)(do-sync #t)) ;; TODO: actually use areapath (let ((tmpdb-stack (dbr:dbstruct-dbstack dbstruct))) ;; RA => Returns the first reference in dbstruct (if (stack? tmpdb-stack) (db:get-db tmpdb-stack) ;; 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)) - (tmpdbfname (conc dbpath "/megatest.db")) + (mtdbfname (conc *toppath* "/.db/"dbname)) + (mtdbexists (common:file-exists? mtdbfname)) + (mtdbmodtime (if mtdbexists (common:lazy-sqlite-db-modification-time mtdbfname) #f)) + (mtdb (db:open-megatest-db mtdbfname)) + ;; the reference db for syncing + (refdbfname (conc dbpath "/ref_"dbname)) + (refndb (db:open-megatest-db refdbfname)) + ;; (mtdbpath (db:dbdat-get-path mtdb)) + ;; the tmpdb + (tmpdbfname (conc dbpath"/"dbname)) ;; /tmp//.db/[main|1,2...].db + (tmpdb (db:open-megatest-db tmpdbfname)) ;; lock-create-open dbpath db:initialize-main-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-write-access? mtdbpath)) + (tmpdbmodtime (if dbfexists (common:lazy-sqlite-db-modification-time tmpdbfname) #f)) + + (write-access (file-write-access? mtdbfname)) ;(mtdbmodtime (if mtdbexists (common:lazy-sqlite-db-modification-time mtdbpath) #f)) ; moving this before db:open-megatest-db is called. if wal mode is on -WAL and -shm file get created with causing the tmpdbmodtime timestamp always greater than mtdbmodtime ;(tmpdbmodtime (if dbfexists (common:lazy-sqlite-db-modification-time tmpdbfname) #f)) ;if wal mode is on -WAL and -shm file get created when db:open-megatest-db is called. modtimedelta will always be < 10 so db in tmp not get synced ;(tmpdbmodtime (if dbfexists (db:get-last-update-time (car tmpdb)) #f)) ;(fmt (file-modification-time tmpdbfname)) @@ -344,12 +378,12 @@ (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")) - ;(print "mtdbmodtime " mtdbmodtime " tmpdbmodtime " tmpdbmodtime " mtdbpath " mtdbpath " " (conc *toppath* "/megatest.db")) - ;;(debug:print-info 13 *default-log-port* "db:open-db>> mtdbpath="mtdbpath" mtdbexists="mtdbexists" and write-access="write-access) + ;; (print "mtdbmodtime " mtdbmodtime " tmpdbmodtime " tmpdbmodtime " mtdbpath " mtdbpath " " (conc *toppath* "/megatest.db")) + ;; (debug:print-info 13 *default-log-port* "db:open-db>> mtdbpath="mtdbpath" mtdbexists="mtdbexists" and write-access="write-access) (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) @@ -362,12 +396,12 @@ (> 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-modification-time tmpdbfname) (current-seconds)) + ;; touch tmp db to avoid wal mode wierdness + (set! (file-modification-time 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)))) @@ -383,31 +417,38 @@ (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)) ;)) + +;; set up a single db (e.g. main.db, 1.db ... etc.) +;; +(define (db:setup-db dbstructs run-id) + (let* ((dbname (db:run-id->dbname run-id)) + (dbstruct (or (hash-table-ref/default dbstructs dbname #f) + (make-dbr:dbstruct)))) + (db:open-db dbstruct run-id areapath: areapath do-sync: do-sync) + (hash-table-set! dbstructs dbname dbstruct) + dbstruct)) + ;; 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 + (*dbstruct-dbs* *dbstruct-dbs*);; 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))) + (let* ((dbstructs (make-hash-table))) (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) + (set! *dbstruct-dbs* dbstructs) ;;(debug:print-info 13 *default-log-port* "new dbstruct = "(dbr:dbstruct->alist dbstruct)) - dbstruct)))) + dbstructs)))) ;; (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) @@ -415,19 +456,15 @@ ;; NOTE: returns a dbdat not a dbstruct! ;; ;;(define (db:reopen-megatest-db -(define (db:open-megatest-db #!key (path #f)(name #f)) - (let* ((dbdir (or path *toppath*)) - (dbpath (conc dbdir "/" (or name "megatest.db"))) - (dbexists (common:file-exists? dbpath)) +(define (db:open-megatest-db dbpath) + (let* ((dbexists (common:file-exists? dbpath)) (db (db:lock-create-open dbpath (lambda (db) - (db:initialize-main-db db) - ;;(db:initialize-run-id-db db) - ))) + (db:initialize-main-db db)))) (write-access (file-write-access? 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))) @@ -1135,12 +1172,20 @@ (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)) +;; Sync all changed db's +;; +(define (db:tmp->megatest.db-sync dbstruct run-id last-update) + (let* ((dbname (db:run-id->dbname run-id)) + (mtdb (dbr:dbstruct-mtdb dbstruct)) + + + ;; more to do here? + + (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)) Index: megatest-version.scm ================================================================== --- megatest-version.scm +++ megatest-version.scm @@ -18,6 +18,6 @@ ;; Always use two or four digit decimal ;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00.. ;; (declare (unit megatest-version)) -(define megatest-version 1.6589) +(define megatest-version 1.7001) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -39,12 +39,17 @@ (declare (uses mt)) (declare (uses api)) (declare (uses tasks)) ;; only used for debugging. (declare (uses env)) (declare (uses diff-report)) +(declare (uses dbmod)) +(declare (uses dbmod.import)) + ;; (declare (uses ftail)) ;; (import ftail) + +(import dbmod) (define *db* #f) ;; this is only for the repl, do not use in general!!!! (include "common_records.scm") (include "key_records.scm") ADDED tests/simplerun/Makefile Index: tests/simplerun/Makefile ================================================================== --- /dev/null +++ tests/simplerun/Makefile @@ -0,0 +1,5 @@ + +cleanup : + killall mtest dboard -v -9 || true + rm -rf *.log *.bak NB* logs/* .meta .db ../simpleruns/* lt + ADDED tests/simplerun/debug.scm Index: tests/simplerun/debug.scm ================================================================== --- /dev/null +++ tests/simplerun/debug.scm @@ -0,0 +1,61 @@ + +(module junk + * + +(import big-chicken + rmtmod + apimod + dbmod + srfi-18 + trace) + +(trace-call-sites #t) +(trace + ;; db:get-tests-for-run + ;; rmt:general-open-connection + ;; rmt:open-main-connection + ;; rmt:drop-conn + ;; rmt:send-receive + ;; rmt:log-to-main + ) + +(define (make-run-id) + (let* ((s (conc (current-process-id))) + (l (string-length s))) + (string->number (substring s (- l 3) l)) + )) + +(define (run) + (let* ((th1 (make-thread + (lambda () + (let loop ((r 0) + (i 1) + (s 0)) ;; sum + (let ((start-time (current-milliseconds)) + (run-id (+ r (make-run-id)))) + (rmt:register-test run-id "test1" (conc "item_" i)) + (thread-sleep! 0.01) + (let* ((qry-time (- (current-milliseconds) start-time)) + (tot-query-time (+ qry-time s)) + (avg-query-time (* 1.0 (/ tot-query-time (max i 1))))) + (if (> qry-time 500) + (print "WARNING: rmt:register-test took more than 500ms, "qry-time"ms, i="i", avg-query-time="avg-query-time)) + (if (eq? (modulo i 100) 0) + (print "For run-id="run-id", "(rmt:get-keys-write)" num tests registered="i" avg-query-time="avg-query-time)) + (if (< i 500) + (loop r (+ i 1) tot-query-time) + (if (< r 100) + (let* ((start-time (current-milliseconds))) + (print "rmt:get-keys "(rmt:get-keys)" in "(- (current-milliseconds) start-time)) + ;; run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode + (print "Got "(length (rmt:get-tests-for-run run-id "%" '() '() #f #f #f #f #f #f 0 #f))" tests for run "run-id) + (print "Average query time: "avg-query-time) + (loop (+ r 1) 0 tot-query-time)))))))) + ))) + (thread-start! th1) + (thread-join! th1))) + +(run) +) + + Index: tests/simplerun/megatest.config ================================================================== --- tests/simplerun/megatest.config +++ tests/simplerun/megatest.config @@ -21,10 +21,12 @@ [setup] # Adjust max_concurrent_jobs to limit how much you load your machines max_concurrent_jobs 50 +[server] +timeout 3600 # Uncomment this to make the in-mem db into a disk based db (slower but good for debug) # be aware that some unit tests will fail with this due to persistent data # # tmpdb /tmp @@ -35,15 +37,15 @@ [validvalues] state start end completed # Job tools are more advanced ways to control how your jobs are launched [jobtools] -useshell yes -launcher nbfind +# useshell yes +launcher nbfake # You can override environment variables for all your tests here [env-override] EXAMPLE_VAR example value # As you run more tests you may need to add additional disks, the names are arbitrary but must be unique [disks] disk0 #{getenv MT_RUN_AREA_HOME}/../simpleruns Index: tests/simplerun/tests/test1/testconfig ================================================================== --- tests/simplerun/tests/test1/testconfig +++ tests/simplerun/tests/test1/testconfig @@ -24,11 +24,11 @@ [requirements] # waiton setup priority 0 # Iteration for your tests are controlled by the items section -[items] +# [items] # PARTOFDAY morning noon afternoon evening night # test_meta is a section for storing additional data on your test [test_meta] author matt