Index: apimod.scm ================================================================== --- apimod.scm +++ apimod.scm @@ -201,10 +201,11 @@ ;; ((start-server) (apply server:kind-run params)) ((kill-server) (set! *server-run* #f)) ((get-server) (api:start-server dbstruct params)) ((register-server) (apply db:register-server dbstruct params) );; dbstruct host port servkey pid ipaddr dbpath) ((deregister-server) (apply db:deregister-server dbstruct params) );; dbstruct host port servkey pid ipaddr dbpath) + ((get-count-servers) (apply db:get-count-servers dbstruct params)) ;; TESTS ;;((test-set-state-status-by-id) (apply mt:test-set-state-status-by-id dbstruct params)) ;;BB - commented out above because it was calling below, eventually, incorrectly (dbstruct passed to mt:test-set-state-status-by-id, which previosly did more, but now only passes thru to db:set-state-status-and-roll-up-items. Index: dbmod.scm ================================================================== --- dbmod.scm +++ dbmod.scm @@ -202,11 +202,11 @@ (create-directory parent-dir #t)) (let* ((exists (file-exists? dbfile)) (db (sqlite3:open-database dbfile)) (handler (sqlite3:make-busy-timeout 3600))) (sqlite3:set-busy-handler! db handler) - (db:set-sync db) + ;; (db:set-sync db) ;; we don't mind that this is slow? (if (not exists) (dbinit-proc db)) db))) ;; open and initialize the inmem db @@ -5564,11 +5564,11 @@ (begin (sqlite3:execute db "DELETE FROM servers WHERE apath=? AND dbname=?;" ;; (host,port,servkey,pid,ipaddr,apath,dbname) VALUES (?,?,?,?,?,?,?);" ;; host port servkey pid ipaddr apath dbname) #;(db:get-server-info dbstruct apath dbname))))))))) - + (define (db:get-server-info dbstruct apath dbname) (db:with-db dbstruct #f #f (lambda (db) @@ -5577,7 +5577,20 @@ (list host port servkey pid ipaddr apath dbpath)) #f db "SELECT host,port,servkey,pid,ipaddr,apath,dbname FROM servers WHERE apath=? AND dbname=?;" apath dbname)))) + +(define (db:get-count-servers dbstruct apath) + (db:with-db + dbstruct + #f #f + (lambda (db) + (sqlite3:fold-row + (lambda (res count) + (max res count)) + 0 + db + "SELECT count(*) FROM servers WHERE apath=?;" + apath)))) ) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -912,12 +912,13 @@ (hash-table-set! args:arg-hash "-testpatt" newval) (hash-table-delete! args:arg-hash "-itempatt"))) (if (args:get-arg "-runtests") (debug:print 0 *default-log-port* "WARNING: \"-runtests\" is deprecated. Use \"-run\" with \"-testpatt\" instead")) - - (on-exit std-exit-procedure) + + (debug:print 0 *default-log-port* "on-exit disabled. Please re-enable") + ;; (on-exit std-exit-procedure) ;;====================================================================== ;; Misc general calls ;;====================================================================== Index: rmtmod.scm ================================================================== --- rmtmod.scm +++ rmtmod.scm @@ -1625,10 +1625,11 @@ (if (not (eq? res 'quit)) (begin (set! *db-last-access* (current-seconds)) (nn-send rep resdat) (loop (nn-recv rep))))))) + (debug:print-info 0 *default-log-port* "After server, should never see this") ;; server exit stuff here (let* ((portnum (servdat-port *server-info*))) (portlogger:open-run-close portlogger:set-port portnum "released") (rmt:server-shutdown) ;; (bdat-time-to-exit-set! *bdat* #t) ;; tell on-exit to be fast as we've already cleaned up @@ -2039,21 +2040,28 @@ ,(current-process-id) ,iface ,apath ,dbname))) -(define (rmt:deregister-server remote apath iface port server-key dbname) +(define (rmt:get-count-servers remote apath) (rmt:open-main-connection remote apath) ;; we need a channel to main.db (rmt:send-receive-real remote apath ;; params: host port servkey pid ipaddr dbpath (db:run-id->dbname #f) - 'deregister-server `(,iface - ,port - ,server-key - ,(current-process-id) - ,iface - ,apath - ,dbname))) + 'get-count-servers `(,apath + ))) + +(define (rmt:deregister-server remote apath iface port server-key dbname) + (rmt:open-main-connection remote apath) ;; we need a channel to main.db + (rmt:send-receive-real remote apath ;; params: host port servkey pid ipaddr dbpath + (db:run-id->dbname #f) + 'deregister-server `(,iface + ,port + ,server-key + ,(current-process-id) + ,iface + ,apath + ,dbname))) (define (http-transport:wait-for-stable-interface #!optional (num-tries-allowed 100)) ;; wait until *server-info* stops changing (let* ((stime (current-seconds))) (let loop ((last-host #f) @@ -2184,19 +2192,25 @@ (db:print-current-query-stats))) (let* ((hrs-since-start (/ (- (current-seconds) server-start-time) 3600))) (cond ((and *server-run* (> (+ last-access server-timeout) - (current-seconds))) + (current-seconds)) + (if is-main + (> (rmt:get-count-servers *rmt:remote* *toppath*) 1) + #t)) (if (common:low-noise-print 120 "server continuing") (debug:print-info 0 *default-log-port* "Server continuing, seconds since last db access: " (- (current-seconds) last-access))) (loop 0 bad-sync-count (current-milliseconds))) (else (set! *unclean-shutdown* #f) - (debug:print-info 0 *default-log-port* "Starting to shutdown the server. pid="(current-process-id)) (debug:print-info 0 *default-log-port* "Server timed out. seconds since last db access: " (- (current-seconds) last-access)) - (debug:print-info 0 *default-log-port* "Sending 'quit to server, received: " + (debug:print-info 0 *default-log-port* "Starting to shutdown the server. pid="(current-process-id)) + (rmt:server-shutdown) + (portlogger:open-run-close portlogger:set-port port "released") + (exit) + #;(debug:print-info 0 *default-log-port* "Sending 'quit to server, received: " (open-send-receive-nn (conc iface":"port) ;; do this here and not in server-shutdown (sexpr->string 'quit))) ))))))) ;; Call this to start the actual server @@ -2319,11 +2333,11 @@ ) (handle-exceptions exn (let ((emsg ((condition-property-accessor 'exn 'message) exn))) ;; Send notification - (debug:print 0 *default-log-port* "ERROR: Failed to connect / send to " uri " message was \"" emsg "\"" ) + (debug:print 0 *default-log-port* "ERROR: Failed to connect / send to " uri " message was \"" emsg "\", exn=" exn) #f) (nn-connect req uri) ;; (print "Connected to the server " ) (nn-send req msg) ;; (print "Request Sent") Index: tests/unittests/server.scm ================================================================== --- tests/unittests/server.scm +++ tests/unittests/server.scm @@ -32,19 +32,21 @@ ;; rmt:send-receive-real ;; rmt:send-receive ;; sexpr->string ;; server-ready? ;; rmt:register-server + ;; rmt:deregister-server ;; rmt:open-main-connection ;; rmt:general-open-connection ;; rmt:get-conn ;; common:watchdog ;; rmt:find-main-server ;; get-all-server-pkts ;; get-viable-servers ;; get-best-candidate ;; api:run-server-process + api:process-request ;; rmt:run ;; rmt:try-start-server ) (define *db* (db:setup #f)) @@ -67,13 +69,15 @@ (test #f 1 (rmt:send-receive 'register-run #f (list keyvals "run1" "new" "n/a" "justme" #f))) (print "Got here.") (test #f 1 (rmt:send-receive 'register-run 1 (list keyvals "run1" "new" "n/a" "justme" #f))) -;; (test #f 1 (rmt:register-run keyvals "run2" "new" "n/a" "justme" #f)) +(test #f 2 (rmt:register-run keyvals "run2" "new" "n/a" "justme" #f)) +;; (test #f 2 (rmt:deregister-server *rmt:remote* *toppath* iface port server-key dbname -(thread-sleep! 5) +(test #f 2 (rmt:get-count-servers *rmt:remote* *toppath*)) + (exit) ;; (delete-file* "logs/1.log") ;; (define run-id 1)