Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -4,13 +4,13 @@ INSTALL=install SRCFILES = common.scm items.scm launch.scm \ ods.scm runconfig.scm server.scm configf.scm \ db.scm keys.scm margs.scm megatest-version.scm \ process.scm runs.scm tasks.scm tests.scm genexample.scm \ - fs-transport.scm http-transport.scm \ + fs-transport.scm http-transport.scm filedb.scm \ client.scm gutils.scm synchash.scm daemon.scm mt.scm dcommon.scm \ - tree.scm ezsteps.scm lock-queue.scm sdb.scm filedb.scm \ + tree.scm ezsteps.scm lock-queue.scm sdb.scm \ rmt.scm api.scm tdb.scm GUISRCF = dashboard-tests.scm dashboard-guimonitor.scm OFILES = $(SRCFILES:%.scm=%.o) Index: client.scm ================================================================== --- client.scm +++ client.scm @@ -65,22 +65,21 @@ (set! *transport-type* (if hostinfo (string->symbol (tasks:hostinfo-get-transport hostinfo)) 'fs)) (debug:print-info 11 "Using transport type of " *transport-type* (if hostinfo (conc " to connect to " hostinfo) "")) (case *transport-type* - ((fs)(if (not *megatest-db*)(set! *megatest-db* (open-db)))) + ;; ((fs)(if (not *megatest-db*)(set! *megatest-db* (open-db)))) ((http) (http-transport:client-connect (tasks:hostinfo-get-interface hostinfo) (tasks:hostinfo-get-port hostinfo))) ((zmq) (zmq-transport:client-connect (tasks:hostinfo-get-interface hostinfo) (tasks:hostinfo-get-port hostinfo) (tasks:hostinfo-get-pubport hostinfo))) (else ;; default to fs - (debug:print 0 "ERROR: unrecognised transport type " *transport-type* " attempting to continue with fs") - (set! *transport-type* 'fs) - (set! *megatest-db* (open-db)))) + (debug:print 0 "ERROR: unrecognised transport type " *transport-type* " exiting now.") + (exit))) (pop-directory))) ;; client:signal-handler (define (client:signal-handler signum) (handle-exceptions Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -38,10 +38,13 @@ (define *waiting-queue* (make-hash-table)) (define *test-meta-updated* (make-hash-table)) (define *globalexitstatus* 0) ;; attempt to work around possible thread issues (define *passnum* 0) ;; when running track calls to run-tests or similar +;; DATABASE +(define *open-dbs* (vector #f (make-hash-table))) ;; megatestdb run-id-dbs + ;; SERVER (define *my-client-signature* #f) (define *transport-type* 'fs) (define *megatest-db* #f) (define *rpc:listener* #f) ;; if set up for server communication this will hold the tcp port @@ -90,10 +93,15 @@ (set! *test-ids* (make-hash-table)) (set! *test-info* (make-hash-table)) (set! *run-info-cache* (make-hash-table)) (set! *env-vars-by-run-id* (make-hash-table)) (set! *test-id-cache* (make-hash-table))) + +;; Generic string database (normalization of sorts) +(define sdb:qry #f) ;; (make-sdb:qry)) ;; 'init #f) +;; Generic path database (normalization of sorts) +(define *fdb* #f) ;;====================================================================== ;; S T A T E S A N D S T A T U S E S ;;====================================================================== Index: configf.scm ================================================================== --- configf.scm +++ configf.scm @@ -217,16 +217,17 @@ (envar (and environ-patt (string-search (regexp environ-patt) curr-section-name))) (realval (if envar (config:eval-string-in-environment val) val))) (debug:print-info 6 "read-config env setting, envar: " envar " realval: " realval " val: " val " key: " key " curr-section-name: " curr-section-name) - (if (and envar - (string? realval) - (not (string-search (integer->char 0) realval))) - ;; (debug:print-info 4 "read-config key=" key ", val=" val ", realval=" realval) - (setenv key realval) - (debug:print 0 "ERROR: bad value for setenv, key=" key ", value=" realval)) + (if envar + (if (and (string? realval)(string? key)) + (handle-exceptions + exn + (debug:print 0 "ERROR: bad value for setenv, key=" key ", value=" realval) + (setenv key realval)) + (debug:print 0 "ERROR: bad value for setenv, key=" key ", value=" realval))) (hash-table-set! res curr-section-name (config:assoc-safe-add alist key realval)) (loop (configf:read-line inp res allow-system) curr-section-name key #f))) (configf:key-no-val ( x key val) (let* ((alist (hash-table-ref/default res curr-section-name '()))) (hash-table-set! res curr-section-name Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -24,11 +24,14 @@ (declare (unit dashboard-tests)) (declare (uses common)) (declare (uses db)) (declare (uses gutils)) +(declare (uses rmt)) (declare (uses ezsteps)) +(declare (uses sdb)) +(declare (uses filedb)) (include "common_records.scm") (include "db_records.scm") (include "run_records.scm") @@ -73,11 +76,11 @@ lbl) (store-label "testcomment" (iup:label "TestComment " #:expand "HORIZONTAL") (lambda (testdat) - (db:test-get-comment testdat))) + (sdb:qry 'getstr (db:test-get-comment testdat)))) (store-label "testid" (iup:label "TestId " #:expand "HORIZONTAL") (lambda (testdat) (db:test-get-id testdat))) @@ -180,15 +183,15 @@ (iup:label "" #:expand "VERTICAL"))) (apply iup:vbox ; #:expand "YES" (list ;; NOTE: Yes, the host can change! (store-label "HostName" - (iup:label (db:test-get-host testdat) #:expand "HORIZONTAL") + (iup:label (sdb:qry 'getstr (db:test-get-host testdat)) #:expand "HORIZONTAL") (lambda (testdat)(db:test-get-host testdat))) (store-label "Uname" (iup:label " " #:expand "HORIZONTAL") - (lambda (testdat)(db:test-get-uname testdat))) + (lambda (testdat)(sdb:qry 'getstr (db:test-get-uname testdat)))) (store-label "DiskFree" (iup:label (conc (db:test-get-diskfree testdat)) #:expand "HORIZONTAL") (lambda (testdat)(conc (db:test-get-diskfree testdat)))) (store-label "CPULoad" (iup:label (conc (db:test-get-cpuload testdat)) #:expand "HORIZONTAL") @@ -442,12 +445,12 @@ ;;====================================================================== ;; ;;====================================================================== (define (examine-test test-id) ;; run-id run-key origtest) - (let* ((db-path (conc *toppath* "/megatest.db")) - (db (open-db)) + (let* ((db-path (conc *toppath* "db/main.db")) + (db (make-dbr:dbstruct path: *toppath* local: #t)) (tdb (tdb:open-test-db-by-test-id-local test-id)) (testdat (db:get-test-info-by-id db test-id)) (db-mod-time 0) ;; (file-modification-time db-path)) (last-update 0) ;; (current-seconds)) (request-update #t)) @@ -523,11 +526,11 @@ (cond ((and need-update newtestdat) (set! testdat newtestdat) (set! teststeps (dashboard-tests:get-compressed-steps db test-id)) (set! logfile (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat))) - (set! rundir (db:test-get-rundir testdat)) + (set! rundir (filedb:get-path *fdb* (db:test-get-rundir testdat))) (set! testfullname (db:test-get-fullname testdat)) ;; (debug:print 0 "INFO: teststeps=" (intersperse teststeps "\n ")) ;; I don't see why this was implemented this way. Please comment it ... ;; (if (eq? curr-mod-time db-mod-time) ;; do only once if same Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -86,11 +86,13 @@ (if (not (setup-for-run)) (begin (print "Failed to find megatest.config, exiting") (exit 1))) -(define *db* (open-db)) +(define *db* (make-dbr:dbstruct path: *toppath* local: #t)) + +;; (define sdb:qry (make-sdb:qry)) ;; 'init #f) ;; (if (args:get-arg "-host") ;; (begin ;; (set! *runremote* (string-split (args:get-arg "-host" ":"))) ;; (client:launch)) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -28,88 +28,212 @@ (declare (uses keys)) (declare (uses ods)) (declare (uses fs-transport)) (declare (uses client)) (declare (uses mt)) +(declare (uses sdb)) (declare (uses filedb)) (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 *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) - ((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 "';")))))) - -(define (open-db) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) - (if (not *toppath*) - (if (not (setup-for-run)) - (begin - (debug:print 0 "ERROR: Attempted to open db when not in megatest area. Exiting.") - (exit)))) - (let* ((dbpath (conc *toppath* "/megatest.db")) ;; fname) - (dbexists (file-exists? dbpath)) - (db (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath)) - (write-access (file-write-access? dbpath)) - (handler (make-busy-timeout (if (args:get-arg "-override-timeout") - (string->number (args:get-arg "-override-timeout")) - 136000)))) ;; 136000))) ;; 136000 = 2.2 minutes - (if (and dbexists - (not write-access)) - (set! *db-write-access* write-access)) ;; only unset so other db's also can use this control - (debug:print-info 11 "open-db, dbpath=" dbpath " argv=" (argv)) - (if write-access (sqlite3:set-busy-handler! db handler)) - (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* ((path (configf:lookup *configdat* "setup" "tmpdb")) - (fname (if path (conc path "/temp-megatest.db") #f)) - (exists (and path (file-exists? fname))) - (db (if path - (begin - (create-directory path #t) - (sqlite3:open-database fname)) - (sqlite3:open-database ":memory:"))) - (handler (make-busy-timeout 3600))) - (if (or (not path) - (not exists)) - (db:initialize db)) - (sqlite3:set-busy-handler! db handler) - db)) - -;; (define (db:sync-table tblname fields fromdb todb) - +(define *rundb-mutex* (make-mutex)) ;; prevent problems opening/closing rundb's +(define *number-of-writes* 0) +(define *number-non-write-queries* 0) + +;; 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) + (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 +;;====================================================================== + +(define (db:get-filedb dbstruct) + (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))) + (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))) + +;; This routine creates the db. It is only called if the db is not already opened +;; +(define (db:open-rundb dbstruct run-id) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) + (let ((rdb (dbr:dbstruct-get-runrec dbstruct run-id 'inmem))) + (if rdb + rdb + (let* ((local (dbr:dbstruct-get-local dbstruct)) + (toppath (dbr:dbstruct-get-path dbstruct)) + (dbpath (conc toppath "/db/" run-id ".db")) + (dbexists (file-exists? dbpath)) + (inmem (if local #f (open-inmem-db))) + (db (sqlite3:open-database dbpath)) + (write-access (file-write-access? dbpath)) + (handler (make-busy-timeout 136000))) + (if (and dbexists (not write-access)) + (set! *db-write-access* #f)) ;; only unset so other db's also can use this control + (if write-access + (begin + (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 'inuse #t) + (if local + db + (begin + (dbr:dbstruct-set-runvec! dbstruct run-id 'inmem inmem) + (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*))) + (let ((mdb (dbr:dbstruct-get-main dbstruct))) + (if mdb + mdb + (let* ((toppath (dbr:dbstruct-get-path dbstruct)) + (dbpath (let ((dbdir (conc *toppath* "/db"))) ;; use this opportunity to create our db dir + (if (not (directory-exists? dbdir)) + (create-direcory dbdir)) + (conc *toppath* "/db/main.db"))) + (dbexists (file-exists? dbpath)) + (db (sqlite3:open-database dbpath)) + (write-access (file-write-access? dbpath)) + (handler (make-busy-timeout 136000))) + (if (and dbexists (not write-access)) + (set! *db-write-access* #f)) + (if write-access + (begin + (sqlite3:set-busy-handler! db handler) + (sqlite3:execute db "PRAGMA synchronous = 0;"))) + (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 dbstruct) + ;; finalize main.db + (sqlite3:finalize! (db:get-db dbstruct #f)) + (for-each + (lambda (runvec) + (let ((rundb (vector-ref runvec (dbr:dbstruct-field-name->num 'rundb)))) + (sqlite3:finalize! rundb))) + (hash-table-values (vector-ref dbstruct 1)))) + +(define (open-inmem-db) + (let* ((db (sqlite3:open-database ":memory:")) + (handler (make-busy-timeout 3600))) + (db:initialize db) + (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)) + +;; 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) @@ -238,140 +362,26 @@ (count (cdr dat))) (if (> count 0) (debug:print 0 (format #f " ~10a ~5a" tblname count))))) (sort (hash-table->alist numrecs)(lambda (a b)(> (cdr a)(cdr b)))))))) -;; (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 ((trecchgd 0) -;; (rrecchgd 0) -;; (tmrecchgd 0)) -;; -;; ;; First sync test_meta data -;; (let ((tmgetstmt (sqlite3:prepare todb "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta WHERE id=?;")) -;; (tmputstmt (sqlite3:prepare todb "INSERT OR REPLACE INTO test_meta (id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup) -;; VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?);")) -;; (tmdats (db:testmeta-get-all fromdb))) -;; ;; (debug:print 7 "Updating as many as " (length tdats) " records for run " run-id) -;; (for-each -;; (lambda (tmdat) ;; iterate over tests -;; (let ((testm-id (vector-ref tmdat 0))) -;; (sqlite3:with-transaction -;; todb -;; (lambda () -;; (let ((curr-tmdat #f)) -;; (sqlite3:for-each-row -;; (lambda (a . b) -;; (set! curr-tmdat (apply vector a b))) -;; tmgetstmt testm-id) -;; (if (not (equal? curr-tmdat tmdat)) ;; something changed -;; (begin -;; (debug:print 0 " test-id: " testm-id -;; "\ncurr-tdat: " curr-tmdat -;; "\n tdat: " tmdat) -;; (apply sqlite3:execute tmputstmt (vector->list tmdat)) -;; (set! tmrecchgd (+ tmrecchgd 1))))))))) -;; tmdats) -;; (sqlite3:finalize! tmgetstmt) -;; (sqlite3:finalize! tmputstmt)) -;; -;; ;; First sync tests data -;; (let ((run-ids (db:get-all-run-ids fromdb)) -;; (tgetstmt (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=?;")) -;; (tputstmt (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 ((tdats (db:get-all-tests-info-by-run-id fromdb run-id))) -;; ;; (debug:print 7 "Updating as many as " (length tdats) " records for run " run-id) -;; (for-each -;; (lambda (tdat) ;; iterate over tests -;; (let ((test-id (vector-ref tdat 0))) -;; (sqlite3:with-transaction -;; todb -;; (lambda () -;; (let ((curr-tdat #f)) -;; (sqlite3:for-each-row -;; (lambda (a . b) -;; (set! curr-tdat (apply vector a b))) -;; tgetstmt -;; test-id) -;; (if (not (equal? curr-tdat tdat)) ;; something changed -;; (begin -;; (debug:print 0 " test-id: " test-id -;; "\ncurr-tdat: " curr-tdat -;; "\n tdat: " tdat) -;; (apply sqlite3:execute tputstmt (vector->list tdat)) -;; (set! trecchgd (+ trecchgd 1))))))))) -;; tdats))) -;; run-ids) -;; (sqlite3:finalize! tgetstmt) -;; (sqlite3:finalize! tputstmt)) -;; -;; ;; Next sync runs table -;; (let* ((rdats '()) -;; (keys (db:get-keys fromdb)) -;; (rstdfields (conc "id," (string-intersperse keys ",") ",runname,state,status,owner,event_time,comment,fail_count,pass_count")) -;; (rnumfields (length (string-split rstdfields ","))) -;; (runslots (string-intersperse (make-list rnumfields "?") ",")) -;; (rgetstmt (sqlite3:prepare todb (conc "SELECT " rstdfields " FROM runs WHERE id=?;"))) -;; (rputstmt (sqlite3:prepare todb (conc "INSERT OR REPLACE INTO runs (" rstdfields ") VALUES ( " runslots " );")))) -;; ;; first collect all the source run data -;; (sqlite3:for-each-row -;; (lambda (a . b) -;; (set! rdats (cons (apply vector a b) rdats))) -;; fromdb -;; (conc "SELECT " rstdfields " FROM runs;")) -;; (sqlite3:with-transaction -;; todb -;; (lambda () -;; (for-each -;; (lambda (rdat) -;; (let ((run-id (vector-ref rdat 0)) -;; (curr-rdat #f)) -;; ;; first get the current value of the equivalent row from the target -;; ;; read, then insert/overwrite if different -;; (sqlite3:for-each-row -;; (lambda (a . b) -;; (set! curr-rdat (apply vector a b))) -;; rgetstmt -;; run-id) -;; (if (not (equal? curr-rdat rdat)) -;; (begin -;; (debug:print 0 " run-id: " run-id -;; "\ncurr-rdat: " curr-rdat -;; "\n rdat: " rdat) -;; (set! rrecchgd (+ rrecchgd 1)) -;; (apply sqlite3:execute rputstmt (vector->list rdat)))))) -;; rdats))) -;; (sqlite3:finalize! rgetstmt) -;; (sqlite3:finalize! rputstmt)) -;; -;; (if (> rrecchgd 0) (debug:print 0 "synced " rrecchgd " changed records in runs table")) -;; (if (> trecchgd 0) (debug:print 0 "synced " trecchgd " changed records in tests table")) -;; (if (> tmrecchgd 0) (debug:print 0 "sync'd " tmrecchgd " changed records in test_meta table")) -;; (+ rrecchgd trecchgd tmrecchgd))) - (define (db:sync-back) (db:sync-tables (db:tbls *inmemdb*) *inmemdb* *db*)) ;; (db:sync-to *inmemdb* *db*)) ;; 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*))) - (let* ((db (cond - ((sqlite3:database? idb) idb) - ((not idb) (open-db)) - ((procedure? idb) (idb)) - (else (open-db)))) + (let* ((db (cond + ((sqlite3:database? idb) idb) + ((not idb) (debug:print 0 "ERROR: cannot open-run-close with #f anymore")) + ((procedure? idb) (idb)) + (else (debug:print 0 "ERROR: cannot open-run-close with #f anymore")))) (res #f)) (set! res (apply proc db params)) - (if (not idb)(sqlite3:finalize! db)) + (if (not idb)(sqlite3:finalize! dbstruct)) (debug:print-info 11 "open-run-close-no-exception-handling END" ) res) #f)) (define (open-run-close-exception-handling proc idb . params) @@ -384,37 +394,16 @@ (thread-sleep! (random 120)) (debug:print-info 0 "trying db call one more time....") (apply open-run-close-no-exception-handling proc idb params)) (apply open-run-close-no-exception-handling proc idb params))) -;; (define open-run-close open-run-close-exception-handling) -(define open-run-close open-run-close-no-exception-handling) - -(define *global-delta* 0) -(define *last-global-delta-printed* 0) - -(define (open-run-close-measure proc idb . params) - (debug:print-info 11 "open-run-close-measure START, idb=" idb ", params=" params) - (let* ((start-ms (current-milliseconds)) - (db (if idb idb (open-db))) - (throttle (string->number (config-lookup *configdat* "setup" "throttle")))) - ;; (db:set-sync db) - (set! res (apply proc db params)) - (if (not idb)(sqlite3:finalize! db)) - ;; scale by 10, average with current value. - (set! *global-delta* (/ (+ *global-delta* (* (- (current-milliseconds) start-ms) - (if throttle throttle 0.01))) - 2)) - (if (> (abs (- *last-global-delta-printed* *global-delta*)) 0.08) ;; don't print all the time, only if it changes a bit - (begin - (debug:print-info 1 "launch throttle factor=" *global-delta*) - (set! *last-global-delta-printed* *global-delta*))) - (debug:print-info 11 "open-run-close-measure END" ) - res)) - -(define (db:initialize db) - (debug:print-info 11 "db:initialize START") +;; (define open-run-close +(define open-run-close ;; (if (debug:debug-mode 2) + 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:config-get-fields configdat)) (havekeys (> (length keys) 0)) (keystr (keys->keystr keys)) (fieldstr (keys->key/field keys))) @@ -426,12 +415,10 @@ (begin (print "ERROR: your key cannot be named " keyn " as this conflicts with the same named field in the runs table") (system (conc "rm -f " dbpath)) (exit 1))))) keys) - ;; (sqlite3:execute db "PRAGMA synchronous = OFF;") - (db:set-sync db) (sqlite3:execute db "CREATE TABLE IF NOT EXISTS keys (id INTEGER PRIMARY KEY, fieldname TEXT, fieldtype TEXT, CONSTRAINT keyconstraint UNIQUE (fieldname));") (for-each (lambda (key) (sqlite3:execute db "INSERT INTO keys (fieldname,fieldtype) VALUES (?,?);" key "TEXT")) keys) (sqlite3:execute db (conc @@ -444,13 +431,39 @@ "event_time TIMESTAMP DEFAULT (strftime('%s','now'))," "comment TEXT DEFAULT ''," "fail_count INTEGER DEFAULT 0," "pass_count INTEGER DEFAULT 0," "CONSTRAINT runsconstraint UNIQUE (runname" (if havekeys "," "") keystr "));")) + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_meta ( + id INTEGER PRIMARY KEY, + testname TEXT DEFAULT '', + author TEXT DEFAULT '', + owner TEXT DEFAULT '', + description TEXT DEFAULT '', + reviewed TIMESTAMP, + iterated TEXT DEFAULT '', + avg_runtime REAL, + avg_disk REAL, + tags TEXT DEFAULT '', + jobgroup TEXT DEFAULT 'default', + CONSTRAINT test_meta_constraint UNIQUE (testname));") (sqlite3:execute db (conc "CREATE INDEX runs_index ON runs (runname" (if havekeys "," "") keystr ");")) - (sqlite3:execute db - "CREATE TABLE IF NOT EXISTS tests + ;; (sqlite3:execute db "CREATE VIEW runs_tests AS SELECT * FROM runs INNER JOIN tests ON runs.id=tests.run_id;") + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS extradat (id INTEGER PRIMARY KEY, run_id INTEGER, key TEXT, val TEXT);") + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT, + CONSTRAINT metadat_constraint UNIQUE (var));") + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);") + ;; Must do this *after* running patch db !! No more. + (db:set-var db "MEGATEST_VERSION" megatest-version) + (debug:print-info 11 "db:initialize END"))) + +;;====================================================================== +;; R U N S P E C I F I C D B +;;====================================================================== + +(define (db:initialized-run-id-db db run-id) + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS tests (id INTEGER PRIMARY KEY, run_id INTEGER DEFAULT -1, testname TEXT DEFAULT 'noname', host TEXT DEFAULT 'n/a', cpuload REAL DEFAULT -1, @@ -468,14 +481,12 @@ comment TEXT DEFAULT '', event_time TIMESTAMP DEFAULT (strftime('%s','now')), fail_count INTEGER DEFAULT 0, pass_count INTEGER DEFAULT 0, archived INTEGER DEFAULT 0, -- 0=no, 1=in progress, 2=yes - CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path) - );") + CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path));") (sqlite3:execute db "CREATE INDEX tests_index ON tests (run_id, testname, item_path);") - (sqlite3:execute db "CREATE VIEW runs_tests AS SELECT * FROM runs INNER JOIN tests ON runs.id=tests.run_id;") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_steps (id INTEGER PRIMARY KEY, test_id INTEGER, stepname TEXT, state TEXT DEFAULT 'NOT_STARTED', @@ -482,26 +493,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 extradat (id INTEGER PRIMARY KEY, run_id INTEGER, key TEXT, val TEXT);") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT, - CONSTRAINT metadat_constraint UNIQUE (var));") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_meta (id INTEGER PRIMARY KEY, - testname TEXT DEFAULT '', - author TEXT DEFAULT '', - owner TEXT DEFAULT '', - description TEXT DEFAULT '', - 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, @@ -510,23 +514,28 @@ units TEXT, comment TEXT DEFAULT '', status TEXT DEFAULT 'n/a', type TEXT DEFAULT '', CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));") - ;; Must do this *after* running patch db !! No more. - (db:set-var db "MEGATEST_VERSION" megatest-version) - (debug:print-info 11 "db:initialize END") - )) + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_rundat ( + id INTEGER PRIMARY KEY, + test_id INTEGER, + update_time TIMESTAMP, + cpuload INTEGER DEFAULT -1, + diskfree INTEGER DEFAULT -1, + diskusage INTGER DEFAULT -1, + run_duration INTEGER DEFAULT 0);") + db) ;;====================================================================== ;; L O G G I N G D B ;;====================================================================== (define (open-logging-db) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) (let* ((dbpath (conc (if *toppath* (conc *toppath* "/") "") "logging.db")) ;; fname) (dbexists (file-exists? dbpath)) - (db (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath)) + (db (sqlite3:open-database dbpath)) (handler (make-busy-timeout (if (args:get-arg "-override-timeout") (string->number (args:get-arg "-override-timeout")) 136000)))) ;; 136000))) (sqlite3:set-busy-handler! db handler) (if (not dbexists) @@ -535,13 +544,10 @@ (sqlite3:execute db (conc "PRAGMA synchronous = 0;")))) db)) (define (db:log-local-event . loglst) (let ((logline (apply conc loglst))) - ;; (pwd (current-directory)) - ;; (cmdline (string-intersperse (argv) " ")) - ;; (pid (current-process-id))) (db:log-event logline))) (define (db:log-event logline) (let ((db (open-logging-db))) (sqlite3:execute db "INSERT INTO log (logline,pwd,cmdline,pid) VALUES (?,?,?,?);" @@ -551,93 +557,12 @@ (current-process-id)) (sqlite3:finalize! db) logline)) ;;====================================================================== -;; TODO: -;; put deltas into an assoc list with version numbers -;; apply all from last to current +;; D B U T I L S ;;====================================================================== -(define (patch-db db) - (handle-exceptions - exn - (begin - (print "Exception: " exn) - (print "ERROR: Possible out of date schema, attempting to add table metadata...") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER, var TEXT, val TEXT, - CONSTRAINT metadat_constraint UNIQUE (var));") - (if (not (db:get-var db "MEGATEST_VERSION")) - (db:set-var db "MEGATEST_VERSION" 1.17))) - (let ((mver (db:get-var db "MEGATEST_VERSION")) - (test-meta-def "CREATE TABLE IF NOT EXISTS test_meta (id INTEGER PRIMARY KEY, - testname TEXT DEFAULT '', - author TEXT DEFAULT '', - owner TEXT DEFAULT '', - description TEXT DEFAULT '', - reviewed TIMESTAMP, - iterated TEXT DEFAULT '', - avg_runtime REAL, - avg_disk REAL, - tags TEXT DEFAULT '', - CONSTRAINT test_meta_constraint UNIQUE (testname));")) - (print "Current schema version: " mver " current megatest version: " megatest-version) - (cond - ((not mver) - (print "Adding megatest-version to metadata") ;; Need to recreate the table - (sqlite3:execute db "DROP TABLE IF EXISTS metadat;") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER, var TEXT, val TEXT, - CONSTRAINT metadat_constraint UNIQUE (var));") - (db:set-var db "MEGATEST_VERSION" 1.17) - (patch-db)) - ((< mver 1.21) - (sqlite3:execute db "DROP TABLE IF EXISTS metadat;") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER, var TEXT, val TEXT, - CONSTRAINT metadat_constraint UNIQUE (var));") - (db:set-var db "MEGATEST_VERSION" 1.21) ;; set before, just in case the changes are already applied - (sqlite3:execute db test-meta-def) - ;(for-each - ; (lambda (stmt) - ; (sqlite3:execute db stmt)) - ; (list - ; "ALTER TABLE tests ADD COLUMN first_err TEXT;" - ; "ALTER TABLE tests ADD COLUMN first_warn TEXT;" - ; )) - (patch-db)) - ((< mver 1.24) - (db:set-var db "MEGATEST_VERSION" 1.24) - (sqlite3:execute db "DROP TABLE IF EXISTS test_data;") - (sqlite3:execute db "DROP TABLE IF EXISTS test_meta;") - (sqlite3:execute db test-meta-def) - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY, - test_id INTEGER, - category TEXT DEFAULT '', - variable TEXT, - value REAL, - expected REAL, - tol REAL, - units TEXT, - comment TEXT DEFAULT '', - status TEXT DEFAULT 'n/a', - CONSTRAINT test_data UNIQUE (test_id,category,variable));") - (print "WARNING: Table test_data and test_meta were recreated. Please do megatest -update-meta") - (patch-db)) - ((< mver 1.27) - (db:set-var db "MEGATEST_VERSION" 1.27) - (sqlite3:execute db "ALTER TABLE test_data ADD COLUMN type TEXT DEFAULT '';") - (patch-db)) - ((< mver 1.29) - (db:set-var db "MEGATEST_VERSION" 1.29) - (sqlite3:execute db "ALTER TABLE test_steps ADD COLUMN logfile TEXT DEFAULT '';") - (sqlite3:execute db "ALTER TABLE tests ADD COLUMN shortdir TEXT DEFAULT '';")) - ((< mver 1.36) - (db:set-var db "MEGATEST_VERSION" 1.36) - (sqlite3:execute db "ALTER TABLE test_meta ADD COLUMN jobgroup TEXT DEFAULT 'default';")) - ((< mver 1.37) - (db:set-var db "MEGATEST_VERSION" 1.37) - (sqlite3:execute db "ALTER TABLE tests ADD COLUMN archived INTEGER DEFAULT 0;")) - ((< mver megatest-version) - (db:set-var db "MEGATEST_VERSION" megatest-version)))))) ;;====================================================================== ;; M A I N T E N A N C E ;;====================================================================== @@ -705,12 +630,16 @@ ;; b. If test dir gone, delete the test record ;; 2. Look at run records ;; a. If have tests that are not deleted, set state='unknown' ;; b. .... ;; -(define (db:clean-up db) - (let ((count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests)+(SELECT count(id) FROM runs);")) +(define (db:clean-up dbstruct) + + (debug:print 0 "ERROR: db clean up not ported yet") + + (let* ((db (db:get-db dbstruct #f)) + (count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests)+(SELECT count(id) FROM runs);")) (statements (map (lambda (stmt) (sqlite3:prepare db stmt)) (list ;; delete all tests that belong to runs that are 'deleted' @@ -738,25 +667,28 @@ (sqlite3:finalize! count-stmt) (db:find-and-mark-incomplete db) (sqlite3:execute db "VACUUM;"))) ;;====================================================================== -;; meta get and set vars +;; M E T A G E T A N D S E T V A R S ;;====================================================================== ;; returns number if string->number is successful, string otherwise ;; also updates *global-delta* -(define (db:get-var db var) - (debug:print-info 11 "db:get-var START " var) +;; +;; Operates on megatestdb +;; +(define (db:get-var dbstruct var) (let* ((start-ms (current-milliseconds)) (throttle (let ((t (config-lookup *configdat* "setup" "throttle"))) (if t (string->number t) t))) (res #f)) (sqlite3:for-each-row (lambda (val) (set! res val)) - db "SELECT val FROM metadat WHERE var=?;" var) + (db:get-db dbstruct #f) + "SELECT val FROM metadat WHERE var=?;" var) ;; convert to number if can (if (string? res) (let ((valnum (string->number res))) (if valnum (set! res valnum)))) ;; scale by 10, average with current value. @@ -765,37 +697,32 @@ 2)) (if (> (abs (- *last-global-delta-printed* *global-delta*)) 0.08) ;; don't print all the time, only if it changes a bit (begin (debug:print-info 4 "launch throttle factor=" *global-delta*) (set! *last-global-delta-printed* *global-delta*))) - (debug:print-info 11 "db:get-var END " var " val=" res) res)) -(define (db:set-var db var val) - (debug:print-info 11 "db:set-var START " var " " val) - (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val) - (debug:print-info 11 "db:set-var END " var " " val)) - -(define (db:del-var db var) - (debug:print-info 11 "db:del-var START " var) - (sqlite3:execute db "DELETE FROM metadat WHERE var=?;" var) - (debug:print-info 11 "db:del-var END " var)) +(define (db:set-var dbstruct var val) + (sqlite3:execute (db:get-db dbstruct #f) "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val)) + +(define (db:del-var dbstruct var) + (sqlite3:execute (db:get-db dbstruct #f) "DELETE FROM metadat WHERE var=?;" var)) ;; use a global for some primitive caching, it is just silly to ;; re-read the db over and over again for the keys since they never ;; change ;; why get the keys from the db? why not get from the *configdat* ;; using keys:config-get-fields? -(define (db:get-keys db) +(define (db:get-keys dbstruct) (if *db-keys* *db-keys* (let ((res '())) (sqlite3:for-each-row (lambda (key) (set! res (cons key res))) - db + (db:get-db dbstruct #f) "SELECT fieldname FROM keys ORDER BY id DESC;") (set! *db-keys* res) res))) ;; @@ -811,26 +738,26 @@ ;;====================================================================== ;; R U N S ;;====================================================================== -(define (db:get-run-name-from-id db run-id) +(define (db:get-run-name-from-id dbstruct run-id) (let ((res #f)) (sqlite3:for-each-row (lambda (runname) (set! res runname)) - db + (db:get-db dbstruct #f) "SELECT runname FROM runs WHERE id=?;" run-id) res)) -(define (db:get-run-key-val db run-id key) +(define (db:get-run-key-val dbstruct run-id key) (let ((res #f)) (sqlite3:for-each-row (lambda (val) (set! res val)) - db + (db:get-db dbstruct #f) (conc "SELECT " key " FROM runs WHERE id=?;") run-id) res)) ;; keys list to key1,key2,key3 ... @@ -853,13 +780,14 @@ patts)) comparator))) ;; register a test run with the db -(define (db:register-run db keyvals runname state status user) +(define (db:register-run dbstruct keyvals runname state status user) (debug:print 3 "runs:register-run runname: " runname " state: " state " status: " status " user: " user) - (let* ((keys (map car keyvals)) + (let* ((db (db:get-db dbstruct #f)) + (keys (map car keyvals)) (keystr (keys->keystr keys)) (comma (if (> (length keys) 0) "," "")) (andstr (if (> (length keys) 0) " AND " "")) (valslots (keys->valslots keys)) ;; ?,?,? ... (allvals (append (list runname state status user) (map cadr keyvals))) @@ -897,13 +825,14 @@ ;; replace header and keystr with a call to runs:get-std-run-fields ;; ;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) ;; runpatts: patt1,patt2 ... ;; -(define (db:get-runs db runpatt count offset keypatts) - (let* ((res '()) - (keys (db:get-keys db)) +(define (db:get-runs dbstruct runpatt count offset keypatts) + (let* ((db (db:get-db dbstruct #f)) + (res '()) + (keys (db:get-keys dbstruct)) (runpattstr (db:patt->like "runname" runpatt)) (remfields (list "id" "runname" "state" "status" "owner" "event_time")) (header (append keys remfields)) (keystr (conc (keys->keystr keys) "," (string-intersperse remfields ","))) @@ -935,13 +864,13 @@ (debug:print-info 11 "db:get-runs END qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count) (vector header res))) ;; Get all targets from the db ;; -(define (db:get-targets db) +(define (db:get-targets dbstruct) (let* ((res '()) - (keys (db:get-keys db)) + (keys (db:get-keys dbstruct)) (header keys) ;; (map key:get-fieldname keys)) (keystr (keys->keystr keys)) (qrystr (conc "SELECT " keystr " FROM runs;")) (seen (make-hash-table))) (sqlite3:for-each-row @@ -949,56 +878,69 @@ (let ((targ (cons a x))) (if (not (hash-table-ref/default seen targ #f)) (begin (hash-table-set! seen targ #t) (set! res (cons (apply vector targ) res)))))) - db + (db:get-db dbstruct #f) qrystr) (debug:print-info 11 "db:get-targets END qrystr: " qrystr ) (vector header res))) ;; just get count of runs -(define (db:get-num-runs db runpatt) +(define (db:get-num-runs dbstruct runpatt) (let ((numruns 0)) (debug:print-info 11 "db:get-num-runs START " runpatt) (sqlite3:for-each-row (lambda (count) (set! numruns count)) - db + (db:get-db dbstruct #f) "SELECT COUNT(id) FROM runs WHERE runname LIKE ? AND state != 'deleted';" runpatt) (debug:print-info 11 "db:get-num-runs END " runpatt) numruns)) ;; get some basic run stats ;; ;; ( (runname (( state count ) ... )) ;; ( ... -(define (db:get-run-stats db) +(define (db:get-run-stats dbstruct) (let ((totals (make-hash-table)) - (res '())) + (res '()) + (runs-info '())) + ;; First get all the runname/run-ids (sqlite3:for-each-row - (lambda (runname state count) + (lambda (run-id runname) + (set! runs-info (cons (list runname run-id) runs-info))) + (db:get-db dbstruct #f) + "SELECT id,runname FROM runs;") + ;; for each run get stats data + (for-each + (lambda (run-info) + (let ((run-name (cadr run-info)) + (run-id (car run-info))) + (sqlite3:for-each-row + (lambda (state count) (let* ((stateparts (string-split state "|")) (newstate (conc (car stateparts) "\n" (cadr stateparts)))) (hash-table-set! totals newstate (+ (hash-table-ref/default totals newstate 0) count)) (set! res (cons (list runname newstate count) res)))) - db - "SELECT runname,t.state||'|'||t.status AS s,count(t.id) FROM runs AS r INNER JOIN tests AS t ON r.id=t.run_id GROUP BY s,runname ORDER BY r.event_time,s DESC;" ) + (db:get-db dbstruct run-id) + "SELECT state||'|'||status AS s,count(id) FROM tests AS t ON ORDER BY s DESC;" ) ;; (set! res (reverse res)) (for-each (lambda (state) (set! res (cons (list "Totals" state (hash-table-ref totals state)) res))) - (sort (hash-table-keys totals) string>=)) + (sort (hash-table-keys totals) string>=)))) + runs-info) res)) ;; db:get-runs-by-patt ;; get runs by list of criteria ;; register a test run with the db ;; ;; Use: (db-get-value-by-header (db:get-header runinfo)(db:get-row runinfo)) ;; to extract info from the structure returned ;; -(define (db:get-runs-by-patt db keys runnamepatt targpatt offset limit) ;; test-name) +(define (db:get-runs-by-patt dbstruct keys runnamepatt targpatt offset limit) ;; test-name) (let* ((tmp (runs:get-std-run-fields keys '("id" "runname" "state" "status" "owner" "event_time"))) (keystr (car tmp)) (header (cadr tmp)) (res '()) (key-patt "") @@ -1022,64 +964,70 @@ ";")) (debug:print-info 4 "runs:get-runs-by-patt qry=" qry-str " " runnamepatt) (sqlite3:for-each-row (lambda (a . r) (set! res (cons (list->vector (cons a r)) res))) - db + (db:get-db dbstruct #f) qry-str runnamepatt) (vector header res))) ;; use (get-value-by-header (db:get-header runinfo)(db:get-row runinfo)) -(define (db:get-run-info db run-id) +(define (db:get-run-info dbstruct run-id) ;;(if (hash-table-ref/default *run-info-cache* run-id #f) ;; (hash-table-ref *run-info-cache* run-id) (let* ((res (vector #f #f #f #f)) - (keys (db:get-keys db)) + (keys (db:get-keys dbstruct)) (remfields (list "id" "runname" "state" "status" "owner" "event_time")) (header (append keys remfields)) (keystr (conc (keys->keystr keys) "," (string-intersperse remfields ",")))) (debug:print-info 11 "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr) (sqlite3:for-each-row (lambda (a . x) (set! res (apply vector a x))) - db + (db:get-db dbstruct #f) (conc "SELECT " keystr " FROM runs WHERE id=? AND state != 'deleted';") run-id) (debug:print-info 11 "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr) (let ((finalres (vector header res))) ;; (hash-table-set! *run-info-cache* run-id finalres) finalres))) -(define (db:set-comment-for-run db run-id comment) - (sqlite3:execute db "UPDATE runs SET comment=? WHERE id=?;" comment run-id)) +(define (db:set-comment-for-run dbstruct run-id comment) + (sqlite3:execute (db:get-db dbstruct #f) "UPDATE runs SET comment=? WHERE id=?;" (sdb:qry 'getid comment) run-id)) ;; does not (obviously!) removed dependent data. But why not!!? -(define (db:delete-run db run-id) +(define (db:delete-run dbstruct run-id) ;; First set any related tests to DELETED - (let ((stmt1 (sqlite3:prepare db "UPDATE tests SET state='DELETED',comment='' WHERE run_id=?;")) - (stmt2 (sqlite3:prepare db "UPDATE runs SET state='deleted',comment='' WHERE id=?;"))) - (sqlite3:with-transaction - db (lambda () - (sqlite3:execute stmt1 run-id) - (sqlite3:execute stmt2 run-id))) - (sqlite3:finalize! stmt1) - (sqlite3:finalize! stmt2))) - -(define (db:update-run-event_time db run-id) - (sqlite3:execute db "UPDATE runs SET event_time=strftime('%s','now') WHERE id=?;" run-id)) - -(define (db:lock/unlock-run db run-id lock unlock user) + (let ((db (db:get-db dbstruct run-id))) + (sqlite3:execute db "UPDATE tests SET state='DELETED',comment='';") + (sqlite3:execute db "DELETE FROM test_steps;") + (sqlite3:execute db "DELETE FROM test_data;") + (sqlite3:execute (db:get-db dbstruct #f) "UPDATE runs SET state='deleted',comment='' WHERE id=?;" run-id))) + +(define (db:update-run-event_time dbstruct run-id) + (sqlite3:execute (db:get-db dbstruct #f) "UPDATE runs SET event_time=strftime('%s','now') WHERE id=?;" run-id)) + +(define (db:lock/unlock-run dbstruct run-id lock unlock user) (let ((newlockval (if lock "locked" (if unlock "unlocked" "locked")))) ;; semi-failsafe - (sqlite3:execute db "UPDATE runs SET state=? WHERE id=?;" newlockval run-id) - (sqlite3:execute db "INSERT INTO access_log (user,accessed,args) VALUES(?,strftime('%s','now'),?);" + (sqlite3:execute (db:get-db dbstruct #f) "UPDATE runs SET state=? WHERE id=?;" newlockval run-id) + (sqlite3:execute (db:get-db dbstruct #f) "INSERT INTO access_log (user,accessed,args) VALUES(?,strftime('%s','now'),?);" user (conc newlockval " " run-id)) (debug:print-info 1 "" newlockval " run number " run-id))) + +(define (db:get-all-run-ids dbstruct) + (let ((res '())) + (sqlite3:for-each-row + (lambda (run-id) + (set! res (cons run-id res))) + (db:get-db dbstruct #f) + "SELECT id FROM runs;") + (reverse res))) (define (db:get-run-ids db) (let ((res '())) (sqlite3:for-each-row (lambda (id) @@ -1091,54 +1039,49 @@ ;; K E Y S ;;====================================================================== ;; get key val pairs for a given run-id ;; ( (FIELDNAME1 keyval1) (FIELDNAME2 keyval2) ... ) -(define (db:get-key-val-pairs db run-id) - (let* ((keys (db:get-keys db)) +(define (db:get-key-val-pairs dbstruct run-id) + (let* ((keys (db:get-keys dbstruct)) (res '())) - (debug:print-info 11 "db:get-key-val-pairs START keys: " keys " run-id: " run-id) (for-each (lambda (key) (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;"))) ;; (debug:print 0 "qry: " qry) (sqlite3:for-each-row (lambda (key-val) (set! res (cons (list key key-val) res))) - db qry run-id))) + (db:get-db dbstruct #f) qry run-id))) keys) - (debug:print-info 11 "db:get-key-val-pairs END keys: " keys " run-id: " run-id) (reverse res))) ;; get key vals for a given run-id -(define (db:get-key-vals db run-id) +(define (db:get-key-vals dbstruct run-id) (let ((mykeyvals (hash-table-ref/default *keyvals* run-id #f))) (if mykeyvals mykeyvals - (let* ((keys (db:get-keys db)) + (let* ((keys (db:get-keys dbstruct)) (res '())) - (debug:print-info 11 "db:get-key-vals START keys: " keys " run-id: " run-id) (for-each (lambda (key) (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;"))) - ;; (debug:print 0 "qry: " qry) (sqlite3:for-each-row (lambda (key-val) (set! res (cons key-val res))) - db qry run-id))) + (db:get-db dbstruct #f) qry run-id))) keys) - (debug:print-info 11 "db:get-key-vals END keys: " keys " run-id: " run-id) (let ((final-res (reverse res))) (hash-table-set! *keyvals* run-id final-res) final-res))))) ;; The target is keyval1/keyval2..., cached in *target* as it is used often -(define (db:get-target db run-id) +(define (db:get-target dbstruct run-id) (let ((mytarg (hash-table-ref/default *target* run-id #f))) (if mytarg mytarg - (let* ((keyvals (db:get-key-vals db run-id)) + (let* ((keyvals (db:get-key-vals dbstruct run-id)) (thekey (string-intersperse (map (lambda (x)(if x x "-na-")) keyvals) "/"))) (hash-table-set! *target* run-id thekey) thekey)))) ;;====================================================================== @@ -1201,11 +1144,11 @@ ))) (debug:print-info 8 "db:get-tests-for-run qry=" qry) (sqlite3:for-each-row (lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) (set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res))) - db + (db:get-db dbstruct run-id) qry run-id ) (case qryvals ((shortlist)(map db:test-short-record->norm res)) @@ -1254,265 +1197,198 @@ ;; get a useful subset of the tests data (used in dashboard ;; use db:mintests-get-{id ,run_id,testname ...} (define (db:get-tests-for-runs-mindata db run-ids testpatt states status not-in) (db:get-tests-for-runs db run-ids testpatt states status not-in: not-in qryvals: "id,run_id,testname,state,status,event_time,item_path")) - -;; NB // This is get tests for "runs" (note the plural!!) +;; Convert calling routines to get list of run-ids and loop, do not use the get-tests-for-runs ;; -;; states and statuses are lists, turn them into ("PASS","FAIL"...) and use NOT IN -;; i.e. these lists define what to NOT show. -;; states and statuses are required to be lists, empty is ok -;; not-in #t = above behaviour, #f = must match -;; run-ids is a list of run-ids or a single number or #f for all runs -(define (db:get-tests-for-runs db run-ids testpatt states statuses - #!key (not-in #t) - (sort-by #f) - (qryvals "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment")) ;; 'rundir 'event_time - (let* ((res '()) - ;; if states or statuses are null then assume match all when not-in is false - (states-qry (if (null? states) - #f - (conc " state " - (if not-in "NOT" "") - " IN ('" - (string-intersperse states "','") - "')"))) - (statuses-qry (if (null? statuses) - #f - (conc " status " - (if not-in "NOT" "") - " IN ('" - (string-intersperse statuses "','") - "')"))) - (tests-match-qry (tests:match->sqlqry testpatt)) - (qry (conc "SELECT " qryvals - " FROM tests WHERE state != 'DELETED' " - (if run-ids - (if (list? run-ids) - (conc "AND run_id IN (" (string-intersperse (map conc run-ids) ",") ") ") - (conc "AND run_id=" run-ids " ")) - " ") ;; #f => run-ids don't filter on run-ids - (if states-qry (conc " AND " states-qry) "") - (if statuses-qry (conc " AND " statuses-qry) "") - (if tests-match-qry (conc " AND (" tests-match-qry ") ") "") - (case sort-by - ((rundir) " ORDER BY length(rundir) DESC;") - ((event_time) " ORDER BY event_time ASC;") - (else ";")) - ))) - (debug:print-info 8 "db:get-tests-for-runs qry=" qry) - (sqlite3:for-each-row - (lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) - (set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res))) - db - qry - ) - res)) - -(define (db:delete-test-records db test-id) - (db:general-call db 'delete-test-step-records (list test-id)) - (db:general-call db 'delete-test-data-records (list test-id)) - (sqlite3:execute db "UPDATE tests SET state='DELETED',status='n/a',comment='' WHERE id=?;" test-id)) - -(define (db:delete-tests-for-run db run-id) - (sqlite3:execute db "DELETE FROM tests WHERE run_id=?;" run-id)) - -(define (db:delete-old-deleted-test-records db) - (let ((targtime (- (current-seconds)(* 30 24 60 60)))) ;; one month in the past - (sqlite3:execute db "DELETE FROM tests WHERE state='DELETED' AND event_timesqlqry testpatt)) - (rqry (conc "SELECT id FROM runs WHERE " keystr " AND runname LIKE '" runname "';")) - (runsqry (sqlite3:prepare db rqry)) - (tqry (conc "SELECT rundir FROM tests WHERE run_id=? AND " testqry " AND state LIKE '" statepatt "' AND status LIKE '" statuspatt "' ORDER BY event_time ASC;")) - (tstsqry (sqlite3:prepare db tqry))) - (debug:print 8 "db:test-get-paths-matching-keynames-target-new\n rqry=" rqry "\n tqry=" tqry) + (runsqry (sqlite3:prepare (db:get-db dbstruct #f)(conc "SELECT id FROM runs WHERE " keystr " AND runname LIKE '" runname "';"))) + (tstsqry (conc "SELECT rundir_id FROM tests WHERE " testqry " AND state LIKE '" statepatt "' AND status LIKE '" statuspatt "' ORDER BY event_time ASC;"))) + (debug:print 8 "db:test-get-paths-matching-keynames-target-new\n runsqry=" runsqry "\n tstqry=" tstqry) (sqlite3:for-each-row (lambda (rid) (set! row-ids (cons rid row-ids))) runsqry) (sqlite3:finalize! runsqry) (for-each (lambda (rid) (sqlite3:for-each-row (lambda (p) (set! res (cons p res))) - tstsqry rid)) + (db:get-db dbstruct rid) + tstsqry)) row-ids) - (sqlite3:finalize! tstsqry) res)) -;; look through tests from matching runs for a file -(define (db:test-get-first-path-matching db keynames target fname) - ;; [refpaths] is the section where references to other megatest databases are stored - (let ((mt-paths (configf:get-section "refpaths")) - (res (db:test-get-paths-matching db keynames target fname))) - (let loop ((pathdat (if (null? paths) #f (car mt-paths))) - (tal (if (null? paths) '()(cdr mt-paths)))) - (if (not (null? res)) - (car res) ;; return first found - (if path - (let* ((db (open-db path: (cadr pathdat))) - (newres (db:test-get-paths-matching db keynames target fname))) - (debug:print-info 4 "Trying " (car pathdat) " at " (cadr pathdat)) - (sqlite3:finalize! db) - (if (not (null? newres)) - (car newres) - (if (null? tal) - #f - (loop (car tal)(cdr tal)))))))))) - ;;====================================================================== ;; QUEUE UP META, TEST STATUS AND STEPS REMOTE ACCESS ;;====================================================================== ;; NOTE: Can remove the regex and base64 encoding for zmq @@ -1744,47 +1595,46 @@ (lambda ()(deserialize))) (vector #f #f #f))) ;; crude reply for when things go awry ((zmq)(with-input-from-string msg (lambda ()(deserialize)))) (else msg))) -(define (db:test-set-status-state db test-id status state msg) +(define (db:test-set-status-state dbstruct run-id test-id status state msg) + (let ((db (db:get-db dbstruct rid))) (if (member state '("LAUNCHED" "REMOTEHOSTSTART")) (db:general-call db 'set-test-start-time (list test-id))) (if msg (db:general-call db 'state-status-msg (list state status msg test-id)) - (db:general-call db 'state-status (list state status test-id)))) + (db:general-call db 'state-status (list state status test-id))))) (define (db:roll-up-pass-fail-counts db run-id test-name item-path status) (if (and (not (equal? item-path "")) (member status '("PASS" "WARN" "FAIL" "WAIVED" "RUNNING" "CHECK" "SKIP"))) - (handle-exceptions - exn - (begin - (debug:print 0 "Problem with call to cdb:remote-run, database may be locked and read-only, waiting and trying again ...") - (thread-sleep! 10) - (apply cdb:remote-run proc db params)) - (apply cdb:client-call *runremote* 'immediate #f *default-numtries* open-run-close proc #f params)) - (begin + (let ((db (db:get-db dbstruct rid))) (db:general-call db 'update-pass-fail-counts (list run-id test-name run-id test-name run-id test-name)) (if (equal? status "RUNNING") (db:general-call db 'top-test-set-running (list run-id test-name)) (db:general-call db 'top-test-set-per-pf-counts (list run-id test-name run-id test-name run-id test-name))) #f) #f)) -(define (db:test-get-logfile-info db run-id test-name) +(define (db:tests-register-test dbstruct run-id test-name item-path) + (sqlite3:execute (db:get-db dbstruct run-id) 'register-test run-id test-name item-path)) + +(define (db:test-get-logfile-info dbstruct run-id test-name) (let ((res #f)) (sqlite3:for-each-row - (lambda (path final_logf) - (set! logf final_logf) - (set! res (list path final_logf)) - (if (directory? path) - (debug:print 2 "Found path: " path) - (debug:print 2 "No such path: " path))) - db - "SELECT rundir,final_logf FROM tests WHERE run_id=? AND testname=? AND item_path='';" - run-id test-name) + (lambda (path-id final_logf-id) + (let ((path (sdb:qry 'getstr path-id)) + (final_logf (sdb:qry 'getstr final_logf-id))) + (set! logf final_logf) + (set! res (list path final_logf)) + (if (directory? path) + (debug:print 2 "Found path: " path) + (debug:print 2 "No such path: " path)))) + (db:get-db dbstruct run-id) + "SELECT rundir_id,final_logf_id FROM tests WHERE testname=? AND item_path='';" + test-name) res)) ;;====================================================================== ;; A G R E G A T E D T R A N S A C T I O N D B W R I T E S ;;====================================================================== @@ -1795,61 +1645,65 @@ ;; TESTS '(register-test "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path,state,status) VALUES (?,?,strftime('%s','now'),?,'NOT_STARTED','n/a');") ;; Test state and status '(set-test-state "UPDATE tests SET state=? WHERE id=?;") '(set-test-status "UPDATE tests SET state=? WHERE id=?;") - '(state-status "UPDATE tests SET state=?,status=? WHERE id=?;") - '(state-status-msg "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;") + '(state-status "UPDATE tests SET state=?,status=? WHERE id=?;") ;; DONE + '(state-status-msg "UPDATE tests SET state=?,status=?,comment_id=? WHERE id=?;") ;; DONE ;; Test comment - '(set-test-comment "UPDATE tests SET comment=? WHERE id=?;") - '(set-test-start-time "UPDATE tests SET event_time=strftime('%s','now') WHERE id=?;") + '(set-test-comment "UPDATE tests SET comment_id=? WHERE id=?;") + '(set-test-start-time "UPDATE tests SET event_time=strftime('%s','now') WHERE id=?;") ;; DONE '(pass-fail-counts "UPDATE tests SET pass_count=?,fail_count=? WHERE id=?;") ;; test_data-pf-rollup is used to set a tests PASS/FAIL based on the pass/fail info from the steps '(test_data-pf-rollup "UPDATE tests SET status=CASE WHEN (SELECT fail_count FROM tests WHERE id=?) > 0 THEN 'FAIL' WHEN (SELECT pass_count FROM tests WHERE id=?) > 0 AND (SELECT status FROM tests WHERE id=?) NOT IN ('WARN','FAIL') THEN 'PASS' ELSE status - END WHERE id=?;") - '(test-set-log "UPDATE tests SET final_logf=? WHERE id=?;") - '(test-set-rundir-by-test-id "UPDATE tests SET rundir=? WHERE id=?") - '(test-set-rundir "UPDATE tests SET rundir=? WHERE run_id=? AND testname=? AND item_path=?;") - '(delete-tests-in-state "DELETE FROM tests WHERE state=? AND run_id=?;") + END WHERE id=?;") ;; DONE + '(test-set-log "UPDATE tests SET final_logf_id=? WHERE id=?;") ;; DONE + '(test-set-rundir-by-test-id "UPDATE tests SET rundir_id=? WHERE id=?") ;; DONE + '(test-set-rundir "UPDATE tests SET rundir_id=? AND testname=? AND item_path=?;") ;; DONE + '(delete-tests-in-state "DELETE FROM tests WHERE state=?;") ;; DONE '(tests:test-set-toplog "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path='';") - '(update-cpuload-diskfree "UPDATE tests SET cpuload=?,diskfree=? WHERE id=?;") - '(update-uname-host "UPDATE tests SET uname=?,host=? WHERE id=?;") + '(update-cpuload-diskfree "UPDATE tests SET cpuload=?,diskfree=? WHERE id=?;") ;; DONE + '(update-uname-host "UPDATE tests SET uname=?,host=? WHERE id=?;") ;; DONE '(update-test-state "UPDATE tests SET state=? WHERE state=? AND run_id=? AND testname=? AND NOT (item_path='' AND testname IN (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));") '(update-test-status "UPDATE tests SET status=? WHERE status like ? AND run_id=? AND testname=? AND NOT (item_path='' AND testname IN (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));") ;; stuff for roll-up-pass-fail-counts '(update-pass-fail-counts "UPDATE tests - SET fail_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND status IN ('FAIL','CHECK')), - pass_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND status IN ('PASS','WARN','WAIVED')) - WHERE run_id=? AND testname=? AND item_path='';") - '(top-test-set-running "UPDATE tests SET state='RUNNING' WHERE run_id=? AND testname=? AND item_path='';") + SET fail_count=(SELECT count(id) FROM tests WHERE testname=? AND item_path != '' AND status IN ('FAIL','CHECK')), + pass_count=(SELECT count(id) FROM tests WHERE testname=? AND item_path != '' AND status IN ('PASS','WARN','WAIVED')) + WHERE testname=? AND item_path='';") ;; DONE + '(top-test-set-running "UPDATE tests SET state='RUNNING' WHERE testname=? AND item_path='';") ;; DONE '(top-test-set-per-pf-counts "UPDATE tests SET state=CASE WHEN (SELECT count(id) FROM tests - WHERE run_id=? AND testname=? + WHERE testname=? AND item_path != '' AND state in ('RUNNING','NOT_STARTED','LAUNCHED','REMOTEHOSTSTART')) > 0 THEN 'RUNNING' ELSE 'COMPLETED' END, status=CASE WHEN fail_count > 0 THEN 'FAIL' WHEN pass_count > 0 AND fail_count=0 THEN 'PASS' WHEN (SELECT count(id) FROM tests - WHERE run_id=? AND testname=? + WHERE testname=? AND item_path != '' AND status = 'SKIP') > 0 THEN 'SKIP' ELSE 'UNKNOWN' END - WHERE run_id=? AND testname=? AND item_path='';") + WHERE testname=? AND item_path='';") ;; DONE ;; STEPS '(delete-test-step-records "UPDATE test_steps SET status='DELETED' WHERE id=?;") '(delete-test-data-records "UPDATE test_data SET status='DELETED' WHERE id=?;") ;; using status since no state field )) + +(define (db:lookup-query qry-name) + (let ((q (alist-ref qry-name db:queries))) + (if q (car q) #f))) ;; do not run these as part of the transaction (define db:special-queries '(rollup-tests-pass-fail ;; db:roll-up-pass-fail-counts ;; WHY NOT!? login @@ -1873,18 +1727,18 @@ (query (vector-ref request-item 1)) (params (vector-ref request-item 2)) (queryh (sqlite3:prepare db query))) (apply sqlite3:execute stmt params) #f)) - -(define *db:process-queue-mutex* (make-mutex)) - -(define *number-of-writes* 0) -(define *writes-total-delay* 0) -(define *total-non-write-delay* 0) -(define *number-non-write-queries* 0) - +;; DISABLING FOR NOW +;; DISABLING FOR NOW (define *number-of-writes* 0) +;; DISABLING FOR NOW (define *writes-total-delay* 0) +;; DISABLING FOR NOW (define *total-non-write-delay* 0) +;; DISABLING FOR NOW (define *number-non-write-queries* 0) +;; DISABLING FOR NOW +;; DISABLING FOR NOW ;; The queue is a list of vectors where the zeroth slot indicates the type of query to +;; DISABLING FOR NOW ;; apply and the second slot is the time of the query and the third entry is a list of (define (db:general-call db stmtname params) (let ((query (let ((q (alist-ref (if (string? stmtname) (string->symbol stmtname) stmtname) db:queries))) @@ -1979,48 +1833,51 @@ results) (if (null? tal) (map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests (loop (car tal)(cdr tal)))))))))) -(define (db:test-get-records-for-index-file db run-id test-name) +(define (db:test-get-records-for-index-file dbstruct run-id test-name) (let ((res '())) (sqlite3:for-each-row - (lambda (id itempath state status run_duration logf comment) + (lambda (id itempath state status run_duration logf-id comment-id) + (let ((logf (db:get-string dbstruct logf-id)) + (comment (db:get-string dbstruct comment-id))) (set! res (cons (vector id itempath state status run_duration logf comment) res))) - db - "SELECT id,item_path,state,status,run_duration,final_logf,comment FROM tests WHERE run_id=? AND testname=? AND item_path != '';" - run-id test-name) - res)) + (db:get-db dbstruct run-id) + "SELECT id,item_path,state,status,run_duration,final_logf_id,comment_id FROM tests WHERE testname=? AND item_path != '';" + test-name) + res))) ;;====================================================================== ;; Tests meta data ;;====================================================================== ;; read the record given a testname -(define (db:testmeta-get-record db testname) +(define (db:testmeta-get-record dbstruct testname) (let ((res #f)) (sqlite3:for-each-row (lambda (id testname author owner description reviewed iterated avg_runtime avg_disk tags) (set! res (vector id testname author owner description reviewed iterated avg_runtime avg_disk tags))) - db "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags FROM test_meta WHERE testname=?;" + (db:get-db dbstruct #f) + "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags FROM test_meta WHERE testname=?;" testname) res)) ;; create a new record for a given testname -(define (db:testmeta-add-record db testname) - (sqlite3:execute db "INSERT OR IGNORE INTO test_meta (testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags) VALUES (?,'','','','','','','','');" testname)) +(define (db:testmeta-add-record dbstruct testname) + (sqlite3:execute (db:get-db dbstruct #f) "INSERT OR IGNORE INTO test_meta (testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags) VALUES (?,'','','','','','','','');" testname)) ;; update one of the testmeta fields -(define (db:testmeta-update-field db testname field value) - (sqlite3:execute db (conc "UPDATE test_meta SET " field "=? WHERE testname=?;") value testname)) +(define (db:testmeta-update-field dbstruct testname field value) + (sqlite3:execute (db:get-db dbstruct #f) (conc "UPDATE test_meta SET " field "=? WHERE testname=?;") value testname)) (define (db:testmeta-get-all db) (let ((res '())) (sqlite3:for-each-row (lambda (a . b) (set! res (cons (apply vector a b) res))) - db + (db:get-db dbstruct run-id) "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta;") res)) ;;====================================================================== ;; M I S C M A N A G E M E N T I T E M S @@ -2033,11 +1890,11 @@ ;; ;; Note: mode 'normal means that tests must be COMPLETED and ok (i.e. PASS, WARN, CHECK, SKIP or WAIVED) ;; mode 'toplevel means that tests must be COMPLETED only ;; mode 'itemmatch or 'itemwait means that tests items must be COMPLETED and (PASS|WARN|WAIVED|CHECK) [[ NB// NOT IMPLEMENTED YET ]] ;; -(define (db:get-prereqs-not-met db run-id waitons ref-item-path mode) +(define (db:get-prereqs-not-met dbstruct run-id waitons ref-item-path mode) (if (or (not waitons) (null? waitons)) '() (let* ((unmet-pre-reqs '()) (result '())) @@ -2101,14 +1958,16 @@ (delete-duplicates result)))) ;;====================================================================== ;; Extract ods file from the db ;;====================================================================== + +;; 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 db outputfile keypatt-alist runspatt pathmod) +(define (db:extract-ods-file dbstruct outputfile keypatt-alist runspatt pathmod) (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 '()) (windows (and pathmod (substring-index "\\" pathmod))) Index: db_records.scm ================================================================== --- db_records.scm +++ db_records.scm @@ -1,5 +1,83 @@ +;;====================================================================== +;; dbstruct +;;====================================================================== + +;; +;; -path-|-megatest.db +;; |-db-|-main.db +;; |-monitor.db +;; |-sdb.db +;; |-fdb.db +;; |-1.db +;; |-.db +(define (make-dbr:dbstruct #!key (path #f)(local #f)) + (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 + local)) ;; read-only local access + +;; get and set main db +(define-inline (dbr:dbstruct-get-main vec) (vector-ref vec 0)) +(define-inline (dbr:dbstruct-set-main! vec db)(vector-set! vec 0 db)) + +;; get a rundb vector +(define (dbr:dbstruct-get-rundb-rec vec run-id) + (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 #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 + ((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)) + (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))) + +;; get/set inmemdb +(define (dbr:dbstruct-get-inmemdb vec run-id) + (let ((runvec (dbr:dbstruct-get-rundb-rec vec run-id))) + (vector-ref runvec 1))) + +(define (dbr:dbstruct-set-inmemdb! vec run-id inmemdb) + (let ((runvec (dbr:dbstruct-get-rundb-rec vec run-id))) + (vector-set! runvec 1 inmemdb))) + +;; the string db +(define-inline (dbr:dbstruct-get-strdb vec) (vector-ref vec 2)) +(define-inline (dbr:dbstruct-set-strdb! vec db)(vector-set! vec 2 db)) + +;; path +(define-inline (dbr:dbstruct-get-path vec) (vector-ref vec 3)) +(define-inline (dbr:dbstruct-set-path! vec path)(vector-set! vec 3)) + +;; local +(define-inline (dbr:dbstruct-get-local vec) (vector-ref vec 4)) +(define-inline (dbr:dbstruct-set-local! vec val)(vector-set! vec 4 val)) + + (define (make-db:test)(make-vector 20)) (define-inline (db:test-get-id vec) (vector-ref vec 0)) (define-inline (db:test-get-run_id vec) (vector-ref vec 1)) (define-inline (db:test-get-testname vec) (vector-ref vec 2)) (define-inline (db:test-get-state vec) (vector-ref vec 3)) Index: ezsteps.scm ================================================================== --- ezsteps.scm +++ ezsteps.scm @@ -16,18 +16,20 @@ (declare (unit ezsteps)) (declare (uses db)) (declare (uses common)) (declare (uses items)) (declare (uses runconfig)) +(declare (uses sdb)) +(declare (uses filedb)) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") (define (ezsteps:run-from testdat start-step-name run-one) - (let* ((test-run-dir (db:test-get-rundir testdat)) + (let* ((test-run-dir (filedb:get-path *fdb* (db:test-get-rundir testdat))) (testconfig (read-config (conc test-run-dir "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) (ezstepslst (hash-table-ref/default testconfig "ezsteps" '())) (run-mutex (make-mutex)) (rollup-status 0) (exit-info (vector #t #t #t)) Index: filedb.scm ================================================================== --- filedb.scm +++ filedb.scm @@ -23,11 +23,11 @@ (filedb:fdb-set-db! fdb db) (filedb:fdb-set-dbpath! fdb dbpath) (filedb:fdb-set-pathcache! fdb (make-hash-table)) (filedb:fdb-set-idcache! fdb (make-hash-table)) (filedb:fdb-set-partcache! fdb (make-hash-table)) - ;(sqlite3:set-busy-timeout! db 1000000) + (sqlite3:set-busy-handler! db (make-busy-timeout 136000)) (if (not dbexists) (begin (sqlite3:execute db "PRAGMA synchronous = OFF;") (sqlite3:execute db "CREATE TABLE names (id INTEGER PRIMARY KEY,name TEST);") ;; for future use - change path in paths table to path_id (sqlite3:execute db "CREATE INDEX name_index ON names (name);") @@ -40,12 +40,20 @@ gid INTEGER DEFAULT -1, size INTEGER DEFAULT -1, mtime INTEGER DEFAULT -1);") (sqlite3:execute db "CREATE INDEX path_index ON paths (path,parent_id);") (sqlite3:execute db "CREATE TABLE bases (id INTEGER PRIMARY KEY,base TEXT, updated TIMESTAMP);"))) + ;; close the sqlite3 db and open it as needed + (filedb:finalize-db! fdb) + (filedb:fdb-set-db! fdb #f) fdb)) +(define (filedb:reopen-db fdb) + (let ((db (sqlite3:open-database (filedb:fdb-get-dbpath fdb)))) + (filedb:fdb-set-db! fdb db) + (sqlite3:set-busy-handler! db (make-busy-timeout 136000)))) + (define (filedb:finalize-db! fdb) (sqlite3:finalize! (filedb:fdb-get-db fdb))) (define (filedb:get-current-time-string) (string-chomp (time->string (seconds->local-time (current-seconds))))) @@ -108,10 +116,11 @@ (define (filedb:register-path fdb path #!key (save-stat #f)) (let* ((db (filedb:fdb-get-db fdb)) (pathcache (filedb:fdb-get-pathcache fdb)) (stat (if save-stat (file-stat path #t))) (id (hash-table-ref/default pathcache path #f))) + (if (not db)(filedb:reopen-db fdb)) (if id id (let ((plist (string-split path "/"))) (let loop ((head (car plist)) (tail (cdr plist)) (parent 0)) @@ -214,10 +223,11 @@ (define (filedb:get-path fdb id) (let* ((db (filedb:fdb-get-db fdb)) (idcache (filedb:fdb-get-idcache fdb)) (path (hash-table-ref/default idcache id #f))) + (if (not db)(filedb:reopen-db fdb)) (if path path (let loop ((curr-id id) (path "")) (let ((path-record (filedb:get-path-record fdb curr-id))) (if (not path-record) #f ;; this id has no path Index: http-transport.scm ================================================================== --- http-transport.scm +++ http-transport.scm @@ -181,10 +181,13 @@ ;;====================================================================== ;; C L I E N T S ;;====================================================================== (define *http-mutex* (make-mutex)) + +;; NOTE: Large block of code from 32436b426188080f72fceb6894af541fbad9921e removed here +;; I'm pretty sure it is defunct. ;; This next block all imported en-mass from the api branch (define *http-requests-in-progress* 0) (define *http-connections-next-cleanup* (current-seconds)) @@ -426,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)) @@ -471,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 " @@ -514,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: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -19,11 +19,13 @@ (declare (unit launch)) (declare (uses common)) (declare (uses configf)) (declare (uses db)) +(declare (uses sdb)) (declare (uses tdb)) +(declare (uses filedb)) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") @@ -497,10 +499,11 @@ (lnkbase (conc linktree "/" target "/" runname)) (lnkpath (conc lnkbase "/" testname)) (lnkpathf (conc lnkpath (if not-iterated "" "/") item-path))) ;; Update the rundir path in the test record for all + ;; (cdb:test-set-rundir-by-test-id *runremote* test-id (filedb:register-path *fdb* lnkpathf)) (rmt:general-call 'test-set-rundir-by-test-id lnkpathf test-id) (debug:print 2 "INFO:\n lnkbase=" lnkbase "\n lnkpath=" lnkpath "\n toptest-path=" toptest-path "\n test-path=" test-path) (if (not (file-exists? linktree)) (begin @@ -518,13 +521,14 @@ ;; NB - This is not working right - some top tests are not getting the path set!!! (if (not (hash-table-ref/default *toptest-paths* testname #f)) (let* ((testinfo (rmt:get-test-info-by-id test-id)) ;; run-id testname item-path)) - (curr-test-path (if testinfo (db:test-get-rundir testinfo) #f))) + (curr-test-path (if testinfo (filedb:get-path *fdb* (db:test-get-rundir testinfo)) #f))) (hash-table-set! *toptest-paths* testname curr-test-path) ;; NB// Was this for the test or for the parent in an iterated test? + ;;(cdb:test-set-rundir! *runremote* run-id testname "" (filedb:register-path *fdb* lnkpath)) ;; toptest-path) (rmt:general-call 'test-set-rundir lnkpath run-id testname "") ;; toptest-path) (if (or (not curr-test-path) (not (directory-exists? toptest-path))) (begin (debug:print-info 2 "Creating " toptest-path " and link " lnkpath) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -25,10 +25,12 @@ (declare (uses client)) (declare (uses tests)) (declare (uses genexample)) (declare (uses daemon)) (declare (uses db)) +(declare (uses sdb)) +(declare (uses filedb)) (declare (uses tdb)) (declare (uses mt)) (declare (uses api)) (define *db* #f) ;; this is only for the repl, do not use in general!!!! @@ -239,10 +241,13 @@ "-rollup" "-update-meta" "-gen-megatest-area" "-mark-incompletes" + "-convert-to-norm" + "-convert-to-old" + "-logging" "-v" ;; verbose 2, more than normal (normal is 1) "-q" ;; quiet 0, errors/warnings only ) args:arg-hash @@ -379,36 +384,13 @@ ((http) (set! *transport-type 'http) (server:ensure-running) (client:launch)) (else ;; (fs) + (debug:print 0 "ERROR: Should NOT be getting here! fs transport is no longer supported") (set! *transport-type* 'fs) - (set! *megatest-db* (open-db)))))))))) -;; (cond -;; ;; command line overrides other mechanisms -;; (transport-from-cmdln -;; (if (equal? transport-from-cmdln "fs") -;; (set! *transport-type* 'fs) -;; (begin -;; (server:ensure-running) -;; (client:launch)))) -;; ;; cmdinfo is second priority -;; (transport-from-cmdinfo -;; (if (equal? transport-from-cmdinfo "fs") -;; (set! *transport-type* 'fs) -;; (begin -;; (server:ensure-running) -;; (client:launch)))) -;; ;; config file is next highest priority for determinining transport -;; (transport-from-config -;; (if (equal? transport-from-config "fs") -;; (set! *transport-type* 'fs) -;; (begin -;; (server:ensure-running) -;; (client:launch)))) -;; (else -;; (set! *transport-type* 'fs))))))))) + (set! *megatest-db* (make-dbr:dbstruct path: *toppath* local: #t)))))))))) (if (or (args:get-arg "-list-servers") (args:get-arg "-stop-server")) (let ((tl (setup-for-run))) (if tl @@ -430,11 +412,11 @@ (pubport (vector-ref server 5)) (start-time (vector-ref server 6)) (priority (vector-ref server 7)) (state (vector-ref server 8)) (mt-ver (vector-ref server 9)) - (last-update (vector-ref server 10)) ;; (open-run-close tasks:server-alive? tasks:open-db #f hostname: hostname port: port)) + (last-update (vector-ref server 10)) (transport (vector-ref server 11)) (killed #f) (status (< last-update 20))) ;; (zmq-sockets (if status (server:client-connect hostname port) #f))) ;; no need to login as status of #t indicates we are connecting to correct @@ -579,19 +561,19 @@ ;; NOTE: list-runs and list-db-targets operate on local db!!! ;; (if (or (args:get-arg "-list-runs") (args:get-arg "-list-db-targets")) (if (setup-for-run) - (let* ((db (open-db)) + (let* ((dbstruct (make-dbr:dbstruct path: *toppath* local: #t)) (runpatt (args:get-arg "-list-runs")) (testpatt (if (args:get-arg "-testpatt") (args:get-arg "-testpatt") "%")) - (runsdat (db:get-runs db runpatt #f #f '())) + (runsdat (db:get-runs dbstruct runpatt #f #f '())) (runs (db:get-rows runsdat)) (header (db:get-header runsdat)) - (keys (db:get-keys db)) + (keys (db:get-keys dbstruct)) (db-targets (args:get-arg "-list-db-targets")) (seen (make-hash-table))) ;; Each run (for-each (lambda (run) @@ -604,11 +586,11 @@ (hash-table-set! seen targetstr #t) ;; (print "[" targetstr "]")))) (print targetstr)))) (if (not db-targets) (let* ((run-id (db:get-value-by-header run header "id")) - (tests (db:get-tests-for-run db run-id testpatt '() '() #f #f #f 'testname 'asc #f))) + (tests (db:get-tests-for-run dbstruct run-id testpatt '() '() #f #f #f 'testname 'asc #f))) (print "Run: " targetstr "/" (db:get-value-by-header run header "runname") " status: " (db:get-value-by-header run header "state") " run-id: " run-id ", number tests: " (length tests)) (for-each (lambda (test) @@ -627,16 +609,16 @@ (equal? (db:test-get-status test) "WARN") (equal? (db:test-get-state test) "NOT_STARTED"))) (begin (print " cpuload: " (db:test-get-cpuload test) "\n diskfree: " (db:test-get-diskfree test) - "\n uname: " (db:test-get-uname test) - "\n rundir: " (db:test-get-rundir test) + "\n uname: " (sdb:qry 'getstr (db:test-get-uname test)) + "\n rundir: " (filedb:get-path *fdb* (db:test-get-rundir test)) ) ;; Each test ;; DO NOT remote run - (let ((steps (db:get-steps-for-test db (db:test-get-id test)))) + (let ((steps (db:get-steps-for-test dbstruct run-id (db:test-get-id test)))) (for-each (lambda (step) (format #t " Step: ~20a State: ~10a Status: ~10a Time ~22a\n" (tdb:step-get-stepname step) @@ -644,11 +626,12 @@ (tdb:step-get-status step) (tdb:step-get-event_time step))) steps))))) tests))))) runs) - (set! *didsomething* #t)))) + (db:close-all dbstruct) + (set! *didsomething* #t)))) ;;====================================================================== ;; full run ;;====================================================================== @@ -804,11 +787,11 @@ (test-name (assoc/default 'test-name cmdinfo)) (runscript (assoc/default 'runscript cmdinfo)) (db-host (assoc/default 'db-host cmdinfo)) (run-id (assoc/default 'run-id cmdinfo)) (itemdat (assoc/default 'itemdat cmdinfo)) - (db (open-db)) + ;; (db (make-dbr:dbstruct path: *)) (state (args:get-arg ":state")) (status (args:get-arg ":status")) (target (args:get-arg "-target"))) (change-directory testpath) ;; (set! *runremote* runremote) @@ -821,28 +804,29 @@ (begin (debug:print 0 "Failed to setup, giving up on -archive, exiting") (exit 1))) (let* ((keys (db:get-keys db)) ;; DO NOT run remote - (paths (db:test-get-paths-matching db keys target))) + (paths (rmt:test-get-paths-matching keys target))) (set! *didsomething* #t) (for-each (lambda (path) (print path)) paths)) - (if (sqlite3:database? db)(sqlite3:finalize! db))) + ;; (if (sqlite3:database? db)(sqlite3:finalize! db)) + ) ;; else do a general-run-call (general-run-call "-test-paths" "Get paths to tests" (lambda (target runname keys keyvals) - (let* ((db (open-db)) + (let* ((dbstruct (make-dbr:dbstruct path: *toppath* local: #t)) ;; DO NOT run remote - (paths (db:test-get-paths-matching db keys target))) + (paths (db:test-get-paths-matching dbstruct keys target))) (for-each (lambda (path) (print path)) paths) - (sqlite3:finalize! db)))))) + (db:close-all dbstruct)))))) ;;====================================================================== ;; Extract a spreadsheet from the runs database ;;====================================================================== @@ -849,18 +833,18 @@ (if (args:get-arg "-extract-ods") (general-run-call "-extract-ods" "Make ods spreadsheet" (lambda (target runname keys keyvals) - (let ((db (open-db)) + (let ((dbstruct (make-dbr:dbstruct path: *toppath* local: #t)) (outputfile (args:get-arg "-extract-ods")) (runspatt (args:get-arg ":runname")) (pathmod (args:get-arg "-pathmod"))) ;; (keyvalalist (keys->alist keys "%"))) (debug:print 2 "Extract ods, outputfile: " outputfile " runspatt: " runspatt " keyvals: " keyvals) - (db:extract-ods-file db outputfile keyvals (if runspatt runspatt "%") pathmod) - (sqlite3:finalize! db) + (db:extract-ods-file dbstruct outputfile keyvals (if runspatt runspatt "%") pathmod) + (db:close-all dbstruct) (set! *didsomething* #t))))) ;;====================================================================== ;; execute the test ;; - gets called on remote host @@ -964,10 +948,11 @@ ;; has sub commands that are rdb: ;; DO NOT put this one into either cdb:remote-run or open-run-close (tdb:load-test-data test-id)) (if (args:get-arg "-setlog") (let ((logfname (args:get-arg "-setlog"))) + ;; (cdb:test-set-log! *runremote* test-id (sdb:qry 'getid logfname)))) (rmt:test-set-log! test-id logfname))) (if (args:get-arg "-set-toplog") ;; DO NOT run remote (tests:test-set-toplog! run-id test-name (args:get-arg "-set-toplog"))) (if (args:get-arg "-summarize-items") @@ -1009,10 +994,11 @@ (debug:print-info 2 "running \"" cmd "\"") (change-directory startingdir) (set! exitstat (system cmd)) (set! *globalexitstatus* exitstat) ;; no necessary (change-directory testpath) + ;; (cdb:test-set-log! *runremote* test-id (sdb:qry 'getid htmllogfile)))) (rmt:test-set-log! test-id htmllogfile))) (let ((msg (args:get-arg "-m"))) (rmt:teststep-set-status! test-id stepname "end" exitstat msg logfile)) ))) (if (or (args:get-arg "-test-status") @@ -1143,26 +1129,56 @@ ;;====================================================================== (if (or (args:get-arg "-repl") (args:get-arg "-load")) (let* ((toppath (setup-for-run)) - (db (if toppath (open-db) #f))) - (if db + (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t) #f))) + (if dbstruct (begin - (set! *db* db) + (set! *db* dbstruct) (set! *client-non-blocking-mode* #t) (import readline) (import apropos) + ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ... (gnu-history-install-file-manager (string-append (or (get-environment-variable "HOME") ".") "/.megatest_history")) (current-input-port (make-gnu-readline-port "megatest> ")) (if (args:get-arg "-repl") (repl) - (load (args:get-arg "-load")))) + (load (args:get-arg "-load"))) + (db:close-all dbstruct)) (exit)) (set! *didsomething* #t))) + +;; Not converted to use dbstruct yet +;; +(if (args:get-arg "-convert-to-norm") + (let* ((toppath (setup-for-run)) + (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t)))) + (for-each + (lambda (field) + (let ((dat '())) + (debug:print-info 0 "Getting data for field " field) + (sqlite3:for-each-row + (lambda (id val) + (set! dat (cons (list id val) dat))) + (get-db db run-id) + (conc "SELECT id," field " FROM tests;")) + (debug:print-info 0 "found " (length dat) " items for field " field) + (let ((qry (sqlite3:prepare db (conc "UPDATE tests SET " field "=? WHERE id=?;")))) + (for-each + (lambda (item) + (let ((newval (sdb:qry 'getid (cadr item)))) + (if (not (equal? newval (cadr item))) + (debug:print-info 0 "Converting " (cadr item) " to " newval " for test #" (car item))) + (sqlite3:execute qry newval (car item)))) + dat) + (sqlite3:finalize! qry)))) + (db:close-all dbstruct) + (list "uname" "rundir" "final_logf" "comment")) + (set! *didsomething* #t))) ;;====================================================================== ;; Exit and clean up ;;====================================================================== @@ -1171,10 +1187,13 @@ ;; this is the socket if we are a client ;; (if (and *runremote* ;; (socket? *runremote*)) ;; (close-socket *runremote*)) +(if sdb:qry (sdb:qry 'finalize #f)) +(if *fdb* (filedb:finalize-db! *fdb*)) + (if (not *didsomething*) (debug:print 0 help)) ;; (if *runremote* (rpc:close-all-connections!)) Index: mt.scm ================================================================== --- mt.scm +++ mt.scm @@ -18,10 +18,11 @@ (declare (uses runconfig)) (declare (uses tests)) (declare (uses server)) (declare (uses runs)) (declare (uses rmt)) +(declare (uses filedb)) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") @@ -96,13 +97,13 @@ result) (let ((newres (rmt:get-prereqs-not-met run-id waitons ref-item-path mode: mode))) (hash-table-set! *pre-reqs-met-cache* key (vector (current-seconds) newres)) newres)))) +(define (mt:get-run-stats dbstruct run-id) ;; Get run stats from local access, move this ... but where? -(define (mt:get-run-stats) - (db:get-run-stats #f)) + (db:get-run-stats dbstruct run-id)) (define (mt:discard-blocked-tests run-id failed-test tests test-records) (if (null? tests) tests (begin @@ -126,11 +127,11 @@ ;; T R I G G E R S ;;====================================================================== (define (mt:process-triggers test-id newstate newstatus) (let* ((test-dat (rmt:get-test-info-by-id test-id)) - (test-rundir (db:test-get-rundir test-dat)) + (test-rundir (filedb:get-path *fdb* (db:test-get-rundir test-dat))) (test-name (db:test-get-testname test-dat)) (tconfig #f) (state (if newstate newstate (db:test-get-state test-dat))) (status (if newstatus newstatus (db:test-get-status test-dat)))) (if (and (file-exists? test-rundir) Index: newdashboard.scm ================================================================== --- newdashboard.scm +++ newdashboard.scm @@ -568,13 +568,13 @@ (iup:attribute-set! tabtop "TABTITLE4" "runconfigs.config") tabtop))) (define *current-window-id* 0) -(define (newdashboard) +(define (newdashboard dbstruct) (let* ((data (make-hash-table)) - (keys (cdb:remote-run db:get-keys #f)) + (keys (db:get-keys dbstruct)) (runname "%") (testpatt "%") (keypatts (map (lambda (k)(list k "%")) keys)) (states '()) (statuses '()) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -19,10 +19,11 @@ (declare (uses items)) (declare (uses runconfig)) (declare (uses tests)) (declare (uses server)) (declare (uses mt)) +(declare (uses filedb)) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") @@ -57,15 +58,10 @@ (runconfig #f) (serverdat (if (args:get-arg "-server") *runremote* #f)) ;; to be used later (transport (or (args:get-arg "-transport") 'http)) - (db (if (and mconfig - (or (args:get-arg "-server") - (eq? transport 'fs))) - (open-db) - #f)) (run-id #f)) ;; Set all the environment vars we know so far, start with keys (for-each (lambda (keyval) (setenv (car keyval)(cadr keyval))) keyvals) @@ -213,13 +209,10 @@ (test-records (make-hash-table)) (all-tests-registry (tests:get-all)) ;; (tests:get-valid-tests (make-hash-table) test-search-path)) ;; all valid tests to check waiton names (all-test-names (hash-table-keys all-tests-registry)) (test-names (tests:filter-test-names all-test-names test-patts))) - ;; Update the synchronous setting in the db based on the default or what is set by the user - ;; This is done once here on a call to run tests rather than on every call to open-db - (set-megatest-env-vars run-id inkeys: keys inrunname: runname) ;; these may be needed by the launching process (if (file-exists? runconfigf) (setup-env-defaults runconfigf run-id *already-seen-runconfig-info* keyvals "pre-launch-env-vars") (debug:print 0 "WARNING: You do not have a run config file: " runconfigf)) @@ -1257,12 +1250,12 @@ action) ((run-wait) (debug:print 1 "Waiting for run " runkey ", run=" runnamepatt " to complete")) (else (debug:print-info 0 "action not recognised " action))) - (let ((sorted-tests (sort tests (lambda (a b)(let ((dira (db:test-get-rundir a)) - (dirb (db:test-get-rundir b))) + (let ((sorted-tests (sort tests (lambda (a b)(let ((dira (filedb:get-path *fdb* (db:test-get-rundir a))) + (dirb (filedb:get-path *fdb* (db:test-get-rundir b)))) (if (and (string? dira)(string? dirb)) (> (string-length dira)(string-length dirb)) #f))))) (test-retry-time (make-hash-table)) (allow-run-time 10)) ;; seconds to allow for killing tests before just brutally killing 'em @@ -1275,11 +1268,11 @@ (debug:print 0 "ERROR: We have a test-id of " test-id " but no record was found. NOTE: No locking of records is done between processes, do not simultaneously remove the same run from two processes!") (if (not (null? tal)) (loop (car tal)(cdr tal)))) (let* ((item-path (db:test-get-item-path new-test-dat)) (test-name (db:test-get-testname new-test-dat)) - (run-dir (db:test-get-rundir new-test-dat)) ;; run dir is from the link tree + (run-dir (filedb:get-path *fdb* (db:test-get-rundir new-test-dat))) ;; run dir is from the link tree (real-dir (if (file-exists? run-dir) (resolve-pathname run-dir) #f)) (test-state (db:test-get-state new-test-dat)) (test-fulln (db:test-get-fullname new-test-dat))) Index: sdb.scm ================================================================== --- sdb.scm +++ sdb.scm @@ -20,27 +20,25 @@ (import (prefix base64 base64:)) (declare (unit sdb)) ;; -(define (sdb:open) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) +(define (sdb:open #!key (fname #f)) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) (if (not *toppath*) (if (not (setup-for-run)) (begin (debug:print 0 "ERROR: Attempted to open db when not in megatest area. Exiting.") (exit)))) - (let* ((dbpath (conc *toppath* "/db/sdb.db")) ;; fname) + (let* ((dbpath (conc *toppath* "/db/" (if fname fname "sdb.db"))) ;; fname) (dbexists (let ((fe (file-exists? dbpath))) (if fe fe (begin (create-directory (conc *toppath* "/db") #t) #f)))) (sdb (sqlite3:open-database dbpath)) - (handler (make-busy-timeout (if (args:get-arg "-override-timeout") - (string->number (args:get-arg "-override-timeout")) - 136000)))) + (handler (make-busy-timeout 136000))) (sqlite3:set-busy-handler! sdb handler) (if (not dbexists) (sdb:initialize sdb)) (sqlite3:execute sdb "PRAGMA synchronous = 1;") sdb)) @@ -77,20 +75,27 @@ (hash-table-set! id-cache id str)) sdb "SELECT str FROM strs WHERE id=?;" id)) str)) -(define sdb:qry - (let ((sdb #f) +;; Numbers get passed though in both directions +;; +(define (make-sdb:qry #!key (fname #f)) + (let ((sdb #f) ;; (sdb:open fname: fname)) (scache (make-hash-table)) (icache (make-hash-table))) (lambda (cmd var) - (if (not sdb)(set! sdb (sdb:open))) + (if (not sdb)(set! sdb (sdb:open fname: fname))) (case cmd - ((init) (if (not sdb)(set! sdb (sdb:open)))) - ((finalize!) (if sdb (sqlite3:finalize! sdb))) - ((getid) (let ((id (sdb:string->id sdb scache var))) + ((finalize) (if sdb + (begin + (sqlite3:finalize! sdb) + (set! sdb #f)))) + ((getid) (let ((id (if (or (number? var) + (string->number var)) + var + (sdb:string->id sdb scache var)))) (if id id (begin (sdb:register-string sdb var) (sdb:string->id sdb scache var))))) 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)))) ;;====================================================================== Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -21,10 +21,11 @@ (declare (uses db)) (declare (uses tdb)) (declare (uses common)) (declare (uses items)) (declare (uses runconfig)) +(declare (uses sdb)) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") @@ -133,12 +134,12 @@ ;; Check for waiver eligibility ;; (define (tests:check-waiver-eligibility testdat prev-testdat) (let* ((test-registry (make-hash-table)) (testconfig (tests:get-testconfig (db:test-get-testname testdat) test-registry #f)) - (test-rundir (db:test-get-rundir testdat)) - (prev-rundir (db:test-get-rundir prev-testdat)) + (test-rundir (sdb:qry 'getstr (db:test-get-rundir testdat))) + (prev-rundir (sdb:qry 'getstr (db:test-get-rundir prev-testdat))) (waivers (configf:section-vars testconfig "waivers")) (waiver-rx (regexp "^(\\S+)\\s+(.*)$")) (diff-rule "diff %file1% %file2%") (logpro-rule "diff %file1% %file2% | logpro %waivername%.logpro %waivername%.html")) (if (not (file-exists? test-rundir)) Index: tests/rununittest.sh ================================================================== --- tests/rununittest.sh +++ tests/rununittest.sh @@ -1,10 +1,13 @@ #!/bin/bash # Usage: rununittest.sh testname debuglevel # +# Ensure all is made +(cd ..;make && make install) + # Clean setup # rm -f simplerun/megatest.db simplerun/monitor.db simplerun/db/monitor.db rm -rf simplelinks/ simpleruns/ mkdir -p simplelinks simpleruns ADDED tests/unittests/basicserver.scm Index: tests/unittests/basicserver.scm ================================================================== --- /dev/null +++ tests/unittests/basicserver.scm @@ -0,0 +1,114 @@ +;;====================================================================== +;; S E R V E R +;;====================================================================== + +;; Run like this: +;; +;; (cd ..;make && make install) && ./rununittest.sh server 1;(cd simplerun;megatest -stop-server 0) + +(set! *transport-type* 'http) + +(test "setup for run" #t (begin (setup-for-run) + (string? (getenv "MT_RUN_AREA_HOME")))) + +(test "server-register, get-best-server" #t (let ((res #f)) + (open-run-close tasks:server-register tasks:open-db 1 "bob" 1234 100 'live 'http) + (set! res (open-run-close tasks:get-best-server tasks:open-db)) + (number? (vector-ref res 3)))) + +(test "de-register server" #f (let ((res #f)) + (open-run-close tasks:server-deregister tasks:open-db "bob" port: 1234) + (vector? (open-run-close tasks:get-best-server tasks:open-db)))) + +(define server-pid #f) + +;; Not sure how the following should work, replacing it with system of megatest -server +;; (test "launch server" #t (let ((pid (process-fork (lambda () +;; ;; (daemon:ize) +;; (server:launch 'http))))) +;; (set! server-pid pid) +;; (number? pid))) +(system "../../bin/megatest -server - -debug 22 > server.log 2> server.log &") + +(let loop ((n 10)) + (thread-sleep! 1) ;; need to wait for server to start. + (let ((res (open-run-close tasks:get-best-server tasks:open-db))) + (print "tasks:get-best-server returned " res) + (if (and (not res) + (> n 0)) + (loop (- n 1))))) + +(test "get-best-server" #t (begin + (client:launch) + (let ((dat (open-run-close tasks:get-best-server tasks:open-db))) + (vector? dat)))) + +(define *keys* (keys:config-get-fields *configdat*)) +(define *keyvals* (keys:target->keyval *keys* "a/b/c")) + +(test #f #t (string? (car *runremote*))) +(test #f '(#t "successful login") (rmt:login)) ;; *runremote* *toppath* *my-client-signature*))) + +(test #f #f (rmt:get-test-info-by-id 99)) ;; get non-existant test + +;; RUNS +(test #f 1 (rmt:register-run *keyvals* "firstrun" "new" "n/a" (current-user-name))) +(test "get run info" "firstrun" (let ((rinfo (rmt:get-run-info 1))) + (vector-ref (vector-ref rinfo 1) 3))) +(test "get runname from id" "firstrun" (rmt:get-run-name-from-id 1)) + +;; TESTS +(test "get tests (no data)" '() (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f)) +(test "register test" #t (rmt:general-call 'register-test 1 "test1" "")) +(test "get tests (some data)" 1 (length (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f))) +(test "get test id" 1 (rmt:get-test-id 1 "test1" "")) +(test "sync back" #t (> (rmt:sync-inmem->db) 0)) +(test "get test id from main" 1 (db:get-test-id *db* 1 "test1" "")) +(test "get keys" #t (list? (rmt:get-keys))) +(test "set comment" #t (begin (rmt:general-call 'set-test-comment "this is a comment" 1) #t)) +(test "get comment" "this is a comment" (let ((trec (rmt:get-test-info-by-id 1))) + (db:test-get-comment trec))) + +;; MORE RUNS +(test "get runs" #t (let* ((runs (rmt:get-runs "%" #f #f '())) + (header (vector-ref runs 0)) + (data (vector-ref runs 1))) + (and (list? header) + (list? data) + (vector? (car data))))) + +(test "get local testinfo" "test1" (vector-ref (db:get-testinfo-state-status *db* 1) 2)) +(test "get testinfo" "test1" (vector-ref (rmt:get-testinfo-state-status 1) 2)) + +;;====================================================================== +;; D B +;;====================================================================== + +(test "pass fail counts" #t (rmt:general-call 'pass-fail-counts 10 9 1)) +(test "get pass fail counts" 19 (let ((dat (rmt:get-test-info-by-id 1))) + (+ (db:test-get-pass_count dat) + (db:test-get-fail_count dat)))) + +(define testregistry (make-hash-table)) +(for-each + (lambda (tname) + (for-each + (lambda (itempath) + (let ((tkey (conc tname "/" itempath)) + (rpass (random 10)) + (rfail (random 10))) + (hash-table-set! testregistry tkey (list tname itempath)) + (rmt:general-call 'register-test 1 tname itempath) + (let* ((tid (rmt:get-test-id 1 tname itempath)) + (tdat (rmt:get-test-info-by-id tid))) + (rmt:general-call 'pass-fail-counts rpass rfail (db:test-get-id tdat)) + (let* ((resdat (rmt:get-test-info-by-id tid))) + (test "set/get pass fail counts" (list rpass rfail) + (list (db:test-get-pass_count resdat) + (db:test-get-fail_count resdat))))))) + (list "" "a" "b" "c" "d" "e" "f" "g" "h" "i" "j"))) + (list "test1" "test2" "test3" "test4" "test5")) + + +(test #f '(#t "exit process started") (rmt:kill-server)) ;; *toppath* *my-client-signature* #f))) + Index: zmq-transport.scm ================================================================== --- zmq-transport.scm +++ zmq-transport.scm @@ -1,14 +1,15 @@ - +;;====================================================================== ;; Copyright 2006-2012, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. +;;====================================================================== (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:))