Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -42,10 +42,12 @@ (define *completed-writes* (make-hash-table)) (define *incoming-last-time* (current-seconds)) (define *incoming-mutex* (make-mutex)) (define *completed-mutex* (make-mutex)) (define *cache-on* #f) + + (define (db:set-sync db) (let* ((syncval (config-lookup *configdat* "setup" "synchronous")) (val (cond ;; 0 | OFF | 1 | NORMAL | 2 | FULL; ((not syncval) #f) @@ -84,10 +86,53 @@ (if (not dbexists) (db:initialize db)) ;; Moving db:set-sync to a call in run.scm - it is a persistent value and only needs to be set once ;; (db:set-sync db) db)) + +(define (open-in-mem-db) + (let ((db (sqlite3:open-database ":memory:"))) + (db:initialize db) + db)) + +(define (db:sync-to fromdb todb) + ;; strategy + ;; 1. Get all run-ids + ;; 2. For each run-id + ;; a. Sync that run in a transaction + (let ((run-ids (db:get-all-run-ids fromdb)) + (getstmt (sqlite3:prepare todb "SELECT id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment FROM tests WHERE id=?;")) + (putstmt (sqlite3:prepare todb "INSERT OR REPLACE INTO tests (id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment) + VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ? );"))) + (for-each + (lambda (run-id) + (let* ((run-dat (db:get-all-tests-info-by-run-id fromdb run-id)) + (curr-tdat #f)) + (debug:print 0 "Updating as many as " (length run-dat) " records for run " run-id) + (for-each + (lambda (tdat) ;; iterate over tests + (let ((test-id (vector-ref tdat 0))) + (sqlite3:with-transaction + todb + (lambda () + (sqlite3:for-each-row + (lambda (a . b) + (set! curr-tdat (apply vector a b))) + getstmt + test-id) + (if (not (equal? curr-tdat tdat)) ;; something changed + (begin + (debug:print 0 "Updating test " test-id) + (apply sqlite3:execute putstmt (vector->list tdat))) + (begin + (debug:print 0 "Not updating test " test-id) + ;; (debug:print 0 " tdat: " tdat) + ;; (debug:print 0 " curr-tdat: " curr-tdat) + ) + ))))) + run-dat))) + run-ids))) ;; 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* @@ -713,10 +758,18 @@ res) (begin (debug:print 0 "ERROR: Called without all necessary keys") #f)))) +(define (db:get-all-run-ids db) + (let ((res '())) + (sqlite3:for-each-row + (lambda (run-id) + (set! res (cons run-id res))) + db + "SELECT DISTINCT run_id FROM tests;") + res)) ;; replace header and keystr with a call to runs:get-std-run-fields ;; ;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) ;; runpatts: patt1,patt2 ... @@ -1353,10 +1406,24 @@ (define (db:clean-all-caches) (set! *test-info* (make-hash-table)) (set! *test-id-cache* (make-hash-table))) + +(define (db:get-all-tests-info-by-run-id db run-id) + (let ((res '())) + (sqlite3:for-each-row + (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment) + ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 + (set! res (cons (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run_duration final_logf comment) + res))) + db + "SELECT id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment FROM tests WHERE run_id=?;" + run-id) + res)) + +;; Get test data using test_id ;; Use db:test-get* to access ;; ;; Get test data using test_id (define (db:get-test-info-by-id db test-id) (if (not test-id) Index: http-transport.scm ================================================================== --- http-transport.scm +++ http-transport.scm @@ -372,10 +372,14 @@ (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"))) + ;; This is were we set up the database connections + (set! *db* (open-db)) + (set! *inmemdb* (open-in-mem-db)) + (db:sync-to *db* *inmemdb*) (thread-start! th2) (thread-start! th3) (thread-start! th1) (set! *didsomething* #t) (thread-join! th2)) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -427,11 +427,16 @@ given-toppath: (get-environment-variable "MT_RUN_AREA_HOME") pathenvvar: "MT_RUN_AREA_HOME")) (set! *configdat* (if (car *configinfo*)(car *configinfo*) #f)) (set! *toppath* (if (car *configinfo*)(cadr *configinfo*) #f)) (if *toppath* - (setenv "MT_RUN_AREA_HOME" *toppath*) ;; to be deprecated + (let ((dbdir (conc *toppath* "/db"))) + (handle-exceptions + exn + (debug:print 0 "ERROR: failed to create the " dbdir " area for your database files") + (if (not (directory-exists? dbdir))(create-directory dbdir))) + (setenv "MT_RUN_AREA_HOME" *toppath*)) (debug:print 0 "ERROR: failed to find the top path to your Megatest area.")))) *toppath*) (define (get-best-disk confdat) (let* ((disks (hash-table-ref/default confdat "disks" #f)) Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -21,11 +21,11 @@ ;;====================================================================== ;; Tasks db ;;====================================================================== (define (tasks:open-db) - (let* ((dbpath (conc *toppath* "/monitor.db")) + (let* ((dbpath (conc *toppath* "/db/monitor.db")) (exists (file-exists? dbpath)) (write-access (file-write-access? dbpath)) (mdb (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath)) (handler (make-busy-timeout 36000))) (if (and exists @@ -64,10 +64,11 @@ priority INTEGER, state TEXT, mt_version TEXT, heartbeat TIMESTAMP, transport TEXT, + run_id INTEGER, CONSTRAINT servers_constraint UNIQUE (pid,hostname,port));") (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS clients (id INTEGER PRIMARY KEY, server_id INTEGER, pid INTEGER, hostname TEXT,