| ︙ | | |
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
|
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
|
-
+
|
;; (args:get-arg "-runstep"))
(let ((original-exit (exit-handler)))
(exit-handler (lambda (#!optional (exit-code 0))
(printf "Preparing to exit with exit code ~A ...\n" exit-code)
(for-each
(lambda (pid)
(handle-exceptions
(common:debug-handle-exceptions #t
exn
#t
(let-values (((pid-val exit-status exit-code) (process-wait pid #t)))
(if (or (eq? pid-val pid)
(eq? pid-val 0))
(begin
(printf "Sending signal/term to ~A\n" pid)
|
| ︙ | | |
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
|
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
|
-
+
|
'())))
(if (null? files)
(debug:print-info 0 *default-log-port* "No cached megatest or runconfigs files found. None removed.")
(begin
(debug:print-info 0 *default-log-port* "Removing cached files:\n " (string-intersperse files "\n "))
(for-each
(lambda (f)
(handle-exceptions
(common:debug-handle-exceptions #t
exn
(debug:print 0 *default-log-port* "WARNING: Failed to remove file " f)
(delete-file f)))
files))))
(debug:print-error 0 *default-log-port* "-clean-cache requires -runname."))
(debug:print-error 0 *default-log-port* "-clean-cache requires -target or -reqtarg"))))
|
| ︙ | | |
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
|
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* ((tdbdat (tasks:open-db))
(let* ((servers (server:get-list *toppath*))
(servers (tasks:get-all-servers (db:delay-if-busy tdbdat)))
|
| ︙ | | |
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
|
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)))
;; (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
|
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)
(handle-exceptions
(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))
|
| ︙ | | |