Megatest

Diff
Login

Differences From Artifact [164cc6d2b1]:

To Artifact [84dec1a162]:


155
156
157
158
159
160
161
162
163

164
165
166
167
168
169
170
155
156
157
158
159
160
161


162
163
164
165
166
167
168
169







-
-
+







  -setvars VAR1=val1,VAR2=val2 : Add environment variables to a run NB// these are
                                 overwritten by values set in config files.
  -server -|hostname      : start the server (reduces contention on megatest.db), use
                            - to automatically figure out hostname
  -transport http|rpc     : use http or rpc for transport (default is http) 
  -log logfile            : send stdout and stderr to logfile
  -list-servers           : list the servers 
  -stop-server id         : stop server specified by id (see output of -list-servers), use
                            0 to kill all
  -kill-servers           : kill all servers
  -repl                   : start a repl (useful for extending megatest)
  -load file.scm          : load and run file.scm
  -mark-incompletes       : find and mark incomplete tests
  -ping run-id|host:port  : ping server, exit with 0 if found
  -debug N|N,M,O...       : enable debug 0-N or N and M and O ...
  -config fname           : override the megatest.config file with fname
  -append-config fname    : append fname to the megatest.config file
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
250
251
252
253
254
255
256

257

258
259
260
261
262
263
264







-

-







			":expected"
			":tol"
			":units"
			;; misc
			"-start-dir"
			"-contour"
			"-server"
			"-stop-server"
			"-transport"
			"-kill-server"
			"-port"
			"-extract-ods"
			"-pathmod"
			"-env2file"
			"-envcap"
			"-envdelta"
			"-setvars"
317
318
319
320
321
322
323

324
325
326
327
328
329
330
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328







+







			"-cache-db"
                        "-use-db-cache"
			;; misc
			"-repl"
			"-lock"
			"-unlock"
			"-list-servers"
			"-kill-servers"
                        "-run-wait"      ;; wait on a run to complete (i.e. no RUNNING)
			"-local"         ;; run some commands using local db access
                        "-generate-html"

			;; misc queries
			"-list-disks"
			"-list-targets"
489
490
491
492
493
494
495
496

497
498

499
500
501
502
503
504
505
487
488
489
490
491
492
493

494
495

496
497
498
499
500
501
502
503







-
+

-
+







					      (eq? pid-val 0))
					  (begin
					    (printf "Sending signal/term to ~A\n" pid)
					    (process-signal pid signal/term))))))
		       (process:children #f))
		      (original-exit exit-code)))))

;; for some switches alway print the command to stderr
;; for some switches always print the command to stderr
;;
(if (args:any? "-run" "-runall" "-list-runs" "-remove-runs" "-set-state-status")
(if (args:any? "-run" "-runall" "-remove-runs" "-set-state-status")
    (debug:print 0 *default-log-port* (string-intersperse (argv) " ")))

;;======================================================================
;; Misc setup stuff
;;======================================================================

(debug:setup)
765
766
767
768
769
770
771
772
773

774
775

776
777

778
779
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
763
764
765
766
767
768
769


770
771

772
773

774








775
776
777
778



779
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







-
-
+

-
+

-
+
-
-
-
-
-
-
-
-
+
+
+

-
-
-
+
+
+
+
-
-
+
-
-
-
-
-
-
-
-
-
+
+
+
-
-
-
+
+
-
-
-
-
+
-
-
-
-
-
+
+
+
+

-
-
-
+
+
+
+
+
+


-
+

+







(if (args:get-arg "-server")
    (let ((tl        (launch:setup))
          (transport-type (string->symbol (or (args:get-arg "-transport") "http"))))
      (server:launch 0 transport-type)
      (set! *didsomething* #t)))

(if (or (args:get-arg "-list-servers")
	(args:get-arg "-stop-server")
        (args:get-arg "-kill-server"))
        (args:get-arg "-kill-servers"))
    (let ((tl (launch:setup)))
      (if tl 
      (if tl ;; all roads from here exit
	  (let* ((servers (server:get-list *toppath*))
		 (fmtstr  "~5a~12a~8a~20a~24a~10a~10a~10a~10a\n")
		 (fmtstr  "~8a~22a~20a~20a~8a\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 
	    (format #t fmtstr "pid" "Interface:port" "age (hms)" "Last mod" "State")
	    (format #t fmtstr "===" "==============" "=========" "========" "=====")
	    (for-each ;;  ( mod-time host port start-time pid )
	     (lambda (server)
	       (let* ((id         (vector-ref server 0))
		      (pid        (vector-ref server 1))
		      (hostname   (vector-ref server 2))
	       (let* ((mtm (any->number (car server)))
		      (mod (if mtm (- (current-seconds) mtm) "unk"))
		      (age (- (current-seconds)(or (any->number (list-ref server 3)) (current-seconds))))
		      (url (conc (cadr server) ":" (caddr server)))
		      (interface  (vector-ref server 3)) 
		      (pullport   (vector-ref server 4))
		      (pid (list-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)))
		      (alv (if (number? mod)(< mod 10) #f)))
		 (format #t
			 fmtstr
		 ;;   (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
			 pid
			 url
		;; (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
			 (seconds->hr-min-sec age)
		;; 	 (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
			 (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 "kill-switch" server with pid " pid)
		       (tasks:kill-server hostname pid kill-switch: kill-switch)))))
	     servers)
		       (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)) ;; must do, would have to add checks to many/all calls below
	    (exit))
	  (exit))))
      ;; must do, would have to add checks to many/all calls below

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

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