Index: commonmod.scm ================================================================== --- commonmod.scm +++ commonmod.scm @@ -228,17 +228,15 @@ (define *heartbeat-mutex* (make-mutex)) (define *api-process-request-count* 0) (define *max-api-process-requests* 0) (define *server-overloaded* #f) (define *writes-total-delay* 0) +(define *unclean-shutdown* #t) ;; flag to clear on clean shutdown ;; client (define *rmt-mutex* (make-mutex)) ;; remote access calls mutex -;; RPC transport -(define *rpc:listener* #f) - ;; KEY info ;; (define *target* (make-hash-table)) ;; cache the target here; target is keyval1/keyval2/.../keyvalN (define *keys* (make-hash-table)) ;; cache the keys here (define *keyvals* (make-hash-table)) (define *toptest-paths* (make-hash-table)) ;; cache toptest path settings here Index: rmtmod.scm ================================================================== --- rmtmod.scm +++ rmtmod.scm @@ -1459,10 +1459,48 @@ (common:version-signature)))) (define (common:api-changed?) (not (equal? (substring (->string megatest-version) 0 4) (substring (conc (common:get-last-run-version)) 0 4)))) + +(define (rmt:server-shutdown) + (let ((dbfile (servdat-dbfile *server-info*))) + (debug:print-info 0 *default-log-port* "dbfile is "dbfile) + (if dbfile + (let* ((am-server (args:get-arg "-server")) + (dbfile (args:get-arg "-db")) + (apath *toppath*)) + ;; do a final sync here + (debug:print-info 0 *default-log-port* "Doing final sync for "apath" "dbfile" at "(current-seconds)) + (db:sync-inmem->disk *dbstruct-db* apath dbfile force-sync: #t) + (if am-server + (if (string-match ".*/main.db$" dbfile) + (let ((pkt-file (conc (get-pkts-dir *toppath*) + "/" (servdat-uuid *server-info*) + ".pkt"))) + (debug:print-info 0 *default-log-port* "removing pkt "pkt-file) + (delete-file* pkt-file) + (debug:print-info 0 *default-log-port* "Releasing lock for "dbfile) + (db:with-lock-db (servdat-dbfile *server-info*) + (lambda (dbh dbfile) + (db:release-lock dbh dbfile)))) + (let* ((sdat *server-info*) ;; we have a run-id server + (host (servdat-host sdat)) + (port (servdat-port sdat)) + (uuid (servdat-uuid sdat))) + (if (not (string-match ".db/main.db" (args:get-arg "-db"))) + (let* ((res (rmt:deregister-server *rmt:remote* ;; TODO/BUG: why is this requiring *rmt:remote*? + *toppath* + (servdat-host *server-info*) ;; iface + (servdat-port *server-info*) + (servdat-uuid *server-info*) + (current-process-id) + ))) + (debug:print-info 0 *default-log-port* "deregistered-server, res="res))) + + (debug:print-info 0 *default-log-port* "deregistering server "host":"port" with uuid "uuid) + ))))))) (define (std-exit-procedure) ;;(common:telemetry-log-close) (on-exit (lambda () 0)) ;;(debug:print-info 13 *default-log-port* "std-exit-procedure called; *time-to-exit*="*time-to-exit*) @@ -1475,37 +1513,13 @@ (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 (let* ((start-time (current-seconds))) - (if *server-info* - (let ((dbfile (servdat-dbfile *server-info*))) - (debug:print-info 0 *default-log-port* "dbfile is "dbfile) - (if dbfile - (let* ((am-server (args:get-arg "-server")) - (dbfile (args:get-arg "-db")) - (apath *toppath*)) - ;; do a final sync here - (debug:print-info 0 *default-log-port* "Doing final sync for "apath" "dbfile" at "(current-seconds)) - (db:sync-inmem->disk *dbstruct-db* apath dbfile force-sync: #t) - (if am-server - (if (string-match ".*/main.db$" dbfile) - (let ((pkt-file (conc (get-pkts-dir *toppath*) - "/" (servdat-uuid *server-info*) - ".pkt"))) - (debug:print-info 0 *default-log-port* "removing pkt "pkt-file) - (delete-file* pkt-file) - (debug:print-info 0 *default-log-port* "Releasing lock for "dbfile) - (db:with-lock-db (servdat-dbfile *server-info*) - (lambda (dbh dbfile) - (db:release-lock dbh dbfile)))) - (let* ((sdat *server-info*) ;; we have a run-id server - (host (servdat-host sdat)) - (port (servdat-port sdat)) - (uuid (servdat-uuid sdat))) - (debug:print-info 0 *default-log-port* "deregistering server "host":"port" with uuid "uuid) - ))))))) + (if (and *server-info* + *unclean-shutdown*) + (rmt:server-shutdown)) (debug:print-info 0 *default-log-port* "Shutdown activities completed in "(- (current-seconds) start-time)" seconds")) ;; (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) @@ -1591,15 +1605,20 @@ (servdat-trynum-set! *server-info* (+ (servdat-trynum *server-info*) 1))) (set! *server-info* (make-servdat host: ipaddrstr port: port))) (let* ((rep (rmt:try-start-server ipaddrstr port))) (let loop ((instr (nn-recv rep))) (let* ((data (string->sexpr instr)) - (res (api:process-request *dbstruct-db* data)) + (res (case data + ((quit) 'quit) + (else (api:process-request *dbstruct-db* data)))) (resdat (sexpr->string res))) - (set! *db-last-access* (current-seconds)) - (nn-send rep resdat) - (loop (nn-recv rep))))) + (if (not (eq? res 'quit)) + (begin + (set! *db-last-access* (current-seconds)) + (nn-send rep resdat) + (loop (nn-recv rep))))))) + ;; server exit stuff here (let* ((portnum (servdat-port *server-info*))) (portlogger:open-run-close portlogger:set-port portnum "released") (debug:print 1 *default-log-port* "INFO: server has been stopped")))) (define (rmt:try-start-server ipaddrstr portnum) @@ -2139,19 +2158,19 @@ (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 (debug:print-info 0 *default-log-port* "Server timed out. seconds since last db access: " (- (current-seconds) last-access)) - (if (not (string-match ".db/main.db" (args:get-arg "-db"))) - (let* ((res (rmt:deregister-server *rmt:remote* ;; TODO/BUG: why is this requiring *rmt:remote*? - *toppath* - (servdat-host *server-info*) ;; iface - (servdat-port *server-info*) - (servdat-uuid *server-info*) - (current-process-id) - ))) - (debug:print-info 0 *default-log-port* "deregistered-server, res="res))) + + + + + ;; send self 'quit here + + + + (http-transport:server-shutdown port)))))))) (define (http-transport:server-shutdown port) (begin ;;(BB> "http-transport:server-shutdown called") @@ -2159,11 +2178,12 @@ ;; ;; start_shutdown ;; ;; deregister the server - + (rmt:server-shutdown) + (set! *unclean-shutdown* #f) (bdat-time-to-exit-set! *bdat* #t) ;; tell on-exit to be fast as we've already cleaned up ;; (portlogger:open-run-close portlogger:set-port port "released") ;; done in rmt:run (thread-sleep! 1)