Index: rmtmod.scm ================================================================== --- rmtmod.scm +++ rmtmod.scm @@ -101,10 +101,35 @@ (defstruct alldat (areapath #f) (ulexdat #f) ) + +;; (require-extension (srfi 18) extras tcp s11n) +;; +;; +;; (use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest posix-extras) +;; +;; (use spiffy uri-common intarweb http-client spiffy-request-vars intarweb spiffy-directory-listing) +;; +;; Configurations for server +(tcp-buffer-size 2048) +(max-connections 2048) + +(defstruct servdat + (host #f) + (port #f) + (uuid #f) + (dbfile #f) + (api-url #f) + (api-uri #f) + (api-req #f) + (status 'starting)) + +(define (servdat->url sdat) + (conc (servdat-host sdat)":"(servdat-port sdat))) + ;; (include "db_records.scm") ;;====================================================================== ;; return the handle struct for sending queries to a specific database ;; - initializes the connection object if this is the first access @@ -1456,12 +1481,11 @@ #t)))) (debug:print-info 4 *default-log-port* "starting exit process, finalizing databases.") (if (and no-hurry (debug:debug-mode 18)) (rmt:print-db-stats)) (let ((th1 (make-thread (lambda () ;; thread for cleaning up, give it five seconds - (if *dbstruct-db* (db:close-all *dbstruct-db*)) ;; one second allocated - (if *server-info* + (if *server-info* (let ((pkt-file (conc (get-pkts-dir *toppath*) "/" (servdat-uuid *server-info*) ".pkt")) (dbfile (servdat-dbfile *server-info*))) (if dbfile @@ -1483,10 +1507,11 @@ 'deregister-server `(,(servdat-uuid sdat) ,(current-process-id) ,(servdat-host sdat) ;; iface ,(servdat-port sdat))))))))) + (if *dbstruct-db* (db:close-all *dbstruct-db*)) ;; one second allocated (if (bdat-task-db *bdat*) ;; TODO: Check that this is correct for task db (let ((db (cdr (bdat-task-db *bdat*)))) (if (sqlite3:database? db) (begin (sqlite3:interrupt! db) @@ -1530,33 +1555,10 @@ ;;====================================================================== ;; http-transportmod.scm contents moved here ;;====================================================================== -;; (require-extension (srfi 18) extras tcp s11n) -;; -;; -;; (use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest posix-extras) -;; -;; (use spiffy uri-common intarweb http-client spiffy-request-vars intarweb spiffy-directory-listing) -;; -;; Configurations for server -(tcp-buffer-size 2048) -(max-connections 2048) - -(defstruct servdat - (host #f) - (port #f) - (uuid #f) - (dbfile #f) - (api-url #f) - (api-uri #f) - (api-req #f)) - -(define (servdat->url sdat) - (conc (servdat-host sdat)":"(servdat-port sdat))) - (define (http-transport:make-server-url hostport) (if (not hostport) #f (conc "http://" (car hostport) ":" (cadr hostport)))) @@ -2053,37 +2055,42 @@ ,apath ,dbname))) (define (http-transport:wait-for-stable-interface #!optional (num-tries-allowed 100)) ;; wait until *server-info* stops changing - (let loop ((sdat #f) ;; this is our copy of the *last* *server-info* - (tries 0)) - ;; first we verify port and interface, update *server-info* in need be. - (cond - ((> tries num-tries-allowed) - (debug:print 0 *default-log-port* "http-transport:keep-running, giving up after trying for several minutes.") - (exit 1)) - ((not *server-info*) - (thread-sleep! 0.25) - (loop *server-info* (+ tries 1))) - ((not sdat) - (debug:print 0 *default-log-port* "http-transport:keep-running, still no interface, tries="tries) - (thread-sleep! 0.25) - (loop *server-info* (+ tries 1))) - ((or (not (equal? (servdat-host sdat)(servdat-host *server-info*))) - (not (equal? (servdat-port sdat)(servdat-port *server-info*)))) - (debug:print-info 0 *default-log-port* "WARNING: interface changed, refreshing iface and port info") - (thread-sleep! 0.25) - (loop *server-info* (+ tries 1))) - (else - (if (not *server-id*)(set! *server-id* (server:mk-signature))) - (debug:print 0 *default-log-port* - "SERVER STARTED: " (servdat-host *server-info*) - ":" (servdat-port *server-info*) - " AT " (current-seconds) " server-id: " *server-id*) - (flush-output *default-log-port*) - #t)))) + (let* ((stime (current-seconds))) + (let loop ((sdat #f) ;; this is our copy of the *last* *server-info* + (tries 0)) + ;; first we verify port and interface, update *server-info* in need be. + (cond + ((> tries num-tries-allowed) + (debug:print 0 *default-log-port* "http-transport:keep-running, giving up after trying for several minutes.") + (exit 1)) + ((not *server-info*) + (thread-sleep! 0.25) + (loop *server-info* (+ tries 1))) + ((not sdat) + (debug:print 0 *default-log-port* "http-transport:keep-running, still no interface, tries="tries) + (thread-sleep! 0.25) + (loop *server-info* (+ tries 1))) + ((or (not (equal? (servdat-host sdat)(servdat-host *server-info*))) + (not (equal? (servdat-port sdat)(servdat-port *server-info*)))) + (debug:print-info 0 *default-log-port* "WARNING: interface changed, refreshing iface and port info") + (thread-sleep! 0.25) + (loop *server-info* (+ tries 1))) + ((< (- (current-seconds) stime) 3) ;; keep up the looping until at least 3 seconds have passed + (thread-sleep! 1) + (loop *server-info* (+ tries 1))) + (else + (if (not *server-id*)(set! *server-id* (server:mk-signature))) + (servdat-status-set! *server-info* 'interface-alive) + (debug:print 0 *default-log-port* + "SERVER STARTED: " (servdat-host *server-info*) + ":" (servdat-port *server-info*) + " AT " (current-seconds) " server-id: " *server-id*) + (flush-output *default-log-port*) + #t))))) ;; 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 dbname) @@ -2099,28 +2106,30 @@ (last-access 0) (server-timeout (server:expiration-timeout))) ;; exits if nothing found in 100 tries (switch to a duration would be good) (http-transport:wait-for-stable-interface) (if is-main (http-transport:wait-for-server pkts-dir dbname server-key)) + ;; this is our forever loop (let* ((iface (servdat-host *server-info*)) (port (servdat-port *server-info*))) (let loop ((count 0) - (server-state 'available) (bad-sync-count 0) (start-time (current-milliseconds))) + (debug:print-info 0 *default-log-port* "servdat-status is " (servdat-status *server-info*) ", is-main="is-main) ;; set up the database handle (if (not *dbstruct-db*) ;; no db opened yet, open the db and register with main if appropriate - (let ((watchdog (bdat-watchdog *bdat*))) + (let ((watchdog (bdat-watchdog *bdat*))) (debug:print 0 *default-log-port* "SERVER: dbprep") (db:setup dbname) ;; sets *dbstruct-db* as side effect ;; IFF I'm not main, call into main and register self (if (not is-main) (let ((res (rmt:register-server *rmt:remote* *toppath* iface port server-key dbname))) - (if (not res) ;; we are not the server! + (if res ;; we are not the server! + (servdat-status-set! *server-info* 'have-interface-and-db) (begin (debug:print 0 *default-log-port* "We are not the server for "dbname", exiting.") (exit))))) (debug:print 0 *default-log-port* "SERVER: running, megatest version: " @@ -2131,11 +2140,11 @@ sleeping dead))) (begin (debug:print-info 0 *default-log-port* "Starting watchdog thread (in state "(thread-state watchdog)")") (thread-start! watchdog))) (debug:print 0 *default-log-port* "ERROR: *watchdog* not setup, cannot start it.")) - (loop (+ count 1) 'running bad-sync-count start-time))) + (loop (+ count 1) bad-sync-count start-time))) ;; when things go wrong we don't want to be doing the various ;; queries too often so we strive to run this stuff only every ;; four seconds or so. (let* ((sync-time (- (current-milliseconds) start-time)) @@ -2143,11 +2152,11 @@ (if (and (<= rem-time 4) (> rem-time 0)) (thread-sleep! rem-time))) (if (< count 1) ;; 3x3 = 9 secs aprox - (loop (+ count 1) 'running bad-sync-count (current-milliseconds))) + (loop (+ count 1) bad-sync-count (current-milliseconds))) ;; Transfer *db-last-access* to last-access to use in checking that we are still alive (mutex-lock! *heartbeat-mutex*) (set! last-access *db-last-access*) (mutex-unlock! *heartbeat-mutex*) @@ -2161,11 +2170,11 @@ ((and *server-run* (> (+ last-access server-timeout) (current-seconds))) (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 server-state bad-sync-count (current-milliseconds))) + (loop 0 bad-sync-count (current-milliseconds))) (else (debug:print-info 0 *default-log-port* "Server timed out. seconds since last db access: " (- (current-seconds) last-access)) (http-transport:server-shutdown port)))))))) (define (http-transport:server-shutdown port) Index: tests/unittests/basicserver.scm ================================================================== --- tests/unittests/basicserver.scm +++ tests/unittests/basicserver.scm @@ -341,6 +341,6 @@ ;; ;; ;; (test #f '(#t "exit process started") (rmt:kill-server)) ;; *toppath* *my-client-signature* #f))) ;; -(exit) +;; (exit)