733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
|
;; we start the server if not running else start the client thread
;;======================================================================
(if (args:get-arg "-server")
;; Server? Start up here.
;;
(let ((tl (launch:setup))
(run-id (and (args:get-arg "-run-id")
(string->number (args:get-arg "-run-id"))))
(transport-type (string->symbol (or (args:get-arg "-transport") "http"))))
(if run-id
(begin
(server:launch run-id transport-type)
;; Not a server? This section will decide how to communicate
;;
;; Setup client for all expect listed here
(if (null? (lset-intersection
equal?
(hash-table-keys args:arg-hash)
'("-list-servers"
|
|
|
|
|
|
|
|
|
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
|
;; we start the server if not running else start the client thread
;;======================================================================
(if (args:get-arg "-server")
;; Server? Start up here.
;;
(let* ((tl (launch:setup))
(run-id (and (args:get-arg "-run-id")
(string->number (args:get-arg "-run-id")))))
(BB> "megatest -server called; starting server")
(if run-id
(begin
(server:launch run-id (->string *transport-type*))
(set! *didsomething* #t))
(debug:print-error 0 *default-log-port* "server requires run-id be specified with -run-id")))
;; Not a server? This section will decide how to communicate
;;
;; Setup client for all expect listed here
(if (null? (lset-intersection
equal?
(hash-table-keys args:arg-hash)
'("-list-servers"
|
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
|
(if (or (args:get-arg "-list-servers")
(args:get-arg "-stop-server")
(args:get-arg "-kill-server"))
(let ((tl (launch:setup)))
(if tl
(let* ((tdbdat (tasks:open-db))
(servers (tasks:get-all-servers (db:delay-if-busy tdbdat)))
(fmtstr "~5a~12a~8a~20a~24a~10a~10a~10a~10a\n")
(servers-to-kill '())
(kill-switch (if (args:get-arg "-kill-server") "-9" ""))
(killinfo (or (args:get-arg "-stop-server") (args:get-arg "-kill-server") ))
(khost-port (if killinfo (if (substring-index ":" killinfo)(string-split ":") #f) #f))
(sid (if killinfo (if (substring-index ":" killinfo) #f (string->number killinfo)) #f)))
(format #t fmtstr "Id" "MTver" "Pid" "Host" "Interface:OutPort" "InPort" "LastBeat" "State" "Transport")
(format #t fmtstr "==" "=====" "===" "====" "=================" "======" "========" "=====" "=========")
(for-each
(lambda (server)
(let* ((id (vector-ref server 0))
(pid (vector-ref server 1))
(hostname (vector-ref server 2))
(interface (vector-ref server 3))
(pullport (vector-ref server 4))
(pubport (vector-ref server 5))
(start-time (vector-ref server 6))
(priority (vector-ref server 7))
(state (vector-ref server 8))
(mt-ver (vector-ref server 9))
(last-update (vector-ref server 10))
(transport (vector-ref server 11))
(killed #f)
(status (< last-update 20)))
;; (zmq-sockets (if status (server:client-connect hostname port) #f)))
;; no need to login as status of #t indicates we are connecting to correct
;; server
(if (equal? state "dead")
(if (> last-update (* 25 60 60)) ;; keep records around for slighly over a day.
(tasks:server-deregister (db:delay-if-busy tdbdat) hostname pullport: pullport pid: pid action: 'delete))
(if (> last-update 20) ;; Mark as dead if not updated in last 20 seconds
(tasks:server-deregister (db:delay-if-busy tdbdat) hostname pullport: pullport pid: pid)))
(format #t fmtstr id mt-ver pid hostname (conc interface ":" pullport) pubport last-update
(if status "alive" "dead") transport)
(if (or (equal? id sid)
(equal? sid 0)) ;; kill all/any
(begin
(debug:print-info 0 *default-log-port* "Attempting to kill "kill-switch" server with pid " pid)
(tasks:kill-server hostname pid kill-switch: kill-switch)))))
servers)
(debug:print-info 1 *default-log-port* "Done with listservers")
|
|
|
|
>
|
|
|
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
|
(if (or (args:get-arg "-list-servers")
(args:get-arg "-stop-server")
(args:get-arg "-kill-server"))
(let ((tl (launch:setup)))
(if tl
(let* ((tdbdat (tasks:open-db))
(servers (tasks:get-all-servers (db:delay-if-busy tdbdat)))
(fmtstr "~5a~6a~12a~8a~20a~24a~10a~10a~10a~10a\n")
(servers-to-kill '())
(kill-switch (if (args:get-arg "-kill-server") "-9" ""))
(killinfo (or (args:get-arg "-stop-server") (args:get-arg "-kill-server") ))
(khost-port (if killinfo (if (substring-index ":" killinfo)(string-split ":") #f) #f))
(sid (if killinfo (if (substring-index ":" killinfo) #f (string->number killinfo)) #f)))
(format #t fmtstr "Id" "RunId" "MTver" "Pid" "Host" "Interface:OutPort" "InPort" "LastBeat" "State" "Transport")
(format #t fmtstr "==" "=====" "=====" "===" "====" "=================" "======" "========" "=====" "=========")
(for-each
(lambda (server)
(let* ((id (vector-ref server 0))
(pid (vector-ref server 1))
(hostname (vector-ref server 2))
(interface (vector-ref server 3))
(pullport (vector-ref server 4))
(pubport (vector-ref server 5))
(start-time (vector-ref server 6))
(priority (vector-ref server 7))
(state (vector-ref server 8))
(mt-ver (vector-ref server 9))
(last-update (vector-ref server 10))
(transport (vector-ref server 11))
(run-id (vector-ref server 12))
(killed #f)
(status (< last-update 20)))
;; (zmq-sockets (if status (server:client-connect hostname port) #f)))
;; no need to login as status of #t indicates we are connecting to correct
;; server
(if (equal? state "dead")
(if (> last-update (* 25 60 60)) ;; keep records around for slighly over a day.
(tasks:server-deregister (db:delay-if-busy tdbdat) hostname pullport: pullport pid: pid action: 'delete))
(if (> last-update 20) ;; Mark as dead if not updated in last 20 seconds
(tasks:server-deregister (db:delay-if-busy tdbdat) hostname pullport: pullport pid: pid)))
(format #t fmtstr id run-id mt-ver pid hostname (conc interface ":" pullport) pubport last-update
(if status state "dead") transport)
(if (or (equal? id sid)
(equal? sid 0)) ;; kill all/any
(begin
(debug:print-info 0 *default-log-port* "Attempting to kill "kill-switch" server with pid " pid)
(tasks:kill-server hostname pid kill-switch: kill-switch)))))
servers)
(debug:print-info 1 *default-log-port* "Done with listservers")
|