Index: dbmod.scm ================================================================== --- dbmod.scm +++ dbmod.scm @@ -145,50 +145,50 @@ (defstruct dbr:counts (state #f) (status #f) (count 0)) -;; Retrieve a dbdat given run-id, open and setup both inmemory and +;; Retrieve a dbdat given dbfile, open and setup both inmemory and ;; db file if needed ;; ;; 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-dbdat dbstruct apath run-id) - (let ((dbdat (dbr:dbstruct-get-dbdat dbstruct run-id))) +(define (db:get-dbdat dbstruct apath dbfile) + (let ((dbdat (dbr:dbstruct-get-dbdat dbstruct dbfile))) ;; run-id))) (if dbdat dbdat - (let* ((dbfile (db:run-id->path apath run-id)) - (newdbdat (db:open-dbdat apath run-id db:initialize-db))) - (dbr:dbstruct-dbdat-put! dbstruct run-id newdbdat) + (let* (;; (dbfile (db:run-id->path apath run-id)) + (newdbdat (db:open-dbdat apath dbfile db:initialize-db))) + (dbr:dbstruct-dbdat-put! dbstruct dbfile newdbdat) newdbdat)))) ;; get the inmem db for actual db operations ;; -(define (db:get-inmem dbstruct run-id) - (dbr:dbdat-inmem (db:get-dbdat dbstruct run-id))) +(define (db:get-inmem dbstruct dbfile) + (dbr:dbdat-inmem (db:get-dbdat dbstruct dbfile))) ;; get the handle for the on-disk db ;; -(define (db:get-ddb dbstruct apath run-id) - (dbr:dbdat-db (db:get-dbdat dbstruct apath run-id))) +(define (db:get-ddb dbstruct apath dbfile) + (dbr:dbdat-db (db:get-dbdat dbstruct apath dbfile))) ;; open or create the disk db file ;; create and fill the inmemory db ;; assemble into dbr:dbdat struct and return ;; -(define (db:open-dbdat apath run-id dbinit-proc) - (let* ((dbfile (db:run-id->path apath run-id)) +(define (db:open-dbdat apath dbfile dbinit-proc) + (let* (;; (dbfile (db:run-id->path apath run-id)) (db (db:open-run-db dbfile dbinit-proc)) (inmem (db:open-inmem-db dbinit-proc)) (dbdat (make-dbr:dbdat db: db inmem: inmem - run-id: run-id + ;; run-id: run-id ;; no can do, there are many run-id values that point to single db fname: dbfile))) ;; now sync the disk file data into the inmemory db (db:sync-tables (db:sync-all-tables-list) #f db inmem) dbdat)) @@ -392,18 +392,18 @@ ;; ;; (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb))) ;; NOTE: touched logic is disabled/not done ;; sync run to disk if touched ;; -(define (db:sync-inmem->disk dbstruct run-id #!key (force-sync #f)) - (let* ((dbdat (db:get-dbdat dbstruct run-id)) +(define (db:sync-inmem->disk dbstruct dbfile #!key (force-sync #f)) + (let* ((dbdat (db:get-dbdat dbstruct dbfile)) (db (dbr:dbdat-db dbstruct)) (inmem (dbr:dbdat-inmem dbstruct)) (start-t (current-seconds)) (last-update (dbr:dbdat-last-write dbdat)) (last-sync (dbr:dbdat-last-sync dbdat))) - (debug:print-info 4 *default-log-port* "Syncing for run-id: " run-id) + (debug:print-info 4 *default-log-port* "Syncing for dbfile: " dbfile) (mutex-lock! *db-multi-sync-mutex*) (let* ((update_info (cons (if force-sync 0 last-update) "last_update")) (need-sync (or force-sync (>= last-update last-sync)))) (mutex-unlock! *db-multi-sync-mutex*) (if need-sync Index: http-transportmod.scm ================================================================== --- http-transportmod.scm +++ http-transportmod.scm @@ -567,22 +567,24 @@ ;;====================================================================== ;; run http-transport:keep-running in a parallel thread to monitor that the db is being ;; used and to shutdown after sometime if it is not. ;; -(define (http-transport:keep-running) +(define (http-transport:keep-running dbname) ;; if none running or if > 20 seconds since ;; server last used then start shutdown ;; This thread waits for the server to come alive (debug:print-info 0 *default-log-port* "Starting the sync-back, keep alive thread in server") - (let* ((run-id (let ((rid (args:get-arg "-run-id"))) + (let* ((run-id (let ((rid (args:get-arg "-run-id"))) ;; consider getting rid of the -run-id mechanism (if rid (string->number rid) #f))) - (db-file (db:run-id->path *toppath* run-id)) + (db-file (if dbname + (db:dbname->path *toppath* dbname) + (db:run-id->path *toppath* run-id))) (sdat #f) - (tmp-area (common:get-db-tmp-area)) + ;; (tmp-area (common:get-db-tmp-area)) (server-start-time (current-seconds)) (pkts-dir (get-pkts-dir)) (server-key (server:mk-signature)) (server-info (let loop ((start-time (current-seconds)) (changed #t) @@ -597,10 +599,11 @@ (not changed) (> (- (current-seconds) start-time) 2)) (begin (debug:print-info 0 *default-log-port* "Received server alive signature, now attempting to lock in server") ;; create a server pkt in *toppath*/.meta/srvpkts + (register-server pkts-dir *srvpktspec* (get-host-name) (cadr sdat) server-key (car sdat) db-file) ;; now read pkts and see if we are a contender (let* ((all-pkts (get-all-server-pkts pkts-dir *srvpktspec*)) @@ -643,11 +646,13 @@ (start-time (current-milliseconds))) ;; Use this opportunity to sync the tmp db to megatest.db (if (not *dbstruct-db* ) (let ((watchdog (bdat-watchdog *bdat*))) (debug:print 0 *default-log-port* "SERVER: dbprep") - (db:setup run-id) ;; sets *dbstruct-db* as side effect + + (db:setup dbname) ;; sets *dbstruct-db* as side effect + (debug:print 0 *default-log-port* "SERVER: running, megatest version: " (common:get-full-version)) ;; NOTE: the server is NOT yet marked as running in the log. We do that in the keep-running routine. (if watchdog (if (not (member (thread-state watchdog) '(ready running blocked sleeping dead))) (begin (debug:print-info 0 "Starting watchdog thread (in state "(thread-state watchdog)")") @@ -756,28 +761,28 @@ ;; all routes though here end in exit ... ;; ;; start_server? ;; -(define (http-transport:launch) - (let* ((tmp-area (common:get-db-tmp-area)) - (server-start (conc tmp-area "/.server-start")) - (server-started (conc tmp-area "/.server-started")) - (start-time (common:lazy-modification-time server-start)) - (started-time (common:lazy-modification-time server-started)) - (server-starting (< start-time started-time)) ;; if start-time is less than started-time then a server is still starting - (start-time-old (> (- (current-seconds) start-time) 5)) +(define (http-transport:launch dbname) + (let* (;; (tmp-area (common:get-db-tmp-area)) + ;; (server-start (conc tmp-area "/.server-start")) + ;; (server-started (conc tmp-area "/.server-started")) + ;; (start-time (common:lazy-modification-time server-start)) + ;; (started-time (common:lazy-modification-time server-started)) + ;; (server-starting (< start-time started-time)) ;; if start-time is less than started-time then a server is still starting + ;; (start-time-old (> (- (current-seconds) start-time) 5)) (cleanup-proc (lambda (msg) (let* ((serv-fname (conc "server-" (current-process-id) "-" (get-host-name) ".log")) (full-serv-fname (conc *toppath* "/logs/" serv-fname)) (new-serv-fname (conc *toppath* "/logs/" "defunct-" serv-fname))) (debug:print 0 *default-log-port* msg) (if (common:file-exists? full-serv-fname) (system (conc "sleep 1;mv -f " full-serv-fname " " new-serv-fname)) (debug:print 0 *default-log-port* "INFO: cannot move " full-serv-fname " to " new-serv-fname)) (exit))))) - (common:save-pkt `((action . start) + #;(common:save-pkt `((action . start) (T . server) (pid . ,(current-process-id))) *configdat* #t) (let* ((th2 (make-thread (lambda () (debug:print-info 0 *default-log-port* "Server run thread started") @@ -786,11 +791,11 @@ (args:get-arg "-server") "-") )) "Server run")) (th3 (make-thread (lambda () (debug:print-info 0 *default-log-port* "Server monitor thread started") - (http-transport:keep-running) + (http-transport:keep-running dbname) "Keep running")))) (thread-start! th2) (thread-sleep! 0.252) ;; give the server time to settle before starting the keep-running monitor. (thread-start! th3) (set! *didsomething* #t) @@ -856,12 +861,12 @@ ;; all routes though here end in exit ... ;; ;; start_server ;; -(define (server:launch run-id transport-type) - (http-transport:launch)) +(define (server:launch dbname) + (http-transport:launch dbname)) ;;====================================================================== ;; S E R V E R U T I L I T I E S ;;====================================================================== Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -580,15 +580,15 @@ ":state" "-state" ":status" "-status" "-list-runs" - "-testdata-csv" + "-testdata-csv" "-testpatt" - "--modepatt" - "-modepatt" - "-tagexpr" + "--modepatt" + "-modepatt" + "-tagexpr" "-itempatt" "-setlog" "-set-toplog" "-runstep" "-logpro" @@ -597,12 +597,12 @@ "-days" "-rename-run" "-to" "-dest" - "-source" - "-time-stamp" + "-source" + "-time-stamp" ;; values and messages ":category" ":variable" ":value" ":expected" @@ -609,17 +609,18 @@ ":tol" ":units" ;; misc "-start-dir" - "-run-patt" - "-target-patt" + "-run-patt" + "-target-patt" "-contour" - "-area-tag" - "-area" + "-area-tag" + "-area" "-run-tag" "-server" + "-db" ;; file name for setting up a server "-adjutant" "-transport" "-port" "-extract-ods" "-pathmod" @@ -626,13 +627,13 @@ "-env2file" "-envcap" "-envdelta" "-setvars" "-set-state-status" - - ;; move runs stuff here - "-remove-keep" + + ;; move runs stuff here + "-remove-keep" "-set-run-status" "-age" ;; archive "-archive" @@ -654,26 +655,26 @@ "-run-id" "-ping" "-refdb2dat" "-o" "-log" - "-sync-log" + "-sync-log" "-since" "-fields" "-recover-test" ;; run-id,test-id - used internally to recover a test stuck in RUNNING state "-sort" "-target-db" "-source-db" "-prefix-target" - "-src-target" - "-src-runname" - "-diff-email" + "-src-target" + "-src-runname" + "-diff-email" "-sync-to" "-pgsync" "-kill-wait" ;; wait this long before removing test (default is 10 sec) - "-diff-html" + "-diff-html" ;; wizards, area capture, setup new ... "-extract-skeleton" ) (list "-h" "-help" "--help" @@ -704,11 +705,11 @@ "-repl" "-lock" "-unlock" "-list-servers" "-kill-servers" - "-run-wait" ;; wait on a run to complete (i.e. no RUNNING) + "-run-wait" ;; wait on a run to complete (i.e. no RUNNING) "-one-pass" ;; "-local" ;; run some commands using local db access "-generate-html" "-generate-html-structure" "-list-run-time" @@ -1139,15 +1140,17 @@ ;;====================================================================== ;; Server? Start up here. ;; (if (args:get-arg "-server") - (let ((tl (launch:setup)) - (transport-type (string->symbol (or (args:get-arg "-transport") "http")))) - (server:launch 0 transport-type) - (set! *didsomething* #t))) - + (if (not (args:get-arg "-db")) + (debug:print 0 *default-log-port* "ERROR: -db required to start server") + (let ((tl (launch:setup)) + (dbname (args:get-arg "-db"))) ;; transport-type (string->symbol (or (args:get-arg "-transport") "http")))) + (server:launch dbname) + (set! *didsomething* #t)))) + ;; The adjutant is a bit different, it does NOT run (launch:setup) as it is not necessarily tied to ;; a specific Megatest area. Detail are being hashed out and this may change. ;; (if (args:get-arg "-adjutant") (begin