Megatest

Check-in [7f668b637d]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Added stuck test handling
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 7f668b637dd79f8557ca79226e9fc630300b6067
User & Date: mrwellan on 2011-05-05 18:35:21
Other Links: manifest | tags
Context
2011-05-05
22:50
Typo in dashboard check-in: 874a4143eb user: matt tags: trunk
18:35
Added stuck test handling check-in: 7f668b637d user: mrwellan tags: trunk
10:12
Bumped version to 1.02 check-in: ad05ecc7d8 user: matt tags: trunk
Changes
Hide Diffs Side-by-Side 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

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








+
+
+








	       (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)
︙
128
129
130
131
132
133
134
135

136
137
138
139
140
141
142

131
132
133
134
135
136
137

138
139
140
141
142
143
144
145








-
+








				(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")
							(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"
︙
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

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








+
+






+







+
+
+








					     (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

56
57
58
59
60
61
62









63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78








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








			 (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))
;; ;; 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))
︙
242
243
244
245
246
247
248
249

250
251
252
253
254
255
256

242
243
244
245
246
247
248

249
250
251
252
253
254
255
256








-
+








		    (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)
			    (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)))))))
︙
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

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








-
+









-
+

+
+
+
+
+
+
+
-
+








		      ((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")
			   (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)))))
		      ((LAUNCHED REMOTEHOSTSTART KILLED) 
		      ((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"))
		      ((RUNNING)  (print "NOTE: " test-name " is already 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))
︙

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