Megatest

Check-in [cb5f28cabe]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Moved ping of server into a separate process
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.60
Files: files | file ages | folders
SHA1: cb5f28cabe6931befbcff5e8602945d661c5c4bd
User & Date: matt on 2014-02-26 23:42:45
Other Links: branch diff | manifest | tags
Context
2014-02-26
23:54
Merged from v1.55. Included bump of IUP versions in installall.sh check-in: e97934c675 user: matt tags: v1.60
23:42
Moved ping of server into a separate process check-in: cb5f28cabe user: matt tags: v1.60
14:36
Partial fix to server start issue (breaks startup when db contains dead server). check-in: 05fa3869fb user: mrwellan tags: v1.60
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified Makefile from [ac2c437624] to [86daa05281]. 

1
2
3
4
5
6
7
8
9

10
11
12
13
14
15
16

1
2
3
4
5
6
7
8

9
10
11
12
13
14
15
16









-
+








# make install CSCOPTS='-accumulate-profile -profile-name $(PWD)/profile-ww$(shell date +%V.%u)'
PREFIX=$(PWD)
CSCOPTS= 
INSTALL=install
SRCFILES = common.scm items.scm launch.scm \
           ods.scm runconfig.scm server.scm configf.scm \
           db.scm keys.scm margs.scm megatest-version.scm \
           process.scm runs.scm tasks.scm tests.scm genexample.scm \
	   fs-transport.scm http-transport.scm filedb.scm \
	   http-transport.scm filedb.scm \
           client.scm gutils.scm synchash.scm daemon.scm mt.scm dcommon.scm \
	   tree.scm ezsteps.scm lock-queue.scm sdb.scm \
	   rmt.scm api.scm tdb.scm

GUISRCF  = dashboard-tests.scm dashboard-guimonitor.scm 

OFILES   = $(SRCFILES:%.scm=%.o)
︙

Modified client.scm from [dd7ce02868] to [ac9cc63d23].

︙
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
100
101

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

100
101
102
103
104
105
106
107








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



















-
-
-
+
+
+
+

+
+
-
+








  (debug:print 0 "INFO: client:setup remaining-tries=" remaining-tries)
  (if (<= remaining-tries 0)
      (begin
	(debug:print 0 "ERROR: failed to start or connect to server for run-id " run-id)
	(exit 1))
      (let ((host-info (hash-table-ref/default *runremote* run-id #f)))
	(if host-info
	    (let ((start-res (http-transport:client-connect run-id ;; NB// confusion over host-info and connection result!
							    (car  host-info)
							    (cadr host-info))))
	      (if start-res ;; sucessful login?
		  start-res
	    (let* ((iface     (car  host-info))
		   (port      (cadr host-info))
		   (start-res (http-transport:client-connect iface port))
		   (ping-res  (server:ping-server run-id iface port)))
	      (if ping-res   ;; sucessful login?
		  (begin
		    (hash-table-set! *runremote* run-id start-res)
		    start-res)  ;; return the server info
		  (if (member remaining-tries '(3 4 6))
		      (begin    ;; login failed
			(debug:print 25 "INFO: client:setup start-res=" start-res ", run-id=" run-id ", server-dat=" host-info)
			(hash-table-delete! *runremote* run-id)
			(open-run-close tasks:server-force-clean-run-record
			 		tasks:open-db
			 		run-id 
			 		(car  host-info)
			 		(cadr host-info)
					" client:setup (host-info=#t)")
			(thread-sleep! 5)
			(client:setup run-id remaining-tries: 10)) ;; (- remaining-tries 1)))
		      (begin
			(debug:print 25 "INFO: client:setup failed to connect, start-res=" start-res ", run-id=" run-id ", host-info=" host-info)
			(thread-sleep! 5)
			(client:setup run-id remaining-tries: (- remaining-tries 1))))))
	    ;; YUK: rename server-dat here
	    (let* ((server-dat (open-run-close tasks:get-server tasks:open-db run-id)))
	      (if server-dat
		  (let ((start-res (http-transport:client-connect run-id
								  (tasks:hostinfo-get-interface server-dat)
								  (tasks:hostinfo-get-port      server-dat))))
		  (let* ((iface     (tasks:hostinfo-get-interface server-dat))
			 (port      (tasks:hostinfo-get-port      server-dat))
			 (start-res (http-transport:client-connect iface port))
			 (ping-res  (server:ping-server run-id iface port)))
		    (if start-res
			(begin
			  (hash-table-set! *runremote* run-id start-res)
			start-res
			  start-res)
			(if (member remaining-tries '(2 5))
			    (begin    ;; login failed
			      (debug:print 25 "INFO: client:setup start-res=" start-res ", run-id=" run-id ", server-dat=" server-dat)
			      (hash-table-delete! *runremote* run-id)
			      (open-run-close tasks:server-force-clean-run-record
					      tasks:open-db
					      run-id
︙
123
124
125
126
127
128
129
130

131
132
133
134
135
136
137
138

129
130
131
132
133
134
135

136

137
138
139
140
141
142
143








-
+
-








				;; (open-run-close tasks:server-clean-out-old-records-for-run-id tasks:open-db run-id " client:setup (server-dat=#f)")
				(server:try-running run-id)))
			  (thread-sleep! 10) ;; give server a little time to start up
			  (client:setup run-id remaining-tries: (- remaining-tries 1)))))))))))

;; keep this as a function to ease future 
(define (client:start run-id server-info)
  (http-transport:client-connect run-id 
  (http-transport:client-connect (tasks:hostinfo-get-interface server-info)
				 (tasks:hostinfo-get-interface server-info)
				 (tasks:hostinfo-get-port server-info)))

;; client:signal-handler
(define (client:signal-handler signum)
  (handle-exceptions
   exn
   (debug:print " ... exiting ...")
︙

Modified common.scm from [8ab78fa41e] to [03bd87c740].

︙
105
106
107
108
109
110
111







112
113
114
115
116
117
118

105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125








+
+
+
+
+
+
+








  (set! *env-vars-by-run-id* (make-hash-table))
  (set! *test-id-cache*      (make-hash-table)))

;; Generic string database (normalization of sorts)
(define sdb:qry #f) ;; (make-sdb:qry)) ;;  'init #f)
;; Generic path database (normalization of sorts)
(define *fdb* #f)

;;======================================================================
;; U S E F U L   S T U F F
;;======================================================================

(define (common:get-megatest-exe)
  (if (getenv "MT_MEGATEST") (getenv "MT_MEGATEST") "megatest"))

;;======================================================================
;; S T A T E S   A N D   S T A T U S E S
;;======================================================================

(define *common:std-states*   
  '((0 "COMPLETED")
︙

Modified db.scm from [00b6a2d48b] to [4736d6ba1e].

︙
9
10
11
12
13
14
15
16

17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41

9
10
11
12
13
14
15

16


17
18
19
20



21
22
23
24

25
26


27
28
29
30
31
32
33








-
+
-
-




-
-
-




-


-
-








;;  PURPOSE.
;;======================================================================

;;======================================================================
;; Database access
;;======================================================================

(require-extension (srfi 18) extras tcp) ;;  rpc)
(require-extension (srfi 18) extras tcp)
;; (import (prefix rpc rpc:))

(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64 format)
(import (prefix sqlite3 sqlite3:))
(import (prefix base64 base64:))

;; Note, try to remove this dependency 
;; (use zmq)

(declare (unit db))
(declare (uses common))
(declare (uses keys))
(declare (uses ods))
(declare (uses fs-transport))
(declare (uses client))
(declare (uses mt))
;; (declare (uses sdb))
;; (declare (uses filedb))

(include "common_records.scm")
(include "db_records.scm")
(include "key_records.scm")
(include "run_records.scm")

(define *rundb-mutex* (make-mutex)) ;; prevent problems opening/closing rundb's
︙

Modified http-transport.scm from [80c3efc43e] to [73e18fc9d1].

︙
264
265
266
267
268
269
270
271

272
273
274
275
276
277
278
279
280
281
282
283
284
285













286
287
288
289
290
291
292

264
265
266
267
268
269
270

271
272
273












274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293








-
+


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








	 (thread-terminate! th2)
	 (debug:print-info 11 "got res=" res)
	 res)))))

;;
;; connect
;;
(define (http-transport:client-connect run-id iface port)
(define (http-transport:client-connect iface port)
  (let* ((uri-dat     (make-request method: 'POST uri: (uri-reference (conc "http://" iface ":" port "/ctrl"))))
	 (uri-api-dat (make-request method: 'POST uri: (uri-reference (conc "http://" iface ":" port "/api"))))
	 (serverdat   (list iface port uri-dat uri-api-dat))
	 (login-res   (rmt:login-no-auto-client-setup serverdat run-id)))
    (if (and (list? login-res)
	     (car login-res))
	(begin
	  (hash-table-set! *runremote* run-id serverdat)
	  (debug:print-info 2 "Logged in and connected to " iface ":" port)
	  (hash-table-set! *runremote* run-id serverdat)
	  serverdat)
	(begin
	  (debug:print-info 0 "ERROR: Failed to login or connect to " iface ":" port)
	  #f))))
	 (server-dat  (list iface port uri-dat uri-api-dat)))
;;	 (login-res   (server:ping-server run-id server-dat))) ;; login-no-auto-client-setup server-dat run-id)))
    server-dat))
;;     (if (and (list? login-res)
;; 	     (car login-res))
;; 	(begin
;; 	  (hash-table-set! *runremote* run-id server-dat)
;; 	  (debug:print-info 2 "Logged in and connected to " iface ":" port)
;; 	  (hash-table-set! *runremote* run-id server-dat)
;; 	  server-dat)
;; 	(begin
;; 	  (debug:print-info 0 "ERROR: Failed to login or connect to " iface ":" port)
;; 	  #f))))

;; run http-transport:keep-running in a parallel thread to monitor that the db is being 
;; used and to shutdown after sometime if it is not.
;;
(define (http-transport:keep-running server-id)
  ;; if none running or if > 20 seconds since 
  ;; server last used then start shutdown
︙

Modified megatest.scm from [6f634f1ef7] to [4877ac5bd9].

︙
130
131
132
133
134
135
136

137
138
139
140
141
142
143

130
131
132
133
134
135
136
137
138
139
140
141
142
143
144








+








  -daemonize              : fork into background and disconnect from stdin/out
  -list-servers           : list the servers 
  -stop-server id         : stop server specified by id (see output of -list-servers), use
                            0 to kill all
  -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

Spreadsheet generation
  -extract-ods fname.ods  : extract an open document spreadsheet from the database
  -pathmod path           : insert path, i.e. path/runame/itempath/logfile.html
                            will clear the field if no rundir/testname/itempath/logfile
                            if it contains forward slashes the path will be converted
                            to windows style
︙
205
206
207
208
209
210
211

212
213
214
215
216
217
218

206
207
208
209
210
211
212
213
214
215
216
217
218
219
220








+








			"-debug" ;; for *verbosity* > 2
			"-gen-megatest-test"
			"-override-timeout"
			"-test-files"  ;; -test-paths is for listing all
			"-load"        ;; load and exectute a scheme file
			"-dumpmode"
			"-run-id"
			"-ping"
			) 
		 (list  "-h"
			"-version"
		        "-force"
		        "-xterm"
		        "-showkeys"
		        "-show-keys"
︙
338
339
340
341
342
343
344




























345
346
347
348
349
350
351

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








+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+








	(map (lambda (x)
	       (string-intersperse 
		x
		" => "))
	     (common:get-disks) )
	"\n"))
      (set! *didsomething* #t)))

(if (args:get-arg "-ping")
    (let* ((run-id    (string->number (args:get-arg "-run-id")))
	   (host-port (let ((slst (string-split   (args:get-arg "-ping") ":")))
			(if (eq? (length slst) 2)
			    (list (car slst)(string->number (cadr slst)))
			    #f)))
	   (toppath   (setup-for-run)))
      (if (not run-id)
	  (begin
	    (debug:print 0 "ERROR: must specify run-id when doing ping, -run-id n")
	    (print "ERROR: No run-id")
	    (exit 1))
	  (if (not host-port)
	      (begin
		(debug:print 0 "ERROR: argument to -ping is host:port, got " (args:get-arg "-ping"))
		(print "ERROR: bad host:port")
		(exit 1))
	      (let* ((server-dat (http-transport:client-connect (car host-port)(cadr host-port)))
		     (login-res  (rmt:login-no-auto-client-setup server-dat run-id)))
		(if (and (list? login-res)
			 (car login-res))
		    (begin
		      (print "LOGIN_OK")
		      (exit 0))
		    (begin
		      (print "LOGIN_FAILED")
		      (exit 1))))))))

;;======================================================================
;; Start the server - can be done in conjunction with -runall or -runtests (one day...)
;;   we start the server if not running else start the client thread
;;======================================================================

(if (args:get-arg "-server")
︙

Name change from fs-transport.scm to oldsrc/fs-transport.scm.

︙

Name change from zmq-transport.scm to oldsrc/zmq-transport.scm.

︙

Modified server.scm from [c4fc1a172b] to [978e83bfc8].

︙
78
79
80
81
82
83
84
85

86
87
88
89
90
91
92

78
79
80
81
82
83
84

85
86
87
88
89
90
91
92








-
+









;; Given a run id start a server process    ### NOTE ### > file 2>&1 
;; if the run-id is zero and the target-host is set 
;; try running on that host
;;
(define  (server:run run-id)
  (let* ((target-host (configf:lookup *configdat* "server" "homehost" ))
	 (cmdln (conc (if (getenv "MT_MEGATEST") (getenv "MT_MEGATEST") "megatest")
	 (cmdln (conc (common:get-megatest-exe)
		      " -server - -run-id " run-id " >> " *toppath* "/db/" run-id ".log 2>&1 &")))
    (debug:print 0 "INFO: Starting server (" cmdln ") as none running ...")
    (push-directory *toppath*)
    (if target-host
	(begin
	  (set-environment-variable "TARGETHOST" target-host)
	  (system (conc "nbfake " cmdln)))
︙
125
126
127
128
129
130
131














125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144








+
+
+
+
+
+
+
+
+
+
+
+
+

	  (if res
	      res
	      (begin
		(open-run-close tasks:server-force-clean-running-records-for-run-id tasks:open-db run-id 
				" server:check-if-running")
		res)))
	#f)))

(define (server:ping-server run-id iface port)
  (with-input-from-pipe 
   (conc (common:get-megatest-exe) " -run-id " run-id " -ping " (conc iface ":" port))
   (lambda ()
     (let loop ((inl (read-line))
		(res "NOREPLY"))
       (if (eof-object? inl)
	   (case (string->symbol res)
	     ((NOREPLY)  #f)
	     ((LOGIN_OK) #t)
	     (else       #f))
	   (loop (read-line) inl))))))

Modified tasks.scm from [b27552d9de] to [677b9b3c1c].

︙
270
271
272
273
274
275
276
277

278
279
280
281
282
283
284

270
271
272
273
274
275
276

277
278
279
280
281
282
283
284








-
+








	     (thread-sleep! 5) ;; give it five seconds to die peacefully then do a brutal kill
	     ;;(process-signal pid signal/kill)
	     ) ;; local machine, send sig term
	    (begin
	      ;;(debug:print-info 1 "Stopping remote servers not yet supported."))))
	      (debug:print-info 1 "Telling alive server on " hostname ":" port " to commit servercide")
	      (let ((serverdat (list hostname port)))
		(http-transport:client-connect hostname port)
		(hash-table-set! *runremote* run-id (http-transport:client-connect hostname port))
	      	(cdb:kill-server serverdat pid)))))    ;; remote machine, try telling server to commit suicide
      (begin
	(if status 
	    (if (equal? hostname (get-host-name))
		(begin
		  (debug:print-info 1 "Sending signal/term to " pid " on " hostname)
		  (process-signal pid signal/term)  ;; local machine, send sig term
︙

Modified tdb.scm from [076079f36f] to [fd0c5aa4a1].

︙
9
10
11
12
13
14
15
16

17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37

9
10
11
12
13
14
15

16


17
18
19
20



21
22
23
24

25
26
27
28
29
30
31








-
+
-
-




-
-
-




-








;;  PURPOSE.
;;======================================================================

;;======================================================================
;; Database access
;;======================================================================

(require-extension (srfi 18) extras tcp) ;;  rpc)
(require-extension (srfi 18) extras tcp)
;; (import (prefix rpc rpc:))

(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64)
(import (prefix sqlite3 sqlite3:))
(import (prefix base64 base64:))

;; Note, try to remove this dependency 
;; (use zmq)

(declare (unit tdb))
(declare (uses common))
(declare (uses keys))
(declare (uses ods))
(declare (uses fs-transport))
(declare (uses client))
(declare (uses mt))

(include "common_records.scm")
(include "db_records.scm")
(include "key_records.scm")
(include "run_records.scm")
︙

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