Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -124,10 +124,88 @@ (assert *toppath* "FATAL: db:setup called before launch:setup has been run.") (let* ((tmpdir (common:get-db-tmp-area))) (if (not *dbstruct-dbs*) (dbfile:setup do-sync *toppath* tmpdir) *dbstruct-dbs*))) + +(define (db:with-db dbstruct run-id r/w proc . params) + (case (rmt:transport-mode) + ((http)(dbfile:with-db dbstruct run-id r/w proc params)) + ((tcp) (dbmod:with-db dbstruct run-id r/w proc params)))) + +;; moved from dbfile +;; +;; ADD run-id SUPPORT +;; +(define (db:create-all-triggers dbstruct) + (db:with-db + dbstruct #f #f + (lambda (dbdat db) + (db:create-triggers db)))) + +(define (db:create-triggers db) + (for-each (lambda (key) + (sqlite3:execute db (cadr key))) + db:trigger-list)) + +(define (db:drop-all-triggers dbstruct) + (db:with-db + dbstruct #f #f + (lambda (dbdat db) + (db:drop-triggers db)))) + +(define (db:have-incompletes? dbstruct run-id ovr-deadtime) + (let* ((incompleted '()) + (oldlaunched '()) + (toplevels '()) + ;; (deadtime-str (configf:lookup *configdat* "setup" "deadtime")) + (deadtime (or ovr-deadtime 72000))) ;; twenty hours + (db:with-db + dbstruct run-id #f + (lambda (dbdat db) + + ;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes + ;; + ;; HOWEVER: this code in run:test seems to work fine + ;; (> (- (current-seconds)(+ (db:test-get-event_time testdat) + ;; (db:test-get-run_duration testdat))) + ;; 600) + ;; (db:delay-if-busy dbdat) + (sqlite3:for-each-row + (lambda (test-id run-dir uname testname item-path) + (if (and (equal? uname "n/a") + (equal? item-path "")) ;; this is a toplevel test + ;; what to do with toplevel? call rollup? + (begin + (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels))) + ;; (print-info "Found old toplevel test in RUNNING state, test-id=" test-id)) + (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted)))) + (db:get-cache-stmth dbdat db + "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('RUNNING','REMOTEHOSTSTART');") + run-id deadtime) + + ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config + ;; + ;; (db:delay-if-busy dbdat) + (sqlite3:for-each-row + (lambda (test-id run-dir uname testname item-path) + (if (and (equal? uname "n/a") + (equal? item-path "")) ;; this is a toplevel test + ;; what to do with toplevel? call rollup? + (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)) + (set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched)))) + (db:get-cache-stmth dbdat db + "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > 86400 AND state IN ('LAUNCHED');") + run-id) + + ;; (print-info "Found " (length oldlaunched) " old LAUNCHED items, " (length toplevels) " old LAUNCHED toplevel tests and " (length incompleted) " tests marked RUNNING but apparently dead.") + (if (and (null? incompleted) + (null? oldlaunched) + (null? toplevels)) + #f + #t))))) + ;; looks up subdb and returns it, if not found then set up ;; and then return it. ;; #;(define (db:get-db dbstruct run-id) Index: dbfile.scm ================================================================== --- dbfile.scm +++ dbfile.scm @@ -952,30 +952,10 @@ FOR EACH ROW BEGIN UPDATE test_data SET last_update=(strftime('%s','now')) WHERE id=old.id; END;" ))) -;; -;; ADD run-id SUPPORT -;; -(define (db:create-all-triggers dbstruct) - (db:with-db - dbstruct #f #f - (lambda (dbdat db) - (db:create-triggers db)))) - -(define (db:create-triggers db) - (for-each (lambda (key) - (sqlite3:execute db (cadr key))) - db:trigger-list)) - -(define (db:drop-all-triggers dbstruct) - (db:with-db - dbstruct #f #f - (lambda (dbdat db) - (db:drop-triggers db)))) - (define (db:is-trigger-dropped db tbl-name) (let* ((trigger-name (if (equal? tbl-name "test_steps") "update_teststeps_trigger" (conc "update_" tbl-name "_trigger"))) (res #f)) @@ -1018,14 +998,15 @@ ;; call with dbinit=db:initialize-main-db ;; (define (db:open-db dbstruct run-id dbinit) ;; (mutex-lock! *db-open-mutex*) - (let* ((dbdat (case (rmt:transport-mode) + (let* ((dbdat (dbfile:open-db dbstruct run-id dbinit))) + #;(case (rmt:transport-mode) ((http) (dbfile:open-db dbstruct run-id dbinit)) ((tcp) (dbmod:open-db dbstruct run-id dbinit)) - (else (assert #f "FATAL: rmt:transport-node not correct value"(rmt:transport-mode)))))) + (else (assert #f "FATAL: rmt:transport-node not correct value"(rmt:transport-mode)))) (set! *db-write-access* (not (dbr:dbdat-read-only dbdat))) ;; (mutex-unlock! *db-open-mutex*) dbdat)) (define dbfile:db-init-proc (make-parameter #f)) @@ -1088,11 +1069,11 @@ (define no-condition-db-with-db (make-parameter #t)) ;; (db:with-db dbstruct run-id sqlite3:exec "select blah fgrom blaz;") ;; r/w is a flag to indicate if the db is modified by this query #t = yes, #f = no ;; -(define (db:with-db dbstruct run-id r/w proc . params) +(define (dbfile:with-db dbstruct run-id r/w proc params) (assert dbstruct "FATAL: db:with-db called with dbstruct "#f) (assert (dbr:dbstruct? dbstruct) "FATAL: dbstruct is "dbstruct) (let* ((use-mutex (> *api-process-request-count* 25)) ;; risk of db corruption (have-struct (dbr:dbstruct? dbstruct)) (dbdat (if have-struct ;; this stuff just allows us to call with a db handle directly @@ -1278,58 +1259,8 @@ (let* ((newstmth (sqlite3:prepare db stmt))) ;; (db:hoh-set! stmt-cache db stmt newstmth) (hash-table-set! stmt-cache stmt newstmth) newstmth)))) -(define (db:have-incompletes? dbstruct run-id ovr-deadtime) - (let* ((incompleted '()) - (oldlaunched '()) - (toplevels '()) - ;; (deadtime-str (configf:lookup *configdat* "setup" "deadtime")) - (deadtime (or ovr-deadtime 72000))) ;; twenty hours - (db:with-db - dbstruct run-id #f - (lambda (dbdat db) - - ;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes - ;; - ;; HOWEVER: this code in run:test seems to work fine - ;; (> (- (current-seconds)(+ (db:test-get-event_time testdat) - ;; (db:test-get-run_duration testdat))) - ;; 600) - ;; (db:delay-if-busy dbdat) - (sqlite3:for-each-row - (lambda (test-id run-dir uname testname item-path) - (if (and (equal? uname "n/a") - (equal? item-path "")) ;; this is a toplevel test - ;; what to do with toplevel? call rollup? - (begin - (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels))) - ;; (print-info "Found old toplevel test in RUNNING state, test-id=" test-id)) - (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted)))) - (db:get-cache-stmth dbdat db - "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('RUNNING','REMOTEHOSTSTART');") - run-id deadtime) - - ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config - ;; - ;; (db:delay-if-busy dbdat) - (sqlite3:for-each-row - (lambda (test-id run-dir uname testname item-path) - (if (and (equal? uname "n/a") - (equal? item-path "")) ;; this is a toplevel test - ;; what to do with toplevel? call rollup? - (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)) - (set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched)))) - (db:get-cache-stmth dbdat db - "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > 86400 AND state IN ('LAUNCHED');") - run-id) - - ;; (print-info "Found " (length oldlaunched) " old LAUNCHED items, " (length toplevels) " old LAUNCHED toplevel tests and " (length incompleted) " tests marked RUNNING but apparently dead.") - (if (and (null? incompleted) - (null? oldlaunched) - (null? toplevels)) - #f - #t))))) ) Index: dbmod.scm ================================================================== --- dbmod.scm +++ dbmod.scm @@ -55,10 +55,16 @@ (conc (dbmod:get-dbdir dbstruct run-id)"/"(dbmod:run-id->dbfname run-id))) ;;====================================================================== ;; The inmem one-db file per server method goes in here ;;====================================================================== + +(define (dbmod:with-db dbstruct run-id r/w proc params) + (let* ((dbdat (dbmod:open-db dbstruct run-id (dbfile:db-init-proc))) + (dbh (dbr:dbdat-dbh dbdat)) + (dbfile (dbr:dbdat-dbfile dbdat))) + (apply proc dbdat dbh params))) (define (dbmod:open-inmem-db initproc) (let* ((db (sqlite3:open-database ":memory:")) (handler (sqlite3:make-busy-timeout 3600))) (sqlite3:set-busy-handler! db handler) @@ -67,11 +73,11 @@ (define (dbmod:open-db dbstruct run-id dbinit) (or (dbr:dbstruct-dbdat dbstruct) (let* ((dbdat (make-dbr:dbdat dbfile: (dbr:dbstruct-dbfile dbstruct) - dbh: (dbr:dbstruct-inmen dbstruct) + dbh: (dbr:dbstruct-inmem dbstruct) ))) (dbr:dbstruct-dbdat-set! dbstruct dbdat) dbdat))) ;; Open the inmem db and the on-disk db @@ -81,11 +87,11 @@ ;; Returns dbstruct ;; ;; * This routine creates the db if not found ;; * Probably can get rid of the dbstruct-in ;; -(define (db:open-dbmoddb areapath run-id init-proc #!key (dbstruct-in #f)) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) +(define (dbmod:open-dbmoddb areapath run-id init-proc #!key (dbstruct-in #f)) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) (let* ((dbstruct (or dbstruct-in (make-dbr:dbstruct areapath: areapath))) (dbfname (dbmod:run-id->dbfname run-id)) (dbpath (dbmod:get-dbdir dbstruct run-id)) ;; directory where all the .db files are kept (dbfullname (dbmod:run-id->full-dbfname dbstruct run-id)) (dbexists (file-exists? dbfullname)) @@ -107,7 +113,12 @@ (define (dbmod:close-db dbstruct) ;; do final sync to disk file ;; (do-sync ...) (sqlite3:finalize! (dbr:dbstruct-ondiskdb dbstruct))) + +;;====================================================================== +;; Moved from dbfile +;;====================================================================== + ) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -934,11 +934,11 @@ (case (rmt:transport-mode) ((http)(http-transport:launch)) ((tcp) (debug:print 0 *default-log-port* "INFO: Running using tcp method.") (if run-id - (tt:start-server tl (dbmod:run-id->dbfname run-id) api:dispatch-request) + (tt:start-server tl run-id (dbmod:run-id->dbfname run-id) api:dispatch-request) (begin (debug:print 0 *default-log-port* "ERROR: transport mode is tcp - -run-id is required.") (exit 1)))) (else (debug:print 0 *default-log-port* "ERROR: rmt:transport-mode value not recognised "(rmt:transport-mode)))) (set! *didsomething* #t))) Index: tcp-transportmod.scm ================================================================== --- tcp-transportmod.scm +++ tcp-transportmod.scm @@ -19,10 +19,12 @@ ;;====================================================================== (declare (unit tcp-transportmod)) (declare (uses debugprint)) (declare (uses commonmod)) +(declare (uses dbfile)) +(declare (uses dbmod)) (module tcp-transportmod * (import scheme @@ -51,10 +53,12 @@ tcp-server tcp commonmod debugprint + dbfile + dbmod ) ;;====================================================================== ;; client ;;====================================================================== @@ -137,17 +141,17 @@ ;; start the listener and start responding to requests ;; ;; NOTE: organise by dbfname, not run-id so we don't need ;; to pull in more modules ;; -(define (tt:start-server areapath dbfname handler) +(define (tt:start-server areapath run-id dbfname handler) ;; is there already a server for this dbfile? Then exit. (let* ((ttdat (make-tt areapath: areapath)) (servers (tt:find-server ttdat dbfname))) (tt-handler-set! ttdat handler) (if (null? servers) - (let* ((dbstruct (dbmod:open-dbmoddb areapath run-id (dbfile:db-init-db)))) + (let* ((dbstruct (dbmod:open-dbmoddb areapath run-id (dbfile:db-init-proc)))) (tt:start-tcp-server ttdat) ;; start the tcp-server which applies handler to incoming data (tt:keep-running ttdat dbfname handler)) (begin (debug:print 0 *default-log-port* "INFO: found server(s) already running for db "dbfname", "(string-intersperse servers ",")" Exiting.") (exit)))))