Megatest

;; a specific Megatest area. Detail are being hashed out and this may change.
;;
(if (args:get-arg "-adjutant")
    (begin
      (adjutant-run)
      (set! *didsomething* #t)))

(if (or (args:get-arg "-list-servers")
(if (args:get-arg "-list-servers")
        (args:get-arg "-kill-servers"))
    (let ((tl (launch:setup)))
  (let* ((tl (launch:setup)) ;; need this to initialize *toppath*
      (if tl ;; all roads from here exit
	  (let* ((servers (server:get-list *toppath*))
		 (fmtstr  "~33a~22a~20a~20a~8a\n"))
	    (format #t fmtstr "ID" "host:port" "age (hms)" "Last mod" "State")
	    (format #t fmtstr "==" "=========" "=========" "========" "=====")
	    (for-each ;;  ( mod-time host port start-time pid )
	     (lambda (server)
	       (let* ((mtm (any->number (car server)))
        (servdir (server: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"))))
     )
     (format #t fmtstr "DB" "host:port" "PID" "age" "last mod" "state")
     (for-each
        (lambda (dbfile)
          (let* (
            (dbfname (conc (pathname-file dbfile) ".db"))
            )
                (let (
                  (sinfos (server:get-server-info-sorted *toppath* dbfname))
                  )
                  (for-each 
                     (lambda (sinfo)
                       (let* (
		      (mod (if mtm (- (current-seconds) mtm) "unk"))
		      (age (- (current-seconds)(or (any->number (list-ref server 3)) (current-seconds))))
                         (db (list-ref sinfo 5))
		      (url (conc (cadr server) ":" (caddr server)))
		      (pid (list-ref server 4))
		      (alv (if (number? mod)(< mod 10) #f)))
		 (format #t
			 fmtstr
			 pid
                         (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
                  )
                ) 
          )
       )
       dbfiles
     )
     (set! *didsomething* #t)
     (exit)  
  )
)


(if (args:get-arg "-kill-servers")

  (let* ((tl (launch:setup)) ;; need this to initialize *toppath*
        (servdir (server: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"))))
			 url
			 (seconds->hr-min-sec age)
			 (seconds->hr-min-sec mod)
     )
     (format #t fmtstr "DB" "host:port" "PID" "age" "last mod" "state")
     (for-each
			 (if alv "alive" "dead"))
		 (if (and alv
        (lambda (dbfile)
			  (args:get-arg "-kill-servers"))
		     (begin
          (let* (
		       (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)))))
	    ;; (debug:print-info 1 *default-log-port* "Done with listservers")
	    (set! *didsomething* #t)
	    (exit))
	  (exit))))
      ;; must do, would have to add checks to many/all calls below
            (dbfname (conc (pathname-file dbfile) ".db"))
            (sfiles   (server:find-server *toppath* dbfname))
            )
            (for-each 
              (lambda (sfile)
                (let (
                  (sinfos (servert:get-server-info-sorted *toppath* 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)
                         (delete-file* sfile)
                       )
                     )
                     sinfos
                  )
                ) 
              )
              sfiles
            )
          )
       )
       dbfiles
     )
     ;; remove this db, because otherwise metadata contains records for old servers, and this causes a problem with db:no-sync-get-lock-with-id.
     (if (file-exists? (conc *toppath* "/.mtdb/no-sync.db"))
       (delete-file (conc *toppath* "/.mtdb/no-sync.db"))
     )
     (set! *didsomething* #t)
     (exit)  
  )
)



;;======================================================================
;; Weird special calls that need to run *after* the server has started?
;;======================================================================

(if (args:get-arg "-list-targets")
    (if (launch:setup)