@@ -981,54 +981,120 @@ (if (args:get-arg "-adjutant") (begin (adjutant-run) (set! *didsomething* #t))) -(if (or (args:get-arg "-list-servers") - (args:get-arg "-kill-servers")) - (let ((tl (launch:setup))) - (debug:print 0 *default-log-port* "NOT YET REIMPLEMENTED FOR TCP/INMEM") ;; BUG - (exit) - (if tl ;; all roads from here exit - (let* ((servers (server:choose-server *toppath* 'all-valid)) ;; (server:get-list *toppath*)) - (fmtstr "~33a~22a~20a~20a~8a\n")) - (if (not servers) - (begin - (debug:print-info 1 *default-log-port* "No servers found") - (exit) - ) - ) - (format #t fmtstr "PID" "host:port" "age (hms)" "Last mod" "State") - (format #t fmtstr "===" "=========" "=========" "========" "=====") - (for-each ;; (ip-addr port? mod-time host port start-time pid ) - (lambda (server) - (let* ((mtm (any->number (caddr server))) - (mod (if mtm (- (current-seconds) mtm) "unk")) - (age (- (current-seconds)(or (any->number mtm) (current-seconds)))) - (pid (list-ref server 4)) - (url (conc (car server) ":" (cadr server))) - (alv (if (number? mod)(< mod 360) #f))) - (format #t - fmtstr - pid - url - (seconds->hr-min-sec age) - (seconds->hr-min-sec mod) - (if alv "alive" "dead")) - (if (and alv - (args:get-arg "-kill-servers")) - (begin - (debug:print-info 0 *default-log-port* "Attempting to kill server with pid " pid) - (server:kill server))))) - (sort servers (lambda (a b) - (let ((ma (or (any->number (car a)) 9e9)) - (mb (or (any->number (car b)) 9e9))) - (> ma mb))))) - (set! *didsomething* #t) - (exit)) - (exit)))) - ;; must do, would have to add checks to many/all calls below +(if (args:get-arg "-list-servers") + (let* ((tl (launch:setup)) ;; need this to initialize *toppath* + (servdir (tt:get-servinfo-dir *toppath*)) + (servfiles (glob (conc servdir "/*:*.db"))) + (fmtstr "~10a~22a~10a~25a~25a~8a\n") + (dbfiles (append (glob (conc *toppath* "/.mtdb/main.db")) (glob (conc *toppath* "/.mtdb/?.db"))(glob (conc *toppath* "/.mtdb/??.db")))) + (ttdat (make-tt areapath: *toppath*)) + ) + (format #t fmtstr "DB" "host:port" "PID" "age" "last mod" "state") + (for-each + (lambda (dbfile) + (let* ( + (dbfname (conc (pathname-file dbfile) ".db")) + (sfiles (tt:find-server *toppath* dbfname)) + ) + (for-each + (lambda (sfile) + (let ( + (sinfos (tt:get-server-info-sorted ttdat dbfname)) + ) + (for-each + (lambda (sinfo) + (let* ( + (db (list-ref sinfo 5)) + (pid (list-ref sinfo 4)) + (host (list-ref sinfo 0)) + (port (list-ref sinfo 1)) + (server-id (list-ref sinfo 3)) + (age (seconds->hr-min-sec (- (current-seconds) (list-ref sinfo 2)))) + (last-mod (seconds->string (list-ref sinfo 2))) + (status (system (conc "ssh " host " ps " pid " > /dev/null"))) + (state (if (> status 0) + "dead" + (tt:ping host port server-id 0) + )) + ) + (format #t fmtstr db (conc host ":" port) pid age last-mod state) + ) + ) + sinfos + ) + ) + ) + sfiles + ) + ) + ) + dbfiles + ) + (set! *didsomething* #t) + (exit) + ) +) + + + + +(if (args:get-arg "-kill-servers") + + (let* ((tl (launch:setup)) ;; need this to initialize *toppath* + (servdir (tt:get-servinfo-dir *toppath*)) + (servfiles (glob (conc servdir "/*:*.db"))) + (fmtstr "~10a~22a~10a~25a~25a~8a\n") + (dbfiles (append (glob (conc *toppath* "/.mtdb/main.db")) (glob (conc *toppath* "/.mtdb/?.db"))(glob (conc *toppath* "/.mtdb/??.db")))) + (ttdat (make-tt areapath: *toppath*)) + ) + (format #t fmtstr "DB" "host:port" "PID" "age" "last mod" "state") + (for-each + (lambda (dbfile) + (let* ( + (dbfname (conc (pathname-file dbfile) ".db")) + (sfiles (tt:find-server *toppath* dbfname)) + ) + (for-each + (lambda (sfile) + (let ( + (sinfos (tt:get-server-info-sorted ttdat dbfname)) + ) + (for-each + (lambda (sinfo) + (let* ( + (db (list-ref sinfo 5)) + (pid (list-ref sinfo 4)) + (host (list-ref sinfo 0)) + (port (list-ref sinfo 1)) + (server-id (list-ref sinfo 3)) + (age (seconds->hr-min-sec (- (current-seconds) (list-ref sinfo 2)))) + (last-mod (seconds->string (list-ref sinfo 2))) + (killed (system (conc "ssh " host " kill " pid " > /dev/null"))) + (dummy2 (sleep 1)) + (state (if (> (system (conc "ssh " host " ps " pid " > /dev/null")) 0) "dead" "alive")) + ) + (format #t fmtstr db (conc host ":" port) pid age last-mod state) + (system (conc "rm " sfile)) + ) + ) + sinfos + ) + ) + ) + sfiles + ) + ) + ) + dbfiles + ) + (set! *didsomething* #t) + (exit) + ) +) ;;====================================================================== ;; Weird special calls that need to run *after* the server has started? ;;====================================================================== @@ -2589,15 +2655,24 @@ (let ((res (dbmod:db-to-db-sync src-db dest-db last-update (dbfile:db-init-proc) keys))) (if res (debug:print-info 0 *default-log-port* "Synced " res " records from "src-db" to "dest-db) (debug:print-info 0 *default-log-port* "No sync due to permissions or other issue.")) res)))) - (start-time (current-seconds))) + (start-time (current-seconds)) + (synclock-mod-time (if (file-exists? lockfile) + (handle-exceptions + exn + #f + (file-modification-time synclock-file)) + #f)) + (age (if synclock-mod-time (- (current-seconds) synclock-mod-time) 1000)) + ) (if (and src-db dest-db) (if (file-exists? src-db) - (if (file-exists? lockfile) - (debug:print 0 *default-log-port* "Lock "lockfile" exists, skipping sync...") + (if (and (file-exists? lockfile) (< age 20)) + (debug:print 0 *default-log-port* "Lock "lockfile" exists, skipping sync...") + (begin (dbfile:with-simple-file-lock lockfile (lambda () (let loop ((last-changed (current-seconds)) (last-update 0)) @@ -2612,11 +2687,14 @@ (if (and sync-period sync-timeout) ;; (if (and (< (- now-time start-time) 600) ;; hard limit on how long we run for (> sync-timeout (- now-time last-changed))) (begin (if sync-period (thread-sleep! sync-period)) - (loop (if (> changes 0) now-time last-changed) now-time))))))))) + (loop (if (> changes 0) now-time last-changed) now-time)))))))) + (debug:print 0 *default-log-port* "Releasing lock file " lockfile) + ) + ) (debug:print 0 *default-log-port* "No sync due to unreadble or non-existant source file"src-db)) (debug:print 0 *default-log-port* "Usage for -db2db; -to and -from must be specified")) (set! *didsomething* #t))) (if (args:get-arg "-list-test-time")