Megatest

Check-in [d42aaaab5b]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Made all stages respect the same hierarchy in setting transport. If -runtests uses http, so should test internal calls
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.55
Files: files | file ages | folders
SHA1: d42aaaab5b98c5e5a9143aeffe369113c9f115f7
User & Date: matt on 2013-08-05 00:19:21
Other Links: branch diff | manifest | tags
Context
2013-08-05
09:16
Improved auto start server message, bumped other server releated noise to level 2 check-in: 4a5256913c user: matt tags: v1.55
00:19
Made all stages respect the same hierarchy in setting transport. If -runtests uses http, so should test internal calls check-in: d42aaaab5b user: matt tags: v1.55
2013-08-04
21:56
Refactor code that choose transport. Priorities between options were not handled correctly in the three contexts; commandline override, cmdinfo and megatest.config check-in: d29828129b user: matt tags: v1.55
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified client.scm from [5629ce5408] to [e09e6cd211].

︙
48
49
50
51
52
53
54
55

56
57
58
59
60
61
62
63
64
65
66
67
68

69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99

48
49
50
51
52
53
54

55
56
57
58
59
60
61
62
63
64
65
66


67



68
69
70
71



72
73
74











75
76
77
78
79
80
81








-
+











-
-
+
-
-
-




-
-
-



-
-
-
-
-
-
-
-
-
-
-








    ok))

;; Do all the connection work, look up the transport type and set up the
;; connection if required.
;;
;; There are two scenarios. 
;;   1. We are a test manager and we received *transport-type* and *runremote* via cmdline
;;   2. We are a run tests, list runs or other interactive process and we mush figure out
;;   2. We are a run tests, list runs or other interactive process and we must figure out
;;      *transport-type* and *runremote* from the monitor.db
;;
;; client:setup
(define (client:setup #!key (numtries 3))
  (if (not *toppath*)
      (if (not (setup-for-run))
	  (begin
	    (debug:print 0 "ERROR: failed to find megatest.config, exiting")
	    (exit))))
  (push-directory *toppath*) ;; This is probably NOT needed 
  (debug:print-info 11 "*transport-type* is " *transport-type* ", *runremote* is " *runremote*)
  (let* ((hostinfo  (if (not *transport-type*) ;; If we dont' already have transport type set then figure it out
			(open-run-close tasks:get-best-server tasks:open-db)
  (let* ((hostinfo  (open-run-close tasks:get-best-server tasks:open-db)))
			#f)))
    ;; if have hostinfo then extract the transport type 
    ;; else fall back to fs
    (debug:print-info 11 "CLIENT SETUP, hostinfo=" hostinfo)
    (set! *transport-type* (if hostinfo 
    			       (string->symbol (tasks:hostinfo-get-transport hostinfo))
			       'fs))
    ;; ;; DEBUG STUFF
    ;; (if (eq? *transport-type* 'fs)(begin (print "ERROR!!!!!!! refusing to run with transport " *transport-type*)(exit 99)))
    
    (debug:print-info 11 "Using transport type of " *transport-type* (if hostinfo (conc " to connect to " hostinfo) ""))
    (case *transport-type* 
      ((fs)(if (not *megatest-db*)(set! *megatest-db* (open-db))))
      ;; NB// Going back to enabling fs and possibly even make it the default.
       ;; ;; we are not doing fs any longer. let's cheat and start up a server
       ;; ;; if we are falling back on fs (not 100% supported) do an about face and start a server
       ;; (if (not (equal? (args:get-arg "-transport") "fs"))
       ;;     (begin
       ;;       (set! *transport-type* #f)
       ;;       (system ;; (conc "megatest -list-servers | grep " (common:version-signature) " | grep alive || megatest -server - -daemonize && sleep 3"))
       ;;        "megatest -server - -daemonize")
       ;;       (thread-sleep! 1)
       ;;       (if (> numtries 0)
       ;;  	 (client:setup numtries: (- numtries 1))))))
      ((http)
       (http-transport:client-connect (tasks:hostinfo-get-interface hostinfo)
				      (tasks:hostinfo-get-port hostinfo)))
      ((zmq)
       (zmq-transport:client-connect (tasks:hostinfo-get-interface hostinfo)
				     (tasks:hostinfo-get-port      hostinfo)
				     (tasks:hostinfo-get-pubport   hostinfo)))
︙

Modified dashboard.scm from [42438bdc1e] to [1bdd31d35e].

︙
1359
1360
1361
1362
1363
1364
1365

1366

1367
1368
1369

1370
1371
1372
1373
1374
1375
1376

1359
1360
1361
1362
1363
1364
1365
1366

1367
1368
1369

1370
1371
1372
1373
1374
1375
1376
1377








+
-
+


-
+








		       (if *db* (sqlite3:finalize! *db*))))
	    (cdb:remote-run examine-run *db* runid)))
	(begin
	  (print "ERROR: runid is not a number " (args:get-arg "-run"))
	  (exit 1)))))
 ((args:get-arg "-test")
  (let ((testid (string->number (args:get-arg "-test"))))
    (if (and (number? testid)
    (if testid
	     (>= testid 0))
	(examine-test testid)
	(begin
	  (print "ERROR: testid is not a number " (args:get-arg "-test"))
	  (debug:print 3 "INFO: tried to open test with invalid test-id. " (args:get-arg "-test"))
	  (exit 1)))))
 ((args:get-arg "-guimonitor")
  (gui-monitor *db*))
 (else
  (set! uidat (make-dashboard-buttons *num-runs* *num-tests* *dbkeys*))
  (iup:callback-set! *tim*
		     "ACTION_CB"
︙

Modified launch.scm from [67cde5b85f] to [3754524a5c].

︙
88
89
90
91
92
93
94
95

96
97
98
99
100
101
102

88
89
90
91
92
93
94

95
96
97
98
99
100
101
102








-
+








                                              runscript))))) ;; assume it is on the path
	       (rollup-status 0))
	  (change-directory top-path)
	  (debug:print 2 "Exectuing " test-name " (id: " test-id ") on " (get-host-name))
	  ;; Setup the *runremote* global var
	  (if *runremote* (debug:print 2 "ERROR: I'm not expecting *runremote* to be set at this time"))
	  ;; (set! *runremote* runremote)
	  (set! *transport-type* (string->symbol transport))
	  ;; (set! *transport-type* (string->symbol transport))
	  (set! keys       (cdb:remote-run db:get-keys #f))
	  (set! keyvals    (keys:target->keyval keys target))
	  ;; apply pre-overrides before other variables. The pre-override vars must not
	  ;; clobbers things from the official sources such as megatest.config and runconfigs.config
	  (if (string? set-vars)
	      (let ((varpairs (string-split set-vars ",")))
		(debug:print 4 "varpairs: " varpairs)
︙

Modified megatest.scm from [a185db2b11] to [eaedd380e0].

︙
252
253
254
255
256
257
258
259
260
261
262




263
264
265
266
267
268
269

252
253
254
255
256
257
258




259
260
261
262
263
264
265
266
267
268
269








-
-
-
-
+
+
+
+








    (begin
      (print megatest-version)
      (exit)))

(define *didsomething* #f)

;; Force default transport to fs
(if ;; (and (or (args:get-arg "-list-targets")
    ;;          (args:get-arg "-list-db-targets"))
 (not (args:get-arg "-transport"))
 (hash-table-set! args:arg-hash "-transport" "fs"))
;; (if ;; (and (or (args:get-arg "-list-targets")
;;     ;;          (args:get-arg "-list-db-targets"))
;;  (not (args:get-arg "-transport"))
;;  (hash-table-set! args:arg-hash "-transport" "fs"))

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

(debug:setup)
︙
312
313
314
315
316
317
318

319

320
321
322
323
324
325



326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364















































365
366
367
368
369
370
371

312
313
314
315
316
317
318
319

320
321
322




323
324
325
326
327
328
329
330
331
332
333































334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387








+
-
+


-
-
-
-
+
+
+








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








	  (transport (or (configf:lookup *configdat* "setup" "transport")
			 (args:get-arg "-transport" "http"))))
      (debug:print 2 "Launching server using transport " transport)
      (server:launch (string->symbol transport)))

    ;; Not a server? This section will decide how to communicate
    ;;
    ;;  Setup client for all expect listed here
    (if (not (null? (lset-intersection 
    (if (null? (lset-intersection 
		     equal?
		     (hash-table-keys args:arg-hash)
		     '("-runtests"    "-list-runs"   "-rollup"
		       "-remove-runs" "-lock"        "-unlock"
		       "-update-meta" "-extract-ods" "-list-servers"
		       "-stop-server" "-show-cmdinfo"))))
		     '("-list-servers"
		       "-stop-server"
		       "-show-cmdinfo")))
	(if (setup-for-run)
	    (begin

	      ;; if not list or kill then start a client (if appropriate)
	      (if (or (args-defined? "-h" "-version" "-gen-megatest-area" "-gen-megatest-test")
		      (eq? (length (hash-table-keys args:arg-hash)) 0))
		  (debug:print-info 1 "Server connection not needed")
		  ;; ok, so lets connect to the server
		  (let ((transport-from-config   (configf:lookup *configdat* "setup" "transport"))
			(transport-from-cmdln    (args:get-arg "-transport"))
			(transport-from-cmdinfo  (if (getenv "MT_CMDINFO")
						     (assoc 'transport 
							    (read (open-input-string (base64:base64-decode
										      (getenv "MT_CMDINFO")))))
						     #f)))
		    (cond
		     ;; command line overrides other mechanisms
		     (transport-from-cmdln
		      (if (equal? transport-from-cmdln "fs")
			  (set! *transport-type* 'fs)
			  (begin
			    (server:ensure-running)
			    (client:launch))))
		     ;; cmdinfo is second priority
		     (transport-from-cmdinfo
		      (if (equal? transport-from-cmdinfo "fs")
			  (set! *transport-type* 'fs)
			  (begin
			    (server:ensure-running)
			    (client:launch))))
		     ;; config file is next highest priority for determinining transport
		     (transport-from-config
		      (if (equal? transport-from-config "fs")
			  (set! *transport-type* 'fs)
			  (begin
			    (server:ensure-running)
			    (client:launch))))
		     (else
		      (set! *transport-type* 'fs)))))))))
		  (let* ((transport-from-config   (configf:lookup *configdat* "setup" "transport"))
			 (transport-from-cmdln    (args:get-arg "-transport"))
			 (transport-from-cmdinfo  (if (getenv "MT_CMDINFO")
						      (let ((res (assoc 'transport 
									(read
									 (open-input-string 
									  (base64:base64-decode
									   (getenv "MT_CMDINFO")))))))
							(if res (cadr res) #f))
						      #f))
			 (chosen-transport        (string->symbol (or transport-from-cmdln
								      transport-from-cmdinfo
								      transport-from-config
								      "fs"))))
		    (debug:print 0 "chosen-transport: " chosen-transport " have; config=" transport-from-config ", cmdln=" transport-from-cmdln ", cmdinfo=" transport-from-cmdinfo)
		    (case chosen-transport
		      ((http)
		       (set! *transport-type 'http)
		       (server:ensure-running)
		       (client:launch))
		      (else ;; (fs)
		       (set! *transport-type* 'fs)
		       (set! *megatest-db* (open-db))))))))))
;; 		    (cond
;; 		     ;; command line overrides other mechanisms
;; 		     (transport-from-cmdln
;; 		      (if (equal? transport-from-cmdln "fs")
;; 			  (set! *transport-type* 'fs)
;; 			  (begin
;; 			    (server:ensure-running)
;; 			    (client:launch))))
;; 		     ;; cmdinfo is second priority
;; 		     (transport-from-cmdinfo
;; 		      (if (equal? transport-from-cmdinfo "fs")
;; 			  (set! *transport-type* 'fs)
;; 			  (begin
;; 			    (server:ensure-running)
;; 			    (client:launch))))
;; 		     ;; config file is next highest priority for determinining transport
;; 		     (transport-from-config
;; 		      (if (equal? transport-from-config "fs")
;; 			  (set! *transport-type* 'fs)
;; 			  (begin
;; 			    (server:ensure-running)
;; 			    (client:launch))))
;; 		     (else
;; 		      (set! *transport-type* 'fs)))))))))

(if (or (args:get-arg "-list-servers")
	(args:get-arg "-stop-server"))
    (let ((tl (setup-for-run)))
      (if tl 
	  (let* ((servers (open-run-close tasks:get-all-servers tasks:open-db))
		 (fmtstr  "~5a~12a~8a~20a~24a~10a~10a~10a~10a\n")
︙
710
711
712
713
714
715
716
717

718
719
720
721
722
723
724

726
727
728
729
730
731
732

733
734
735
736
737
738
739
740








-
+








	       (db        #f)
	       (state     (args:get-arg ":state"))
	       (status    (args:get-arg ":status"))
	       (target    (args:get-arg "-target"))
	       (toppath   (assoc/default 'toppath   cmdinfo)))
	  (change-directory toppath)
	  ;; (set! *runremote* runremote)
	  (set! *transport-type* (string->symbol transport))
	  ;; (set! *transport-type* (string->symbol transport))
	  (if (not target)
	      (begin
		(debug:print 0 "ERROR: -target is required.")
		(exit 1)))
	  (if (not (setup-for-run))
	      (begin
		(debug:print 0 "Failed to setup, giving up on -test-paths or -test-files, exiting")
︙
761
762
763
764
765
766
767
768

769
770
771
772
773
774
775

777
778
779
780
781
782
783

784
785
786
787
788
789
790
791








-
+








	       (itemdat   (assoc/default 'itemdat   cmdinfo))
	       (db        #f)
	       (state     (args:get-arg ":state"))
	       (status    (args:get-arg ":status"))
	       (target    (args:get-arg "-target")))
	  (change-directory testpath)
	  ;; (set! *runremote* runremote)
	  (set! *transport-type* (string->symbol transport))
	  ;; (set! *transport-type* (string->symbol transport))
	  (if (not target)
	      (begin
		(debug:print 0 "ERROR: -target is required.")
		(exit 1)))
	  (if (not (setup-for-run))
	      (begin
		(debug:print 0 "Failed to setup, giving up on -archive, exiting")
︙
842
843
844
845
846
847
848

849

850
851
852
853
854
855
856

858
859
860
861
862
863
864
865

866
867
868
869
870
871
872
873








+
-
+








	     (run-id    (assoc/default 'run-id    cmdinfo))
	     (test-id   (assoc/default 'test-id   cmdinfo))
	     (itemdat   (assoc/default 'itemdat   cmdinfo))
	     (work-area (assoc/default 'work-area cmdinfo))
	     (db        #f))
	(change-directory testpath)
	;; (set! *runremote* runremote)
	;; The transport is handled earlier in the loading process of megatest.
	(set! *transport-type* (string->symbol transport))
	;; (set! *transport-type* (string->symbol transport))
	(if (not (setup-for-run))
	    (begin
	      (debug:print 0 "Failed to setup, exiting")
	      (exit 1)))
	(if (and state status)
	    ;; DO NOT remote run, makes calls to the testdat.db test db.
	    (db:teststep-set-status! db test-id step state status msg logfile work-area: work-area)
︙
894
895
896
897
898
899
900
901

902
903
904
905
906
907
908

911
912
913
914
915
916
917

918
919
920
921
922
923
924
925








-
+








	       (test-id   (assoc/default 'test-id   cmdinfo))
	       (itemdat   (assoc/default 'itemdat   cmdinfo))
	       (work-area (assoc/default 'work-area cmdinfo))
	       (db        #f) ;; (open-db))
	       (state     (args:get-arg ":state"))
	       (status    (args:get-arg ":status")))
	  ;; (set! *runremote* runremote)
	  (set! *transport-type* (string->symbol transport))
	  ;; (set! *transport-type* (string->symbol transport))
	  (if (not (setup-for-run))
	      (begin
		(debug:print 0 "Failed to setup, exiting")
		(exit 1)))

	  (if (args:get-arg "-runstep")(debug:print-info 1 "Running -runstep, first change to directory " work-area))
	  (change-directory work-area)
︙

Modified server.scm from [8151d68998] to [b6cfd8a4e3].

︙
127
128
129
130
131
132
133

134

135
136
137
138
139
140
141

127
128
129
130
131
132
133
134

135
136
137
138
139
140
141
142








+
-
+








	(begin
	  (if (even? trycount) ;; just do the server start every other time through this loop (every 8 seconds)
	      (begin
		(debug:print 0 "INFO: Starting server as none running ...")
		;; (server:launch (string->symbol (args:get-arg "-transport" "http"))))
		;; no need to use fork, no need to do the list-servers trick. Just start the damn server, it will exit on it's own
		;; if there is an existing server
		(system (conc (if (getenv "MT_MEGATEST") (getenv "MT_MEGATEST") "megatest")
		(system "megatest -server - -daemonize")
			      " -server - -daemonize"))
		(thread-sleep! 3)
		;; (process-run (car (argv)) (list "-server" "-" "-daemonize" "-transport" (args:get-arg "-transport" "http")))
		;; (system (conc "megatest -list-servers | egrep '" megatest-version ".*alive' || megatest -server - -daemonize && sleep 3"))
		;; (process-fork (lambda ()
		;;       	  (daemon:ize)
		;;       	  (server:launch (string->symbol (args:get-arg "-transport" "http")))))
		)
︙

Modified tasks.scm from [d74494eba8] to [4666e559d1].

︙
197
198
199
200
201
202
203
204





205
206
207
208
209
210
211
212
213

214

215
216
217
218
219
220
221

197
198
199
200
201
202
203

204
205
206
207
208
209
210
211
212
213
214
215
216
217
218

219
220
221
222
223
224
225
226








-
+
+
+
+
+









+
-
+








(define (tasks:have-clients? mdb server-id)
  (null? (tasks:get-logged-in-clients mdb server-id)))

;; ping each server in the db and return first found that responds. 
;; remove any others. will not necessarily remove all!
(define (tasks:get-best-server mdb)
  (let ((res '())
	(best #f))
	(best #f)
	(transport (if (and *transport-type*
			    (not (eq? *transport-type* 'fs)))
		       (conc *transport-type*)
		       "%")))
    (sqlite3:for-each-row
     (lambda (id interface port pubport transport pid hostname)
       (set! res (cons (vector id interface port pubport transport pid hostname) res))
       ;;(debug:print-info 2 "Found existing server " hostname ":" port " registered in db"))
       )
     mdb
     
     "SELECT id,interface,port,pubport,transport,pid,hostname FROM servers
          WHERE strftime('%s','now')-heartbeat < 10 
          AND mt_version=? AND transport LIKE ? 
          AND mt_version=? ORDER BY start_time DESC LIMIT 1;" (common:version-signature))
          ORDER BY start_time DESC LIMIT 1;" (common:version-signature) transport)
    ;; for now we are keeping only one server registered in the db, return #f or first server found
    (if (null? res) #f (car res))))

;; BUG: This logic is probably needed unless methodology changes completely...
;;
;;     (if (null? res) #f
;; 	(let loop ((hed (car res))
︙

Modified tests/Makefile from [c07bc6a6e8] to [602052bbdd].

︙
145
146
147
148
149
150
151
152




153
154
155
156
157
158
159

145
146
147
148
149
150
151

152
153
154
155
156
157
158
159
160
161
162








-
+
+
+
+








	touch cleanprep

fullprep : cleanprep
	cd fullrun;$(MEGATEST) -remove-runs :runname $(RUNNAME)% -target %/%/% -testpatt %/%
	cd fullrun;$(BINPATH)/dashboard -rows 15 &

dashboard : cleanprep
	cd fullrun && $(BINPATH)/dashboard -rows 25 &
	cd fullrun && $(BINPATH)/dashboard -transport fs -rows 20 &

dashboard-http : cleanprep
	cd fullrun && $(BINPATH)/dashboard -transport http -rows 20 &

remove :
	cd fullrun;$(MEGATEST) -remove-runs :runname $(RUN)  -testpatt % -itempatt % :sysname % :fsname % :datapath %

clean  : 
	rm cleanprep
︙

This page was generated in about 0.107s by Fossil 2.24 [452f8e1ffc] 2024-03-26 15:36:00