779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
|
(set! *didsomething* #t)))
(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")
|
|
<
|
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
|
(set! *didsomething* #t)))
(if (or (args:get-arg "-list-servers")
(args:get-arg "-stop-server")
(args:get-arg "-kill-server"))
(let ((tl (launch:setup)))
(if tl
(let* ((servers (server:get-list *toppath*))
(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")
|
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
|
(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)))))
|
|
|
|
|
|
|
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
|
(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)))))
|
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
|
(display (conc "target: " targetstr " "))
(display (conc field-name ": " (db:get-value-by-header run header (conc field-name)) " "))))
runs-spec)
(newline)))))
(for-each
(lambda (test)
(handle-exceptions
exn
(begin
(debug:print-error 0 *default-log-port* "Bad data in test record? " test)
(print "exn=" (condition->list exn))
(debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
(print-call-chain (current-error-port)))
(let* ((test-id (if (member "id" tests-spec)(get-value-by-fieldname test test-field-index "id" ) #f)) ;; (db:test-get-id test))
|
|
|
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
|
(display (conc "target: " targetstr " "))
(display (conc field-name ": " (db:get-value-by-header run header (conc field-name)) " "))))
runs-spec)
(newline)))))
(for-each
(lambda (test)
(common:debug-handle-exceptions #f
exn
(begin
(debug:print-error 0 *default-log-port* "Bad data in test record? " test)
(print "exn=" (condition->list exn))
(debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
(print-call-chain (current-error-port)))
(let* ((test-id (if (member "id" tests-spec)(get-value-by-fieldname test test-field-index "id" ) #f)) ;; (db:test-get-id test))
|