Index: Makefile
==================================================================
--- Makefile
+++ Makefile
@@ -28,11 +28,11 @@
ezsteps.scm lock-queue.scm sdb.scm rmt.scm api.scm \
subrun.scm portlogger.scm archive.scm env.scm \
diff-report.scm cgisetup/models/pgdb.scm
# module source files
-MSRCFILES = dbmod.scm
+MSRCFILES = dbmod.scm dbfile.scm
# ftail.scm rmtmod.scm commonmod.scm removed
# MSRCFILES = ducttape-lib.scm pkts.scm stml2.scm cookie.scm mutils.scm \
# mtargs.scm commonmod.scm dbmod.scm adjutant.scm ulex.scm \
# rmtmod.scm apimod.scm
@@ -162,19 +162,19 @@
monitor.o dashboard.o archive.o megatest.o : db_records.scm megatest-fossil-hash.scm
tests.o runs.o dashboard.o dashboard-tests.o dashboard-context-menu.o dashboard-main.o : run_records.scm
db.o ezsteps.o keys.o launch.o megatest.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm
-db.o api.o : mofiles/dbmod.o
+db.o api.o : mofiles/dbmod.o mofiles/dbfile.o
tests.o tasks.o dashboard-tasks.o : task_records.scm
runs.o : test_records.scm
megatest.o : megatest-fossil-hash.scm megatest-version.scm
-rmt.scm client.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.scm fs-transport.scm http-transport.scm index-tree.scm items.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm newdashboard.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm : common_records.scm megatest-version.scm
+rmt.scm client.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.scm http-transport.scm index-tree.scm items.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm newdashboard.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm : common_records.scm megatest-version.scm
common_records.scm : altdb.scm
# mofiles/stml2.o : mofiles/cookie.o
# configf.o : mofiles/commonmod.o
Index: archive.scm
==================================================================
--- archive.scm
+++ archive.scm
@@ -397,11 +397,11 @@
(bup-restore-params (list "-d" archive-path "restore" "-C" *toppath* archive-internal-path)))
(debug:print-info 2 *default-log-port* "Restoring archived data to " *toppath* " from archive in " archive-path " ... " archive-internal-path)
(run-n-wait bup-exe params: bup-restore-params print-cmd: "Running:"))
(sleep 2)
(db:multi-db-sync
- (db:setup #f)
+ (db:setup-db *dbstruct-dbs* *toppath* #f)
'killservers
;'dejunk
;'adj-testids
'old2new
)
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
@@ -591,13 +591,13 @@
;;
(define (common:exit-on-version-changed)
(if (common:on-homehost?)
(if (common:api-changed?)
(let* ((mtconf (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.config"))
- (dbfile (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.db"))
- (read-only (not (file-write-access? dbfile)))
- (dbstruct (db:setup #t)))
+ (dbfile (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.db"))
+ (read-only (not (file-write-access? dbfile)))
+ (dbstruct (db:setup-db *dbstruct-dbs* *toppath* #f))) ;; #t)))
(debug:print 0 *default-log-port*
"WARNING: Version mismatch!\n"
" expected: " (common:version-signature) "\n"
" got: " (common:get-last-run-version))
(cond
@@ -979,10 +979,18 @@
"/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)))
+ ;; ensure tmp area has .db
+ (let ((dbarea (conc dbpath "/.db")))
+ (if (not (file-exists? dbarea))
+ (create-directory dbarea)))
dbpath))
#f)))
(define (common:get-area-path-signature)
(message-digest-string (md5-primitive) *toppath*))
@@ -1037,19 +1045,19 @@
;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage
(define (common:watchdog)
(debug:print-info 13 *default-log-port* "common:watchdog entered.")
(if (launch:setup)
(if (common:on-homehost?)
- (let ((dbstruct (db:setup #t)))
+ (let ((dbstruct (db:setup-db *dbstruct-dbs* *toppath* #f))) ;; #t)))
(debug:print-info 13 *default-log-port* "after db:setup with dbstruct=" dbstruct)
(cond
((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))
@@ -1073,11 +1081,11 @@
#t))))
(debug:print-info 4 *default-log-port* "starting exit process, finalizing databases.")
(if (and no-hurry (debug:debug-mode 18))
(rmt:print-db-stats))
(let ((th1 (make-thread (lambda () ;; thread for cleaning up, give it five seconds
- (if *dbstruct-db* (db:close-all *dbstruct-db*)) ;; one second allocated
+ (if *dbstruct-dbs* (db:close-all *dbstruct-dbs*)) ;; one second allocated
(if *task-db*
(let ((db (cdr *task-db*)))
(if (sqlite3:database? db)
(begin
(sqlite3:interrupt! db)
ADDED configfmod.scm
Index: configfmod.scm
==================================================================
--- /dev/null
+++ configfmod.scm
@@ -0,0 +1,75 @@
+;;======================================================================
+;; 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 .
+
+;;======================================================================
+
+(declare (unit configfmod))
+;; (declare (uses mtargs))
+;; (declare (uses debugprint))
+;; (declare (uses keysmod))
+
+(module configfmod
+*
+
+(import srfi-1
+
+;; scheme
+;;
+;; big-chicken ;; more of a reminder than anything ...
+;; chicken.base
+;; chicken.condition
+;; chicken.file
+;; chicken.io
+;; chicken.pathname
+;; chicken.port
+;; chicken.pretty-print
+;; chicken.process
+;; chicken.process-context
+;; chicken.process-context.posix
+;; chicken.sort
+;; chicken.string
+;; chicken.time
+;; chicken.eval
+;;
+;; debugprint
+;; (prefix mtargs args:)
+;; pkts
+;; keysmod
+;;
+;; (prefix base64 base64:)
+;; (prefix dbi dbi:)
+;; (prefix sqlite3 sqlite3:)
+;; (srfi 18)
+;; directory-utils
+;; format
+;; matchable
+;; md5
+;; message-digest
+;; regex
+;; regex-case
+;; sparse-vectors
+;; srfi-1
+;; srfi-13
+;; srfi-69
+;; stack
+;; typed-records
+;; z3
+
+ )
+)
+
Index: db.scm
==================================================================
--- db.scm
+++ db.scm
@@ -22,17 +22,35 @@
;; Database access
;;======================================================================
;; dbstruct vector containing all the relevant dbs like main.db, megatest.db, run.db etc
-(use (srfi 18) extras tcp stack)
-(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64 format dot-locking z3 typed-records matchable)
-(import (prefix sqlite3 sqlite3:))
-(import (prefix base64 base64:))
+(use (srfi 18)
+ extras
+ tcp
+ stack
+ (prefix sqlite3 sqlite3:)
+ srfi-1
+ posix
+ regex
+ regex-case
+ srfi-69
+ csv-xml
+ s11n
+ md5
+ message-digest
+ (prefix base64 base64:)
+ format
+ dot-locking
+ z3
+ typed-records
+ matchable)
(declare (unit db))
(declare (uses common))
+(declare (uses dbmod))
+(declare (uses dbfile))
(declare (uses keys))
(declare (uses ods))
(declare (uses client))
(declare (uses mt))
@@ -42,44 +60,21 @@
(include "run_records.scm")
(define *number-of-writes* 0)
(define *number-non-write-queries* 0)
-;;======================================================================
-;; R E C O R D S
-;;======================================================================
-
-;; each db entry is a pair ( db . dbfilepath )
-;; I propose this record evolves into the area record
-;;
-(defstruct dbr:dbstruct
- (tmpdb #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))
- ) ;; goal is to converge on one struct for an area but for now it is too confusing
-
+(import dbmod)
+(import dbfile)
;; 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 +122,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 +177,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 +209,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 +299,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
+ (db:get-db 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))
- (tmpdbfname (conc dbpath "/megatest.db"))
+ (mtdbfname (conc *toppath* "/"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 "/"dbname"_ref"))
+ (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 +333,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 +351,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 +372,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 areapath 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: #t)
+ (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,29 +411,25 @@
;; 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)))
;; sync run to disk if touched
;;
(define (db:sync-touched dbstruct run-id #!key (force-sync #f))
- (let ((tmpdb (db:get-db dbstruct))
+ (let ((tmpdb (db:get-db dbstruct run-id))
(mtdb (dbr:dbstruct-mtdb dbstruct))
(refndb (dbr:dbstruct-refndb dbstruct))
(start-t (current-seconds)))
(debug:print-info 4 *default-log-port* "Syncing for run-id: " run-id)
(mutex-lock! *db-multi-sync-mutex*)
@@ -1066,10 +1058,11 @@
;; run-ids: '(1 2 3 ...) or #f (for all)
;;
(define (db:multi-db-sync dbstruct . options)
;; (if (not (launch:setup))
;; (debug:print 0 *default-log-port* "ERROR: not able to setup up for megatest.")
+ (assert #f "FATAL: Call to db:multi-db-sync which is not completed yet.")
(let* ((mtdb (dbr:dbstruct-mtdb dbstruct))
(tmpdb (db:get-db dbstruct))
(refndb (dbr:dbstruct-refndb dbstruct))
(allow-cleanup #t) ;; (if run-ids #f #t))
(servers (server:get-list *toppath*)) ;; (tasks:get-all-servers (db:delay-if-busy tdbdat)))
@@ -1135,13 +1128,21 @@
(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))
- (tmpdb (db:get-db 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 run-id))
(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))
@@ -1552,11 +1553,11 @@
;; 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)) ;; archive tables are in main.db
+ (let* ((dbdat (db:get-db dbstruct #f)) ;; archive tables are in main.db
(db (db:dbdat-get-db 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)
@@ -1584,11 +1585,11 @@
;; 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)) ;; archive tables are in main.db
+ (let* ((dbdat (db:get-db dbstruct #f)) ;; archive tables are in main.db
(db (db:dbdat-get-db dbdat))
(res #f))
(sqlite3:for-each-row
(lambda (id)
(set! res id))
@@ -1614,11 +1615,11 @@
;; 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)) ;; archive tables are in main.db
+ (let* ((dbdat (db:get-db dbstruct #f)) ;; archive tables are in main.db
(db (db:dbdat-get-db dbdat))
(res #f))
;; first look to see if this path is already registered
(sqlite3:for-each-row
(lambda (id)
@@ -4880,10 +4881,11 @@
;; NOT REWRITTEN YET!!!!!
;; runspatt is a comma delimited list of run patterns
;; 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))
ADDED dbfile.scm
Index: dbfile.scm
==================================================================
--- /dev/null
+++ dbfile.scm
@@ -0,0 +1,89 @@
+;;======================================================================
+;; 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 .
+
+;;======================================================================
+
+(declare (unit dbfile))
+
+(module dbfile
+ *
+
+(import scheme chicken data-structures extras)
+(import (prefix sqlite3 sqlite3:)
+ posix typed-records srfi-18
+ srfi-69)
+
+;;======================================================================
+;; R E C O R D S
+;;======================================================================
+
+;; each db entry is a pair ( db . dbfilepath )
+;; NOTE: Need one dbr:dbstruct per main.db, 1.db ...
+;;
+(defstruct dbr:dbstruct
+ (dbname #f)
+ (dbdats (make-hash-table)) ;; id => dbdat
+ (tmpdb #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))
+ ) ;; 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))
+
+(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)))
+
+)
DELETED fs-transport.scm
Index: fs-transport.scm
==================================================================
--- fs-transport.scm
+++ /dev/null
@@ -1,52 +0,0 @@
-
-;; Copyright 2006-2012, 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 .
-
-(require-extension (srfi 18) extras tcp s11n)
-
-(use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest)
-(import (prefix sqlite3 sqlite3:))
-
-(use spiffy uri-common intarweb http-client spiffy-request-vars)
-
-(tcp-buffer-size 2048)
-
-(declare (unit fs-transport))
-
-(declare (uses common))
-(declare (uses db))
-(declare (uses tests))
-(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
-
-(include "common_records.scm")
-(include "db_records.scm")
-
-
-;;======================================================================
-;; F S T R A N S P O R T S E R V E R
-;;======================================================================
-
-;; There is no "server" per se but a convience routine to make it non
-;; necessary to be reopening the db over and over again.
-;;
-
-(define (fs:process-queue-item packet)
- (if (not *dbstruct-db*) ;; we will require that (setup-for-run) has already been called
- (set! *dbstruct-db* (db:setup-db)))
- (debug:print-info 11 *default-log-port* "fs:process-queue-item called with packet=" packet)
- (db:process-queue-item *dbstruct-db* packet))
-
Index: http-transport.scm
==================================================================
--- http-transport.scm
+++ http-transport.scm
@@ -97,11 +97,11 @@
(dat ($ 'dat))
(res #f))
(cond
((equal? (uri-path (request-uri (current-request)))
'(/ "api"))
- (send-response body: (api:process-request *dbstruct-db* $) ;; the $ is the request vars proc
+ (send-response body: (api:process-request *dbstruct-dbs* $) ;; the $ is the request vars proc
headers: '((content-type text/plain)))
(mutex-lock! *heartbeat-mutex*)
(set! *db-last-access* (current-seconds))
(mutex-unlock! *heartbeat-mutex*))
((equal? (uri-path (request-uri (current-request)))
@@ -458,14 +458,14 @@
(let loop ((count 0)
(server-state 'available)
(bad-sync-count 0)
(start-time (current-milliseconds)))
;; Use this opportunity to sync the tmp db to megatest.db
- (if (not server-going) ;; *dbstruct-db*
+ (if (not server-going) ;; *dbstruct-dbs*
(begin
(debug:print 0 *default-log-port* "SERVER: dbprep")
- (set! *dbstruct-db* (db:setup #t)) ;; run-id))
+ (set! *dbstruct-dbs* (db:setup #t)) ;; run-id)) FIXME!!!
(set! server-going #t)
(debug:print 0 *default-log-port* "SERVER: running, megatest version: " (common:get-full-version)) ;; NOTE: the server is NOT yet marked as running in the log. We do that in the keep-running routine.
(thread-start! *watchdog*)))
;; when things go wrong we don't want to be doing the various queries too often
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.6591)
+(define megatest-version 1.7001)
Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -39,12 +39,20 @@
(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 dbfile))
+(declare (uses dbfile.import))
+
;; (declare (uses ftail))
;; (import ftail)
+
+(import dbmod
+ dbfile)
(define *db* #f) ;; this is only for the repl, do not use in general!!!!
(include "common_records.scm")
(include "key_records.scm")
@@ -2290,22 +2298,22 @@
(begin
(debug:print 0 *default-log-port* "Failed to setup, exiting")
(exit 1)))
;; keep this one local
;; (open-run-close patch-db #f)
- (let ((dbstruct (db:setup #f areapath: *toppath*)))
- (common:cleanup-db dbstruct full: #t))
+ (let ((dbstructs (db:setup #f areapath: *toppath*)))
+ (common:cleanup-db dbstructs full: #t))
(set! *didsomething* #t)))
(if (args:get-arg "-cleanup-db")
(begin
(if (not (launch:setup))
(begin
(debug:print 0 *default-log-port* "Failed to setup, exiting")
(exit 1)))
- (let ((dbstruct (db:setup #f areapath: *toppath*)))
- (common:cleanup-db dbstruct))
+ (let ((dbstructs (db:setup #f areapath: *toppath*)))
+ (common:cleanup-db dbstructs))
(set! *didsomething* #t)))
(if (args:get-arg "-mark-incompletes")
(begin
(if (not (launch:setup))
@@ -2357,14 +2365,14 @@
(if (or (getenv "MT_RUNSCRIPT")
(args:get-arg "-repl")
(args:get-arg "-load"))
(let* ((toppath (launch:setup))
- (dbstruct (if (and toppath
- (common:on-homehost?))
- (db:setup #t)
- #f))) ;; make-dbr:dbstruct path: toppath local: (args:get-arg "-local")) #f)))
+ (dbstructs (if (and toppath
+ (common:on-homehost?))
+ (db:setup #t)
+ #f))) ;; make-dbr:dbstruct path: toppath local: (args:get-arg "-local")) #f)))
(if *toppath*
(cond
((getenv "MT_RUNSCRIPT")
;; How to run megatest scripts
;;
@@ -2377,15 +2385,16 @@
;; EOF
(repl))
(else
(begin
- (set! *db* dbstruct)
+ (set! *db* dbstructs)
(import extras) ;; might not be needed
;; (import csi)
(import readline)
(import apropos)
+ (import dbfile)
;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ...
(if *use-new-readline*
(begin
(install-history-file (get-environment-variable "HOME") ".megatest_history") ;; [homedir] [filename] [nlines])
Index: rmt.scm
==================================================================
--- rmt.scm
+++ rmt.scm
@@ -368,28 +368,28 @@
(loop (car tal)(cdr tal) newmax-cmd currmax)))))))
(mutex-unlock! *db-stats-mutex*)
res))
(define (rmt:open-qry-close-locally cmd run-id params #!key (remretries 5))
- (let* ((qry-is-write (not (member cmd api:read-only-queries)))
- (db-file-path (db:dbfile-path)) ;; 0))
- (dbstruct-local (db:setup #t)) ;; make-dbr:dbstruct path: dbdir local: #t)))
- (read-only (not (file-write-access? db-file-path)))
- (start (current-milliseconds))
- (resdat (if (not (and read-only qry-is-write))
- (let ((v (api:execute-requests dbstruct-local (vector (symbol->string cmd) params))))
- (handle-exceptions ;; there has been a long history of receiving strange errors from values returned by the client when things go wrong..
- exn ;; This is an attempt to detect that situation and recover gracefully
- (begin
- (debug:print 0 *default-log-port* "ERROR: bad data from server " v " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)
- (vector #t '())) ;; should always get a vector but if something goes wrong return a dummy
- (if (and (vector? v)
- (> (vector-length v) 1))
- (let ((newvec (vector (vector-ref v 0)(vector-ref v 1))))
- newvec) ;; by copying the vector while inside the error handler we should force the detection of a corrupted record
- (vector #t '())))) ;; we could also check that the returned types are valid
- (vector #t '())))
+ (let* ((qry-is-write (not (member cmd api:read-only-queries)))
+ (db-file-path (db:dbfile-path)) ;; 0))
+ (dbstructs-local (db:setup #t)) ;; make-dbr:dbstruct path: dbdir local: #t)))
+ (read-only (not (file-write-access? db-file-path)))
+ (start (current-milliseconds))
+ (resdat (if (not (and read-only qry-is-write))
+ (let ((v (api:execute-requests dbstructs-local (vector (symbol->string cmd) params))))
+ (handle-exceptions ;; there has been a long history of receiving strange errors from values returned by the client when things go wrong..
+ exn ;; This is an attempt to detect that situation and recover gracefully
+ (begin
+ (debug:print 0 *default-log-port* "ERROR: bad data from server " v " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)
+ (vector #t '())) ;; should always get a vector but if something goes wrong return a dummy
+ (if (and (vector? v)
+ (> (vector-length v) 1))
+ (let ((newvec (vector (vector-ref v 0)(vector-ref v 1))))
+ newvec) ;; by copying the vector while inside the error handler we should force the detection of a corrupted record
+ (vector #t '())))) ;; we could also check that the returned types are valid
+ (vector #t '())))
(success (vector-ref resdat 0))
(res (vector-ref resdat 1))
(duration (- (current-milliseconds) start)))
(if (and read-only qry-is-write)
(debug:print 0 *default-log-port* "ERROR: attempt to write to read-only database ignored. cmd=" cmd))
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