Megatest
Check-in [7f668b637d]
Not logged in
Overview
SHA1:7f668b637dd79f8557ca79226e9fc630300b6067
Date: 2011-05-05 18:35:21
User: mrwellan
Comment:Added stuck test handling
Timelines: family | ancestors | descendants | both | trunk
Downloads: Tarball | ZIP archive
Other Links: files | file ages | folders | manifest
Tags And Properties
Context
2011-05-05
22:50
[874a4143eb] Typo in dashboard (user: matt, tags: trunk)
18:35
[7f668b637d] Added stuck test handling (user: mrwellan, tags: trunk)
10:12
[ad05ecc7d8] Bumped version to 1.02 (user: matt, tags: trunk)
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Modified dashboard.scm from [43e9dd636e] to [d12532b941].

93
94
95
96
97
98
99



100
101
102
103
104
105
106
...
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
...
257
258
259
260
261
262
263


264
265
266
267
268
269

270
271
272
273
274
275
276



277
278
279
280
281
282
283
	       (rundir       (db:test-get-rundir test))
	       (testname     (db:test-get-testname   test))
	       (itempath     (db:test-get-item-path test))
	       (testfullname (runs:test-get-full-path test))
	       (currstatus   (db:test-get-status test))
	       (currstate    (db:test-get-state  test))
	       (currcomment  (db:test-get-comment test))



	       (logfile      (conc (db:test-get-rundir test) "/" (db:test-get-final_logf test)))
	       (viewlog      (lambda (x)
			       (if (file-exists? logfile)
				   (system (conc "firefox " logfile "&"))
				   (message-window (conc "File " logfile " not found")))))
	       (xterm        (lambda (x)
			       (if (directory-exists? rundir)
................................................................................
				(iup:label "STATE:" #:size "30x")
				(let ((lb (iup:listbox #:action (lambda (val a b c)
								  ;; (print val " a: " a " b: " b " c: " c)
								  (set! newstate a))
						       #:editbox "YES"
						       #:expand "YES")))
				  (iuplistbox-fill-list lb
							(list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "KILLED" "KILLREQ")
							currstate)
				  lb))
			       (iup:vbox ;; the status
				(iup:label "STATUS:" #:size "30x")
				(let ((lb (iup:listbox #:action (lambda (val a b c)
								  (set! newstatus a))
						       #:editbox "YES"
................................................................................
					     (car matching))))
			   ;; (test       (if real-test real-test
			   (testname   (db:test-get-testname  test))
			   (itempath   (db:test-get-item-path test))
			   (testfullname (test:test-get-fullname test))
			   (teststatus (db:test-get-status   test))
			   (teststate  (db:test-get-state    test))


			   (buttontxt  (if (equal? teststate "COMPLETED") teststatus teststate))
			   (button     (vector-ref columndat rown))
			   (color      (case (string->symbol teststate)
					 ((COMPLETED)
					  (if (equal? teststatus "PASS") "70 249 73" "223 33 49")) ;; greenish redish
					 ((LAUNCHED)         "101 123 142")

					 ((REMOTEHOSTSTART)  "50 130 195")
					 ((RUNNING)          "9 131 232")
					 ((KILLREQ)          "39 82 206")
					 ((KILLED)           "234 101 17")
					 (else "192 192 192")))
			   (curr-color (vector-ref buttondat 1)) ;; (iup:attribute button "BGCOLOR"))
			   (curr-title (vector-ref buttondat 2))) ;; (iup:attribute button "TITLE")))



		      (if (not (equal? curr-color color))
			  (iup:attribute-set! button "BGCOLOR" color))
		      (if (not (equal? curr-title buttontxt))
			  (iup:attribute-set! button "TITLE"   buttontxt))
		      (vector-set! buttondat 0 run-id)
		      (vector-set! buttondat 1 color)
		      (vector-set! buttondat 2 buttontxt)







>
>
>







 







|







 







>
>






>







>
>
>







93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
...
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
...
260
261
262
263
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
	       (rundir       (db:test-get-rundir test))
	       (testname     (db:test-get-testname   test))
	       (itempath     (db:test-get-item-path test))
	       (testfullname (runs:test-get-full-path test))
	       (currstatus   (db:test-get-status test))
	       (currstate    (db:test-get-state  test))
	       (currcomment  (db:test-get-comment test))
	       (host         (db:test-get-host test))
	       (cpuload      (db:test-get-cpuload test))
	       (runtime      (db:test-get-run)duration test)
	       (logfile      (conc (db:test-get-rundir test) "/" (db:test-get-final_logf test)))
	       (viewlog      (lambda (x)
			       (if (file-exists? logfile)
				   (system (conc "firefox " logfile "&"))
				   (message-window (conc "File " logfile " not found")))))
	       (xterm        (lambda (x)
			       (if (directory-exists? rundir)
................................................................................
				(iup:label "STATE:" #:size "30x")
				(let ((lb (iup:listbox #:action (lambda (val a b c)
								  ;; (print val " a: " a " b: " b " c: " c)
								  (set! newstate a))
						       #:editbox "YES"
						       #:expand "YES")))
				  (iuplistbox-fill-list lb
							(list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "KILLED" "KILLREQ" "CHECK")
							currstate)
				  lb))
			       (iup:vbox ;; the status
				(iup:label "STATUS:" #:size "30x")
				(let ((lb (iup:listbox #:action (lambda (val a b c)
								  (set! newstatus a))
						       #:editbox "YES"
................................................................................
					     (car matching))))
			   ;; (test       (if real-test real-test
			   (testname   (db:test-get-testname  test))
			   (itempath   (db:test-get-item-path test))
			   (testfullname (test:test-get-fullname test))
			   (teststatus (db:test-get-status   test))
			   (teststate  (db:test-get-state    test))
			   (teststart  (db:test-get-event_time test))
			   (runtime    (db:test-get-run_duration test))
			   (buttontxt  (if (equal? teststate "COMPLETED") teststatus teststate))
			   (button     (vector-ref columndat rown))
			   (color      (case (string->symbol teststate)
					 ((COMPLETED)
					  (if (equal? teststatus "PASS") "70 249 73" "223 33 49")) ;; greenish redish
					 ((LAUNCHED)         "101 123 142")
					 ((CHECK)            "255 100 50")
					 ((REMOTEHOSTSTART)  "50 130 195")
					 ((RUNNING)          "9 131 232")
					 ((KILLREQ)          "39 82 206")
					 ((KILLED)           "234 101 17")
					 (else "192 192 192")))
			   (curr-color (vector-ref buttondat 1)) ;; (iup:attribute button "BGCOLOR"))
			   (curr-title (vector-ref buttondat 2))) ;; (iup:attribute button "TITLE")))
		;;       (if (and (equal? teststate "RUNNING")
		;; 	       (> (- (current-seconds) (+ teststart runtime)) 100)) ;; if test has been dead for more than 100 seconds, call it dead
			  
		      (if (not (equal? curr-color color))
			  (iup:attribute-set! button "BGCOLOR" color))
		      (if (not (equal? curr-title buttontxt))
			  (iup:attribute-set! button "TITLE"   buttontxt))
		      (vector-set! buttondat 0 run-id)
		      (vector-set! buttondat 1 color)
		      (vector-set! buttondat 2 buttontxt)

Modified runs.scm from [1ff2811773] to [0e915f1707].

56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
...
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
...
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
294
			 (car comment) run-id test-name item-path))))

(define (test-set-log! db run-id test-name itemdat logf) 
  (let ((item-path (item-list->path itemdat)))
    (sqlite3:execute db "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path=?;" 
		     logf run-id test-name item-path)))

;; TODO: Converge this with db:get-test-info
(define (runs:get-test-info db run-id test-name item-path)
  (let ((res #f)) ;; (vector #f #f #f #f #f #f)))
    (sqlite3:for-each-row 
     (lambda (id run-id test-name state status)
       (set! res (vector id run-id test-name state status item-path)))
     db "SELECT id,run_id,testname,state,status FROM tests WHERE run_id=? AND testname=? AND item_path=?;"
     run-id test-name item-path)
    res))

(define-inline (test:get-id vec)       (vector-ref vec 0))
(define-inline (test:get-run_id vec)   (vector-ref vec 1))
(define-inline (test:get-test-name vec)(vector-ref vec 2))
(define-inline (test:get-state vec)    (vector-ref vec 3))
(define-inline (test:get-status vec)   (vector-ref vec 4))
(define-inline (test:get-item-path vec)(vector-ref vec 5))
................................................................................
		    (let loop2 ((ts #f)
				(ct 0))
		      (if (and (not ts)
			       (< ct 10))
			  (begin
			    (register-test db run-id test-name item-path)
			    (db:delete-test-step-records db run-id test-name) ;; clean out if this is a re-run
			    (loop2 (runs:get-test-info db run-id test-name item-path)
				   (+ ct 1)))
			  (if ts
			      (set! test-status ts)
			      (begin
				(print "WARNING: Couldn't register test " test-name " with item path " item-path ", skipping")
				(if (not (null? tal))
				    (loop (car tal)(cdr tal)))))))
................................................................................
		      ((failed-to-insert)
		       (print "ERROR: Failed to insert the record into the db"))
		      ((NOT_STARTED COMPLETED) ;; (cadr status is the row id for the run record)
		       (if (and (equal? (test:get-state test-status) "COMPLETED")
				(equal? (test:get-status test-status) "PASS")
				(equal? (test:get-status test-status) "CHECK")
				(not (args:get-arg "-force")))
			   (print "NOTE: Not starting test " new-test-name " as it is state \"COMPLETED\" and status \"PASS\", use -force to override")
			   (let* ((get-prereqs-cmd (lambda ()
						     (db-get-prereqs-not-met db run-id waiton))) ;; check before running ....
				  (launch-cmd      (lambda ()
						     (launch-test db run-id test-conf keyvallst test-name test-path itemdat)))
				  (testrundat      (list get-prereqs-cmd launch-cmd)))
			     (if (or (args:get-arg "-force")
				     (null? ((car testrundat)))) ;; are there any tests that must be run before this one...
				 ((cadr testrundat)) ;; this is the line that launches the test to the remote host
				 (hash-table-set! *waiting-queue* new-test-name testrundat)))))
		      ((LAUNCHED REMOTEHOSTSTART KILLED) 
		       (print "NOTE: " new-test-name " is already running or was explictly killed, use -force to launch it."))







		      ((RUNNING)  (print "NOTE: " test-name " is already running"))
		      (else       (print "ERROR: Failed to launch test " new-test-name ". Unrecognised state " (test:get-state test-status))))))
	      (if (not (null? tal))
		  (loop (car tal)(cdr tal)))))))))

(define (run-waiting-tests db)
  (let ((numtries           0)
	(last-try-time      (current-seconds))







|
|
|
|
|
|
|
|
|







 







|







 







|









|

>
>
>
>
>
>
>
|







56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
...
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
...
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
294
295
296
297
298
299
300
301
			 (car comment) run-id test-name item-path))))

(define (test-set-log! db run-id test-name itemdat logf) 
  (let ((item-path (item-list->path itemdat)))
    (sqlite3:execute db "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path=?;" 
		     logf run-id test-name item-path)))

;; ;; TODO: Converge this with db:get-test-info
;; (define (runs:get-test-info db run-id test-name item-path)
;;   (let ((res #f)) ;; (vector #f #f #f #f #f #f)))
;;     (sqlite3:for-each-row 
;;      (lambda (id run-id test-name state status)
;;        (set! res (vector id run-id test-name state status item-path)))
;;      db "SELECT id,run_id,testname,state,status FROM tests WHERE run_id=? AND testname=? AND item_path=?;"
;;      run-id test-name item-path)
;;     res))

(define-inline (test:get-id vec)       (vector-ref vec 0))
(define-inline (test:get-run_id vec)   (vector-ref vec 1))
(define-inline (test:get-test-name vec)(vector-ref vec 2))
(define-inline (test:get-state vec)    (vector-ref vec 3))
(define-inline (test:get-status vec)   (vector-ref vec 4))
(define-inline (test:get-item-path vec)(vector-ref vec 5))
................................................................................
		    (let loop2 ((ts #f)
				(ct 0))
		      (if (and (not ts)
			       (< ct 10))
			  (begin
			    (register-test db run-id test-name item-path)
			    (db:delete-test-step-records db run-id test-name) ;; clean out if this is a re-run
			    (loop2 (db:get-test-info db run-id test-name item-path)
				   (+ ct 1)))
			  (if ts
			      (set! test-status ts)
			      (begin
				(print "WARNING: Couldn't register test " test-name " with item path " item-path ", skipping")
				(if (not (null? tal))
				    (loop (car tal)(cdr tal)))))))
................................................................................
		      ((failed-to-insert)
		       (print "ERROR: Failed to insert the record into the db"))
		      ((NOT_STARTED COMPLETED) ;; (cadr status is the row id for the run record)
		       (if (and (equal? (test:get-state test-status) "COMPLETED")
				(equal? (test:get-status test-status) "PASS")
				(equal? (test:get-status test-status) "CHECK")
				(not (args:get-arg "-force")))
			   (print "NOTE: Not starting test " new-test-name " as it is state \"COMPLETED\" and status \"" (test:get-status test-status) "\", use -force to override")
			   (let* ((get-prereqs-cmd (lambda ()
						     (db-get-prereqs-not-met db run-id waiton))) ;; check before running ....
				  (launch-cmd      (lambda ()
						     (launch-test db run-id test-conf keyvallst test-name test-path itemdat)))
				  (testrundat      (list get-prereqs-cmd launch-cmd)))
			     (if (or (args:get-arg "-force")
				     (null? ((car testrundat)))) ;; are there any tests that must be run before this one...
				 ((cadr testrundat)) ;; this is the line that launches the test to the remote host
				 (hash-table-set! *waiting-queue* new-test-name testrundat)))))
		      ((KILLED) 
		       (print "NOTE: " new-test-name " is already running or was explictly killed, use -force to launch it."))
		      ((LAUNCHED REMOTEHOSTSTART RUNNING)  
		       (if (> (- (current-seconds)(+ (db:test-get-event_time test-status)
						     (db:test-get-run_duration test-status)))
			      100) ;; i.e. no update for more than 100 seconds
			   (begin
			     (print "WARNING: Test " test-name " appears to be dead.")
			     (test-set-status! db run-id test-name "INCOMPLETE" "STUCK/DEAD" itemdat "Test is stuck or dead"))
			   (print "NOTE: " test-name " is already running")))
		      (else       (print "ERROR: Failed to launch test " new-test-name ". Unrecognised state " (test:get-state test-status))))))
	      (if (not (null? tal))
		  (loop (car tal)(cdr tal)))))))))

(define (run-waiting-tests db)
  (let ((numtries           0)
	(last-try-time      (current-seconds))