Index: dbmod.scm ================================================================== --- dbmod.scm +++ dbmod.scm @@ -228,14 +228,14 @@ ;; ;; called in http-transport and replicated in rmt.scm for *local* access. ;; (define (db:setup run-id) (assert *toppath* "FATAL: db:setup called before toppath is available.") - (let* ((dbstruct (make-dbr:dbstruct)) + (let* ((dbstruct (or *dbstruct-db* (make-dbr:dbstruct))) (db-file (db:run-id->path *toppath* run-id))) (db:get-dbdat dbstruct *toppath* db-file) - (set! *dbstruct-db* dbstruct) + (if (not *dbstruct-db*)(set! *dbstruct-db* dbstruct)) dbstruct)) ;;====================================================================== ;; setting/getting a lock on the db for only one server per db ;; @@ -413,30 +413,29 @@ ;; ;; (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 dbfile #!key (force-sync #f)) - (let* ((dbdat (db:get-dbdat dbstruct dbfile)) - (db (dbr:dbdat-db dbstruct)) - (inmem (dbr:dbdat-inmem dbstruct)) +(define (db:sync-inmem->disk dbstruct apath dbfile #!key (force-sync #f)) + (let* ((dbdat (db:get-dbdat dbstruct apath dbfile)) + (db (dbr:dbdat-db dbdat)) + (inmem (dbr:dbdat-inmem dbdat)) (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 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 + (if need-sync (db:sync-tables (db:sync-all-tables-list) update_info inmem db) (debug:print 0 *default-log-port* "Skipping sync as nothing touched."))) - (mutex-lock! *db-multi-sync-mutex*) (dbr:dbdat-last-sync-set! dbdat start-t) (mutex-unlock! *db-multi-sync-mutex*))) - +;; TODO: Add final sync to this +;; (define (db:safely-close-sqlite3-db db stmt-cache #!key (try-num 3)) (if (<= try-num 0) #f (handle-exceptions exn Index: launchmod.scm ================================================================== --- launchmod.scm +++ launchmod.scm @@ -2281,33 +2281,44 @@ ;;====================================================================== ;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage (define (common:watchdog) (debug:print-info 13 *default-log-port* "common:watchdog entered.") - #;(if (launch:setup) - (if (common:on-homehost?) - (let ((dbstruct (db:setup #t))) - (debug:print-info 13 *default-log-port* "after db:setup with dbstruct=" dbstruct) - (cond - ((dbr:dbstruct-read-only dbstruct) - (debug:print-info 13 *default-log-port* "loading read-only watchdog") - (common:readonly-watchdog dbstruct)) - (else - (debug:print-info 13 *default-log-port* "loading writable-watchdog.") - (let* ((syncer (or (configf:lookup *configdat* "server" "sync-method") "brute-force-sync"))) - (cond - ((equal? syncer "brute-force-sync") - (server:writable-watchdog-bruteforce dbstruct)) - ((equal? syncer "delta-sync") - (server:writable-watchdog-deltasync dbstruct)) - (else - (debug:print-error 0 *default-log-port* "Unknown server/sync-method specified ("syncer") - valid values are brute-force-sync and delta-sync.") - (exit 1))) - ;;(debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] Syncer started (method="syncer")") - ))) - (debug:print-info 13 *default-log-port* "watchdog done.")) - (debug:print-info 13 *default-log-port* "no need for watchdog on non-homehost")))) + (assert *toppath* "common:watchdog started before *toppath* is set") + (let* ((start-time (current-seconds)) + (am-server (args:get-arg "-server")) + (dbfile (args:get-arg "-db")) + (apath *toppath*)) + (let loop () + (thread-sleep! 5) ;; add control / setting for this + (if am-server + (if (not *dbstruct-db*) + (loop) + (db:sync-inmem->disk *dbstruct-db* *toppath* dbfile)))))) + +;; +;; (let ((dbstruct +;; (debug:print-info 13 *default-log-port* "after db:setup with dbstruct=" dbstruct) +;; (cond +;; ((dbr:dbstruct-read-only dbstruct) +;; (debug:print-info 13 *default-log-port* "loading read-only watchdog") +;; (common:readonly-watchdog dbstruct)) +;; (else +;; (debug:print-info 13 *default-log-port* "loading writable-watchdog.") +;; (let* ((syncer (or (configf:lookup *configdat* "server" "sync-method") "brute-force-sync"))) +;; (cond +;; ((equal? syncer "brute-force-sync") +;; (server:writable-watchdog-bruteforce dbstruct)) +;; ((equal? syncer "delta-sync") +;; (server:writable-watchdog-deltasync dbstruct)) +;; (else +;; (debug:print-error 0 *default-log-port* "Unknown server/sync-method specified ("syncer") - valid values are brute-force-sync and delta-sync.") +;; (exit 1))) +;; ;;(debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] Syncer started (method="syncer")") +;; ))) +;; (debug:print-info 13 *default-log-port* "watchdog done.")) +;; (debug:print-info 13 *default-log-port* "no need for watchdog on non-homehost")))) ;;====================================================================== ;; currently the primary job of the watchdog is to run the sync back to megatest.db from the db in /tmp ;; if we are on the homehost and we are a server (by definition we are on the homehost if we are a server) ;; @@ -2524,11 +2535,11 @@ ;; time to exit, close the no-sync db here (db:no-sync-close-db no-sync-db stmt-cache) (if (common:low-noise-print 30) (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " (bdat-time-to-exit *bdat*)" pid="(current-process-id) ))))))) ;;" this-wd-num="this-wd-num))))))) -(define (server:writable-watchdog-bruteforce dbstruct) +#;(define (server:writable-watchdog-bruteforce dbstruct) (thread-sleep! 1) ;; delay for startup (let* ((do-a-sync (server:get-bruteforce-syncer dbstruct)) (final-sync (server:get-bruteforce-syncer dbstruct fork-to-background: #t persist-until-sync: #t))) (when (and (not (args:get-arg "-sync-to-megatest.db")) ;; conditions under which we do not run the sync (args:get-arg "-server")) @@ -2545,11 +2556,11 @@ ))))) ;; moving this here as it needs access to db and cannot be in common. ;; -(define (server:get-bruteforce-syncer dbstruct #!key (fork-to-background #f) (persist-until-sync #f)) +#;(define (server:get-bruteforce-syncer dbstruct #!key (fork-to-background #f) (persist-until-sync #f)) (let* ((sqlite-exe (or (get-environment-variable "MT_SQLITE3_EXE"))) ;; defined in cfg.sh (sync-log (or (args:get-arg "-sync-log") (conc *toppath* "/logs/sync-" (current-process-id) "-" (get-host-name) ".log"))) (tmp-area (common:get-db-tmp-area)) (tmp-db (conc tmp-area "/megatest.db")) (staging-file (conc *toppath* "/.megatest.db")) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -743,11 +743,11 @@ "-convert-to-norm" "-convert-to-old" "-import-megatest.db" "-sync-to-megatest.db" - "-sync-brute-force" + "-sync-brute-force" "-logging" "-v" ;; verbose 2, more than normal (normal is 1) "-q" ;; quiet 0, errors/warnings only "-diff-rep" @@ -2581,11 +2581,11 @@ 'old2new ;; 'new2old ) (set! *didsomething* #t))) - (when (args:get-arg "-sync-brute-force") + #;(when (args:get-arg "-sync-brute-force") ((server:get-bruteforce-syncer (db:setup #t) persist-until-sync: #t)) (set! *didsomething* #t)) #;(if (args:get-arg "-sync-to-megatest.db") (let* ((dbstruct (db:setup #f)) Index: rmtmod.scm ================================================================== --- rmtmod.scm +++ rmtmod.scm @@ -644,11 +644,16 @@ (define (rmt:get-runs-cnt-by-patt runpatt targetpatt keys) (rmt:send-receive 'get-runs-cnt-by-patt #f (list runpatt targetpatt keys))) ;; Use the special run-id == #f scenario here since there is no run yet (define (rmt:register-run keyvals runname state status user contour) - (rmt:send-receive 'register-run #f (list keyvals runname state status user contour))) + ;; first register in main.db (thus the #f) + (let* ((run-id (rmt:send-receive 'register-run #f (list keyvals runname state status user contour)))) + ;; now register in the run db itself + (rmt:send-receive 'register-run run-id (list keyvals runname state status user contour)) + run-id)) + (define (rmt:get-run-name-from-id run-id) (rmt:send-receive 'get-run-name-from-id run-id (list run-id))) (define (rmt:delete-run run-id) @@ -1545,15 +1550,13 @@ (define (common:run-sync?) ;; (and (common:on-homehost?) (args:get-arg "-server")) - - ;; this one seems to be the general entry point ;; -(define (server:start-and-wait areapath #!key (timeout 60)) +#;(define (server:start-and-wait areapath #!key (timeout 60)) (let ((give-up-time (+ (current-seconds) timeout))) (let loop ((server-info (server:check-if-running areapath)) (try-num 0)) (if (or server-info (> (current-seconds) give-up-time)) ;; server-url will be #f if no server available. @@ -1586,11 +1589,13 @@ #f))) ;; no longer care if multiple servers are started by accident. older ;; servers will drop off in time. ;; -(define (server:check-if-running areapath) ;; #!key (numservers "2")) +;; defunct +;; +#;(define (server:check-if-running areapath) ;; #!key (numservers "2")) (let* ((ns (server:get-num-servers)) (servers (server:get-best (server:get-list areapath)))) (if (or (and servers (null? servers)) (not servers) @@ -1607,11 +1612,13 @@ (loop (car tal)(cdr tal))))))))) ;; kind start up of servers, wait 40 seconds before allowing another server for a given ;; run-id to be launched ;; -(define (server:kind-run areapath) +;; defunct +;; +#;(define (server:kind-run areapath) ;; look for $MT_RUN_AREA_HOME/logs/server-start-last ;; and wait for it to be at least 3 seconds old ;; (server:wait-for-server-start-last-flag areapath) (if (not (server:check-if-running areapath)) ;; why try if there is already a server running? (let* ((last-run-dat (hash-table-ref/default *server-kind-run* areapath '(0 0))) ;; callnum, whenrun @@ -1640,11 +1647,14 @@ ((rpc) (rpc:client-connect iface port)) ((http) (http:client-connect iface port)) ((zmq) (zmq:client-connect iface port)) (else (rpc:client-connect iface port)))) -(define (client:setup areapath #!key (remaining-tries 100) (failed-connects 0)) +;; +;; defunct +;; +#;(define (client:setup areapath #!key (remaining-tries 100) (failed-connects 0)) (print "got here") ;; (client:setup-http areapath remaining-tries: remaining-tries failed-connects: failed-connects) #;(case (server:get-transport) ((rpc) (rpc-transport:client-setup remaining-tries: remaining-tries failed-connects: failed-connects)) ;;(client:setup-rpc run-id)) ((http)(client:setup-http areapath remaining-tries: remaining-tries failed-connects: failed-connects)) Index: tests/unittests/basicserver.scm ================================================================== --- tests/unittests/basicserver.scm +++ tests/unittests/basicserver.scm @@ -55,12 +55,15 @@ ;; with-input-from-request ) (define *db* (db:setup #f)) (test #f 'server-started (api:execute-requests *db* 'get-server (list *toppath* ".db/1.db"))) +(set! *dbstruct-db* #f) (test #f 'server-started (rmt:general-open-connection *rmt:remote* *toppath* ".db/1.db")) (test #f '("SYSTEM" "RELEASE") (rmt:get-keys)) + +(test #f 1 (rmt:register-run '(("SYSTEM" "a")("RELEASE" "b")) "run1" "new" "n/a" "justme" #f)) ;; (delete-file* "logs/1.log") ;; (define run-id 1) ;; (test "setup for run" #t (begin (launch:setup)