Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -36,46 +36,39 @@ (include "common_records.scm") (include "db_records.scm") (include "key_records.scm") (include "run_records.scm") -;; timestamp type (val1 val2 ...) -;; type: meta-info, step -(define *incoming-writes* '()) -(define *completed-writes* (make-hash-table)) -(define *incoming-last-time* (current-seconds)) -(define *incoming-mutex* (make-mutex)) -(define *completed-mutex* (make-mutex)) +(define *rundb-mutex* (make-mutex)) ;; prevent problems opening/closing rundb's ;; Get/open a database ;; if run-id => get run specific db ;; if #f => get main db ;; 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) - (if run-id - (db:open-rundb dbstruct run-id) - (db:open-main dbstruct))) - -(define (db:set-sync db) - (let* ((syncval (config-lookup *configdat* "setup" "synchronous")) - (val (cond ;; 0 | OFF | 1 | NORMAL | 2 | FULL; - ((not syncval) #f) - ((string->number syncval) - (let ((val (string->number syncval))) - (if (member val '(0 1 2)) val #f))) - ((string-match (regexp "yes" #t) syncval) 1) - ((string-match (regexp "no" #t) syncval) 0) - ((string-match (regexp "(off|normal|full)" #t) syncval) syncval) - (else - (debug:print 0 "ERROR: synchronous must be 0,1,2,OFF,NORMAL or FULL, you provided: " syncval) - #f)))) - (if val - (begin - (debug:print-info 9 "db:set-sync, setting pragma synchronous to " val) - (sqlite3:execute db (conc "PRAGMA synchronous = '" val "';")))))) + (mutex-lock! *rundb-mutex*) + (let ((db (if run-id + (db:open-rundb dbstruct run-id) + (db:open-main dbstruct)))) + ;; db prunning would go here + (mutex-unlock! *rundb-mutex*) + db)) + +;; mod-read: +;; 'mod modified data +;; 'read read data +;; +(define (db:done-with dbstruct run-id mod-read) + (mutex-lock! *rundb-mutex*) + (if (eq? mod-read 'mod) + (dbr:dbstruct-set-runvec! dbstruct run-id 'mtime (current-milliseconds)) + (dbr:dbstruct-set-runvec! dbstruct run-id 'rtime (current-milliseconds))) + (dbr:dbstruct-set-runvec! dbstruct run-id 'inuse #f) + (mutex-unlock! *rundb-mutex*)) ;;====================================================================== ;; K E E P F I L E D B I N dbstruct ;;====================================================================== @@ -119,10 +112,12 @@ (sqlite3:set-busy-handler! db handler) (sqlite3:execute db "PRAGMA synchronous = 0;"))) (if (not dbexists)(db:initialize-run-id-db db run-id)) (dbr:dbstruct-set-runvec! dbstruct run-id 'rundb db) (dbr:dbstruct-set-runvec! dbstruct run-id 'inmem inmem) + (dbr:dbstruct-set-runvec! dbstruct run-id 'inuse #t) + (db:sync-tables db:sync-tests-only db inmem) inmem)))) ;; This routine creates the db. It is only called if the db is not already opened ;; (define (db:open-main dbstruct) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) @@ -147,10 +142,24 @@ (if (not dbexists) (db:initialize-megatest-db db)) (dbr:dbstruct-set-main! dbstruct db) db)))) +;; sync all touched runs to disk +(define (db:sync-touched dbstruct) + (for-each + (lambda (runvec) + (let ((mtime (vector-ref runvec (dbr:dbstruct-field-name->num 'mtime))) + (stime (vector-ref runvec (dbr:dbstruct-field-name->num 'stime))) + (rundb (vector-ref runvec (dbr:dbstruct-field-name->num 'rundb))) + (inmem (vector-ref runvec (dbr:dbstruct-field-name->num 'inmem)))) + (if (> mtime stime) + (begin + (db:sync-tables db:sync-tests-only inmem rundb) + (vector-set! runvec (dbr:dbstruct-field-name->run 'stime (current-milliseconds))))))) + (hash-table-values (vector-ref dbstruct 1)))) + ;; close all opened run-id dbs (define (db:close-all-db) (for-each (lambda (db) (finalize! db)) @@ -164,12 +173,59 @@ (sqlite3:set-busy-handler! db handler) (set! sdb:qry (make-sdb:qry)) ;; we open the normalization helpers here (set! *fdb* (filedb:open-db (conc *toppath* "/db/paths.db"))) db)) -;; (define (db:sync-table tblname fields fromdb todb) +;; just tests, test_steps and test_data tables +(define db:sync-tests-only + (list + (list "tests" + '("id" #f) + '("run_id" #f) + '("testname" #f) + '("host" #f) + '("cpuload" #f) + '("diskfree" #f) + '("uname" #f) + '("rundir" #f) + '("shortdir" #f) + '("item_path" #f) + '("state" #f) + '("status" #f) + '("attemptnum" #f) + '("final_logf" #f) + '("logdat" #f) + '("run_duration" #f) + '("comment" #f) + '("event_time" #f) + '("fail_count" #f) + '("pass_count" #f) + '("archived" #f)) + (list "test_steps" + '("id" #f) + '("test_id" #f) + '("stepname" #f) + '("state" #f) + '("status" #f) + '("event_time" #f) + '("comment" #f) + '("logfile" #f)) + (list "test_data" + '("id" #f) + '("test_id" #f) + '("category" #f) + '("variable" #f) + '("value" #f) + '("expected" #f) + '("tol" #f) + '("units" #f) + '("comment" #f) + '("status" #f) + '("type" #f)))) +;; needs db to get keys, this is for syncing all tables +;; (define (db:tbls db) (let ((keys (db:get-keys db))) (list (list "keys" '("id" #f) @@ -337,11 +393,11 @@ open-run-close-no-exception-handling open-run-close-exception-handling)) (define (db:initialize-megatest-db db) (let* ((configdat (car *configinfo*)) ;; tut tut, global warning... - (keys (keys:configq-get-fields configdat)) + (keys (keys:config-get-fields configdat)) (havekeys (> (length keys) 0)) (keystr (keys->keystr keys)) (fieldstr (keys->key/field keys))) (for-each (lambda (key) (let ((keyn key)) @@ -429,19 +485,19 @@ status TEXT DEFAULT 'n/a', event_time TIMESTAMP, comment TEXT DEFAULT '', logfile TEXT DEFAULT '', CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data - (id INTEGER PRIMARY KEY, - reviewed TIMESTAMP DEFAULT (strftime('%s','now')), - iterated TEXT DEFAULT '', - avg_runtime REAL DEFAULT -1, - avg_disk REAL DEFAULT -1, - tags TEXT DEFAULT '', - jobgroup TEXT DEFAULT 'default', - CONSTRAINT test_meta_constraint UNIQUE (testname));") +;; (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data +;; (id INTEGER PRIMARY KEY, +;; reviewed TIMESTAMP DEFAULT (strftime('%s','now')), +;; iterated TEXT DEFAULT '', +;; avg_runtime REAL DEFAULT -1, +;; avg_disk REAL DEFAULT -1, +;; tags TEXT DEFAULT '', +;; jobgroup TEXT DEFAULT 'default', +;; CONSTRAINT test_meta_constraint UNIQUE (testname));") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY, test_id INTEGER, category TEXT DEFAULT '', variable TEXT, value REAL, Index: db_records.scm ================================================================== --- db_records.scm +++ db_records.scm @@ -9,11 +9,11 @@ ;; |-sdb.db ;; |-fdb.db ;; |-1.db ;; |-.db (define (make-dbr:dbstruct #!key (path #f)) - (make-vector + (vector #f ;; the main db (contains runs, test_meta etc.) NOT CACHED IN MEM (make-hash-table) ;; run-id => [ rundb inmemdb last-mod last-read last-sync ] #f ;; the global string db (use for state, status etc.) path)) ;; path to database files/megatest area @@ -26,11 +26,11 @@ (let* ((dbhash (vector-ref vec 1)) (runvec (hash-table-ref/default dbhash run-id))) (if runvec runvec (begin - (hash-table-set! dbhash run-id (vector #f #f -1 -1 -1)) + (hash-table-set! dbhash run-id (vector #f #f -1 -1 -1 #f)) (dbr:dbstruct-get-rundb-rec vec run-id))))) ;; [ rundb inmemdb last-mod last-read last-sync ] (define-inline (dbr:dbstruct-field-name->num field-name) (case field-name @@ -37,16 +37,19 @@ ((rundb) 0) ;; the on-disk db ((inmem) 1) ;; the in-memory db ((mtime) 2) ;; last modification time ((rtime) 3) ;; last read time ((stime) 4) ;; last sync time + ((inuse) 5) ;; is the db currently in use (else -1))) ;; get/set rundb fields (define (dbr:dbstruct-get-runrec vec run-id field-name) - (let ((runvec (dbr:dbstruct-get-rundb-rec vec run-id))) - (vector-ref runvec (dbr:dbstruct-field-name->num field-name)))) + (let ((runvec (dbr:dbstruct-get-rundb-rec vec run-id)) + (fieldnum (dbr:dbstruct-field-name->num field-name))) + ;; (vector-set! runvec (dbr:dbstruct-field-name->num 'inuse) #t) + (vector-ref runvec fieldnum))) (define (dbr:dbstruct-set-runvec! vec run-id field-name val) (let ((runvec (dbr:dbstruct-get-rundb-rec vec run-id))) (vector-set! runvec (dbr:dbstruct-field-name->num field-name) rundb))) Index: http-transport.scm ================================================================== --- http-transport.scm +++ http-transport.scm @@ -429,11 +429,11 @@ (let loop ((count 0)) ;; Use this opportunity to sync the inmemdb to db (let ((start-time (current-milliseconds)) (sync-time #f) (rem-time #f)) - (if *inmemdb* (db:sync-tables (db:tbls *inmemdb*) *inmemdb* *db*)) ;; (db:sync-to *inmemdb* *db*)) + (if *inmemdb* (db:sync-touched *inmemdb*)) (set! sync-time (- (current-milliseconds) start-time)) (debug:print 0 "SYNC: time= " sync-time) (set! rem-time (quotient (- 4000 sync-time) 1000)) (if (and (< rem-time 4) (> rem-time 0)) @@ -474,11 +474,11 @@ (loop 0)) (begin (debug:print-info 0 "Starting to shutdown the server.") ;; need to delete only *my* server entry (future use) (set! *time-to-exit* #t) - (if *inmemdb* (db:sync-tables (db:tbls *inmemdb*) *inmemdb* *db*)) ;; (db:sync-to *inmemdb* *db*)) + (if *inmemdb* (db:sync-touched *inmemdb*)) (open-run-close tasks:server-deregister-self tasks:open-db (get-host-name)) (thread-sleep! 1) (debug:print-info 0 "Max cached queries was " *max-cache-size*) (debug:print-info 0 "Number of cached writes " *number-of-writes*) (debug:print-info 0 "Average cached write time " @@ -517,49 +517,25 @@ (http-transport:run (if (args:get-arg "-server") (args:get-arg "-server") "-"))) "Server run")) (th3 (make-thread http-transport:keep-running "Keep running"))) -;; (th1 (make-thread server:write-queue-handler "write queue"))) - (set! *cache-on* #t) - (set! *db* (open-db)) - (set! *inmemdb* (open-in-mem-db)) - (db:sync-tables (db:tbls *db*) *db* *inmemdb*) ;; (db:sync-to *db* *inmemdb*) - + ;; Database connection + (set! *inmemdb* (make-dbr:dbstruct path: *toppath*)) (thread-start! th2) (thread-start! th3) - ;; (thread-start! th1) (set! *didsomething* #t) (thread-join! th2)) (debug:print 0 "ERROR: Failed to setup for megatest"))) (exit))) -;; (use trace) -;; (trace http-transport:keep-running -;; tasks:server-update-heartbeat -;; tasks:server-get-server-id) -;; tasks:get-best-server -;; http-transport:run -;; http-transport:launch -;; http-transport:try-start-server -;; http-transport:client-send-receive -;; http-transport:make-server-url -;; tasks:server-register -;; tasks:server-delete -;; start-server -;; hostname->ip -;; with-input-from-request -;; tasks:server-deregister-self) - (define (http-transport:server-signal-handler signum) (handle-exceptions exn (debug:print " ... exiting ...") (let ((th1 (make-thread (lambda () (thread-sleep! 1)) - ;; (if (not *received-response*) - ;; (receive-message* *runremote*))) ;; flush out last call if applicable "eat response")) (th2 (make-thread (lambda () (debug:print 0 "ERROR: Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.") (thread-sleep! 3) ;; give the flush three seconds to do it's stuff (debug:print 0 " Done.") Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -51,13 +51,13 @@ (debug:print 0 "ERROR: cannot find megatest.config, exiting") (exit)))) (debug:print-info 2 "Starting server using " transport " transport") (set! *transport-type* transport) (case transport - ((fs) (exit)) ;; there is no "fs" server transport - ((http) (http-transport:launch)) - ((zmq) (zmq-transport:launch)) + ;; ((fs) (exit)) ;; there is no "fs" server transport + ((fs http) (http-transport:launch)) + ((zmq) (zmq-transport:launch)) (else (debug:print "WARNING: unrecognised transport " transport) (exit)))) ;;======================================================================