Megatest

Check-in [d24a0f4c43]
Login
Overview
Comment:Login/logout list and kill working nicely
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | monitor-cleanup
Files: files | file ages | folders
SHA1: d24a0f4c434f2d2db413d1c394c3c0fdac1b59b6
User & Date: mrwellan on 2012-10-31 17:03:27
Other Links: branch diff | manifest | tags
Context
2012-10-31
21:16
Converting the server receive works. check-in: ea995f8a70 user: matt tags: monitor-cleanup
17:17
Switched to receive-message* which supposedly does not block chicken threads check-in: f3b8ce03c9 user: mrwellan tags: defunct-try-of-non-blocking-receive
17:03
Login/logout list and kill working nicely check-in: d24a0f4c43 user: mrwellan tags: monitor-cleanup
14:31
Got remote login with client signature and login key working check-in: 05e3308da2 user: mrwellan tags: monitor-cleanup
Changes

Modified db.scm from [7361e51af6] to [8e7dce497a].

1118
1119
1120
1121
1122
1123
1124


1125
1126
1127
1128
1129
1130
1131
1132
1133
1134

1135
1136
1137
1138
1139
1140
1141
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135

1136
1137
1138
1139
1140
1141
1142
1143







+
+









-
+







		     (list #f (conc "Login failed due to mismatch paths: " calling-path ", " *toppath*))))))
	  ((logout)
	   (if (and (> (length remparam) 1)
		    (eq? *toppath* (car remparam))
		    (hash-table-ref/default *logged-in-clients* (cadr remparam) #f))
	       #t
	       #f))
	  ((numclients)
	   (length (hash-table-keys *logged-in-clients*)))
	  ((flush)
	   (db:write-cached-data)
	   #t)
	  ((immediate)
	   (db:write-cached-data)
	   (if (not (null? remparam))
	       (apply (car remparam) (cdr remparam))
	       "ERROR"))
	  ((killserver)
	   (db:write-cached-data)
	   ;; (db:write-cached-data)
	   (debug:print-info 0 "Remotely killed server on host " (get-host-name) " pid " (current-process-id))
	   (set! *time-to-exit* #t)
	   #t)
	  ((set-verbosity)
	   (set! *verbosity* (caddr params))
	   *verbosity*)
	  ((get-verbosity)
1177
1178
1179
1180
1181
1182
1183



1184
1185
1186
1187
1188
1189
1190
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195







+
+
+








(define (cdb:login zmq-socket keyval signature)
  (cdb:client-call zmq-socket 'login #t keyval signature))

(define (cdb:logout zmq-socket keyval signature)
  (cdb:client-call zmq-socket 'logout #t keyval signature))

(define (cdb:num-clients zmq-socket)
  (cdb:client-call zmq-socket 'numclients #t))

(define (cdb:test-set-status-state zmqsocket test-id status state msg)
  (if msg
      (cdb:client-call zmqsocket 'state-status-msg #t state status msg test-id)
      (cdb:client-call zmqsocket 'state-status #t state status test-id))) ;; run-id test-name item-path minutes cpuload diskfree tmpfree) 

(define (cdb:test-rollup-test_data-pass-fail zmqsocket test-id)
  (cdb:client-call zmqsocket 'test_data-pf-rollup #t test-id test-id test-id test-id))

Modified megatest.scm from [75cecfeb9c] to [786a96adc0].

94
95
96
97
98
99
100
101

102
103
104
105
106
107
108
94
95
96
97
98
99
100

101
102
103
104
105
106
107
108







-
+







  -update-meta            : update the tests metadata for all tests
  -env2file fname         : write the environment to fname.csh and fname.sh
  -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
  -listservers            : list the servers 
  -killserver host:port|pid : kill server specified by host:port or pid, use % to kill all
  -killserver host:port|pid : kill server specified by host:port or pid
  -repl                   : start a repl (useful for extending megatest)

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
270
271
272
273
274
275
276
277
278
279




280
281



282

283
284
285
286
287
288

289
290
291



292
293
294





295
296













297
298

299
300
301
302


303
304

305
306
307
308
309
310
311
270
271
272
273
274
275
276



277
278
279
280
281
282
283
284
285

286
287
288
289
290
291
292
293



294
295
296
297
298
299
300
301
302
303
304


305
306
307
308
309
310
311
312
313
314
315
316
317
318

319
320
321


322
323
324

325
326
327
328
329
330
331
332







-
-
-
+
+
+
+


+
+
+
-
+






+
-
-
-
+
+
+



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

-
+


-
-
+
+

-
+







      (server:launch)))

(if (or (args:get-arg "-listservers")
	(args:get-arg "-killserver"))
    (let ((tl (setup-for-run)))
      (if tl 
	  (let ((servers (open-run-close tasks:get-all-servers tasks:open-db))
		(fmtstr  "~5a~8a~20a~5a~20a~9a~10a\n"))
	    (format #t fmtstr "Id" "Pid" "Host" "Port" "Time" "Priority" "State")
	    (format #t fmtstr "==" "===" "====" "====" "====" "========" "=====")
		(fmtstr  "~5a~8a~20a~5a~20a~9a~20a~5a\n")
		(servers-to-kill '()))
	    (format #t fmtstr "Id" "Pid" "Host" "Port" "Time" "Priority" "State" "Num Clients")
	    (format #t fmtstr "==" "===" "====" "====" "====" "========" "=====" "===========")
	    (for-each 
	     (lambda (server)
	       (let* ((killinfo   (args:get-arg "-killserver"))
		      (khost-port (if killinfo (if (substring-index ":" killinfo)(string-split ":") #f) #f))
		      (kpid       (if killinfo (if (substring-index ":" killinfo) #f (string->number killinfo)) #f))
	       (let* ((id         (vector-ref server 0))
		      (id         (vector-ref server 0))
		      (pid        (vector-ref server 1))
		      (hostname   (vector-ref server 2))
		      (port       (vector-ref server 3))
		      (start-time (vector-ref server 4))
		      (priority   (vector-ref server 5))
		      (state      (vector-ref server 6))
		      (numclients #f)
		      (status     (handle-exceptions
				   exn
				   (conc "EXCEPTION: " ((condition-property-accessor 'exn 'message) exn))
		      (stat-numc  ;; (handle-exceptions
				  ;;  exn
				  ;;  (list #f (conc "EXCEPTION: " ((condition-property-accessor 'exn 'message) exn)))
				   (let ((zmq-socket (server:client-connect hostname port)))
				     (if zmq-socket
					 (if (server:client-login zmq-socket)
					     (let ((numclients (cdb:num-clients zmq-socket))
						   (killed     #f))
					       (if (and khost-port ;; kill by host/port
							(equal? hostname (car khost-port))
							(equal? port (string->number (cadr khost-port))))
					     (begin
					       (server:client-logout zmq-socket)
						   (begin
						     (open-run-close tasks:server-deregister tasks:open-db  hostname port: port)
						     (cdb:kill-server zmq-socket)
						     (debug:print-info 1 "Killed server by host:port at " hostname ":" port)
						     (set! killed #t))
						   (if (and kpid
							    (equal? kpid pid))
						       (begin
							 (open-run-close tasks:server-deregister tasks:open-db hostname pid: pid)
							 (set! killed #t)
							 (cdb:kill-server zmq-socket)
							 (debug:print-info 1 "Killed server by pid at " hostname ":" port))))
					       (if (not killed)(server:client-logout zmq-socket))
					       (close-socket  zmq-socket)
					       "ACCESSIBLE") ;; (server:client-logout zmq-socket)
					       (list numclients "ACCESSIBLE")) ;; (server:client-logout zmq-socket)
					     (begin
					       (close-socket zmq-socket)
					       "CAN'T LOGIN"))
					 "CAN'T CONNECT")))))
					       (list #f "CAN'T LOGIN")))
					 (list #f "CAN'T CONNECT"))))) ;; )
		 (format #t fmtstr id pid hostname port start-time priority 
			 status)))
			 (cadr stat-numc)(car stat-numc))))
	     servers)
	    (set! *didsomething* #t))))
    ;; if not list or kill then start a client (if appropriate)
    (if (or (let ((res #f))
	      (for-each
	       (lambda (key)
		 (if (args:get-arg key)(set! res #t)))

Modified server.scm from [db67acb83d] to [2fc90a75bd].

65
66
67
68
69
70
71
72
73







74
75
76
77
78
79
80
65
66
67
68
69
70
71


72
73
74
75
76
77
78
79
80
81
82
83
84
85







-
-
+
+
+
+
+
+
+







      (let* ((rawmsg (receive-message zmq-socket))
	     (params (db:string->obj rawmsg)) ;; (with-input-from-string rawmsg (lambda ()(deserialize))))
	     (res    #f))
	(debug:print-info 12 "server=> received params=" params)
	(set! res (cdb:cached-access params))
	(debug:print-info 12 "server=> processed res=" res)
	(send-message zmq-socket (db:obj->string res))
	(if *time-to-exit* (exit))
	(loop)))))
	(if (not *time-to-exit*)
	    (loop)
	    (begin
	      (db:write-cached-data)
	      (open-run-close tasks:server-deregister-self tasks:open-db)
	      (exit)
	      ))))))

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

Modified tasks.scm from [bda0d3a691] to [d0c7d4c2b8].

77
78
79
80
81
82
83

84
85
86
87
88
89
90
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91







+







(define (tasks:server-register mdb pid hostname port priority state)
  (sqlite3:execute 
   mdb 
   "INSERT OR REPLACE INTO servers (pid,hostname,port,start_time,priority,state) VALUES(?,?,?,strftime('%s','now'),?,?);"
   pid hostname port priority (conc state)))

(define (tasks:server-deregister mdb hostname #!key (port #f)(pid #f))
  (debug:print-info 11 "server-deregister " hostname ", port " port ", pid " pid)
  (if pid
      (sqlite3:execute mdb "DELETE FROM servers WHERE  hostname=? AND pid=?;" hostname pid)
      (if port
	  (sqlite3:execute mdb "DELETE FROM servers WHERE  hostname=? AND port=?;" hostname port)
	  (debug:print 0 "ERROR: tasks:server-deregister called with neither pid nor port specified"))))

(define (tasks:server-deregister-self mdb)