Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -51,16 +51,17 @@ ;; DATABASE (define *dbstruct-db* #f) (define *db-stats* (make-hash-table)) ;; hash of vectors < count duration-total > (define *db-stats-mutex* (make-mutex)) -(define *db-sync-mutex* (make-mutex)) -(define *megatest-db* #f) -(define *last-db-access* (current-seconds)) ;; update when db is accessed via server -(define *db-write-access* #t) -(define *inmemdb* #f) -(define *task-db* #f) ;; (vector db path-to-db) +(define *db-sync-mutex* (make-mutex)) +(define *db-local-sync* (make-hash-table)) ;; used to record last touch of db +(define *megatest-db* #f) +(define *last-db-access* (current-seconds)) ;; update when db is accessed via server +(define *db-write-access* #t) +(define *inmemdb* #f) +(define *task-db* #f) ;; (vector db path-to-db) ;; SERVER (define *my-client-signature* #f) (define *transport-type* 'http) (define *rpc:listener* #f) ;; if set up for server communication this will hold the tcp port Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -470,10 +470,74 @@ (debug:print 0 (format #f " ~10a ~5a" tblname count))))) (sort (hash-table->alist numrecs)(lambda (a b)(> (cdr a)(cdr b)))))) tot-count))) (mutex-unlock! *db-sync-mutex*)) +;; options: +;; +;; 'killservers - kills all servers +;; 'dejunk - removes junk records +;; 'adj-testids - move test-ids into correct ranges +;; 'old2new - sync megatest.db records to .db/{main,1,2 ...}.db +;; 'new2old - sync .db/{main,1,2,3 ...}.db to megatest.db +;; 'closeall - close all opened dbs +;; +;; run-ids: '(1 2 3 ...) or #f (for all) +;; +(define (db:multi-db-sync run-ids . options) + (let* ((toppath (launch:setup-for-run)) + (dbstruct (if toppath (make-dbr:dbstruct path: toppath) #f)) + (mtdb (if toppath (db:open-megatest-db))) + (run-ids (if run-ids + run-ids + (if toppath (db:get-all-run-ids mtdb)))) + (mdb (tasks:open-db)) + (servers (tasks:get-all-servers mdb))) + + ;; kill servers + (if (member 'killservers options) + (for-each + (lambda (server) + (tasks:server-delete-record mdb (vector-ref server 0) "dbmigration") + (tasks:kill-server (vector-ref server 2)(vector-ref server 1))) + servers)) + + ;; clear out junk records + ;; + (if (member 'dejunk options) + (db:clean-up mtdb)) + + ;; adjust test-ids to fit into proper range + ;; + (if (member 'adj-testids options) + (db:prep-megatest.db-for-migration mtdb)) + + ;; sync runs, test_meta etc. + ;; + (if (member 'old2new options) + (begin + (db:sync-tables (db:sync-main-list mtdb) mtdb (db:get-db dbstruct #f)) + (for-each + (lambda (run-id) + (let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id)) + (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t) #f))) + (debug:print 0 "INFO: Propagating " (length testrecs) " records for run-id=" run-id " to run specific db") + (db:replace-test-records dbstruct run-id testrecs) + (sqlite3:finalize! (dbr:dbstruct-get-rundb dbstruct)))) + run-ids))) + + ;; now ensure all newdb data are synced to megatest.db + (if (member 'old2new options) + (for-each + (lambda (run-id) + (let ((fromdb (if toppath (make-dbr:dbstruct path: toppath local: #t) #f))) + (db:sync-tables db:sync-tests-only (db:get-db fromdb run-id) mtdb))) + run-ids)) + + (db:close-all dbstruct) + (sqlite3:finalize! mdb))) + ;; keeping it around for debugging purposes only (define (open-run-close-no-exception-handling proc idb . params) (debug:print-info 11 "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params) (if (or *db-write-access* (not (member proc *db:all-write-procs*))) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -347,10 +347,13 @@ (hash-table-set! args:arg-hash "-testpatt" newval) (hash-table-delete! args:arg-hash "-itempatt"))) (on-exit (lambda () (rmt:print-db-stats) + (let ((run-ids (hash-table-keys *db-local-sync*))) + (if (not (null? run-ids)) + (db:multi-db-sync run-ids 'new2old))) (if *dbstruct-db* (db:close-all *dbstruct-db*)) (if *megatest-db* (sqlite3:finalize! *megatest-db*)) (if *task-db* (sqlite3:finalize! (vector-ref *task-db* 0))))) ;;====================================================================== @@ -1296,53 +1299,20 @@ ;; ;; ;; redo me (db:close-all dbstruct) ;; ;; ;; redo me (list "uname" "rundir" "final_logf" "comment")) ;; ;; ;; redo me (set! *didsomething* #t))) (if (args:get-arg "-import-megatest.db") - (let* ((toppath (launch:setup-for-run)) - (dbstruct (if toppath (make-dbr:dbstruct path: toppath) #f)) - (mtdb (if toppath (db:open-megatest-db))) - (run-ids (if toppath (db:get-all-run-ids mtdb))) - (mdb (tasks:open-db)) - (servers (tasks:get-all-servers mdb))) - - ;; kill servers - (for-each - (lambda (server) - (tasks:server-delete-record mdb (vector-ref server 0) "dbmigration") - (tasks:kill-server (vector-ref server 2)(vector-ref server 1))) - servers) - (sqlite3:finalize! mdb) - - ;; clear out junk records - ;; - (db:clean-up mtdb) - - ;; adjust test-ids to fit into proper range - ;; - (db:prep-megatest.db-for-migration mtdb) - - ;; sync runs, test_meta etc. - ;; - (db:sync-tables (db:sync-main-list mtdb) mtdb (db:get-db dbstruct #f)) - (for-each - (lambda (run-id) - (let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id)) - (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t) #f))) - (debug:print 0 "INFO: Propagating " (length testrecs) " records for run-id=" run-id " to run specific db") - (db:replace-test-records dbstruct run-id testrecs) - (sqlite3:finalize! (dbr:dbstruct-get-rundb dbstruct)))) - run-ids) - ;; now ensure all newdb data are synced to megatest.db - (for-each - (lambda (run-id) - (let ((fromdb (if toppath (make-dbr:dbstruct path: toppath local: #t) #f))) - (db:sync-tables db:sync-tests-only (db:get-db fromdb run-id) mtdb))) - run-ids) - (set! *didsomething* #t) - (db:close-all dbstruct))) - + (begin + (db:multi-db-sync + #f ;; do all run-ids + 'killservers + 'dejunk + 'adj-testids + 'old2new + 'new2old + ) + (set! *didsomething* #t))) ;;====================================================================== ;; Exit and clean up ;;====================================================================== (if *runremote* (close-all-connections!)) Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -147,10 +147,21 @@ ;; (read-only (not (file-read-access? db-file-path))) (let* ((start (current-milliseconds)) (res (api:execute-requests dbstruct-local (symbol->string cmd) params)) (duration (- (current-milliseconds) start))) (rmt:update-db-stats cmd params duration) + ;; mark this run as dirty if this was a write + (if (not (member cmd api:read-only-queries)) + (let ((start-time (current-seconds))) + (mutex-lock! *db-sync-mutex*) + (let ((last-sync (hash-table-ref/default *db-local-sync* run-id 0))) + (if (> (- start-time last-sync) 5) ;; every five seconds + (begin + (db:multi-db-sync run-id 'new2old) + (debug:print-info 0 "Sync of newdb to olddb for run-id " run-id " completed in " (- (current-seconds) start-time) " seconds") + (hash-table-set! *db-local-sync* run-id start-time)))) + (mutex-unlock! *db-sync-mutex*))) res))) (define (rmt:send-receive-no-auto-client-setup connection-info cmd run-id params) (let* ((run-id (if run-id run-id 0)) (jparams (db:obj->string params)) ;; (rmt:dat->json-str params))