| ︙ | | |
15
16
17
18
19
20
21
22
23
24
25
26
27
28
|
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
|
+
|
(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp directory-utils)
(import (prefix sqlite3 sqlite3:))
(declare (unit tests))
(declare (uses lock-queue))
(declare (uses db))
(declare (uses tdb))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
|
| ︙ | | |
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
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
227
|
126
127
128
129
130
131
132
133
134
135
136
137
138
139
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
(qry (conc "(" test-qry " AND " item-qry ")")))
;; (print "tests:match => patt-parts: " patt-parts ", test-patt: " test-patt ", item-patt: " item-patt)
(if (null? tal)
(string-intersperse (append (reverse res)(list qry)) " OR ")
(loop (car tal)(cdr tal)(cons qry res)))))))
#f))
;; get the previous record for when this test was run where all keys match but runname
;; returns #f if no such test found, returns a single test record if found
;;
;; Run this server-side
;;
(define (test:get-previous-test-run-record db run-id test-name item-path)
(let* ((keys (db:get-keys db))
(selstr (string-intersperse keys ","))
(qrystr (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND "))
(keyvals #f))
;; first look up the key values from the run selected by run-id
(sqlite3:for-each-row
(lambda (a . b)
(set! keyvals (cons a b)))
db
(conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") run-id)
(if (not keyvals)
#f
(let ((prev-run-ids '()))
(apply sqlite3:for-each-row
(lambda (id)
(set! prev-run-ids (cons id prev-run-ids)))
db
(conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id)))
;; for each run starting with the most recent look to see if there is a matching test
;; if found then return that matching test record
(debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids)
(if (null? prev-run-ids) #f
(let loop ((hed (car prev-run-ids))
(tal (cdr prev-run-ids)))
(let ((results (db:get-tests-for-run db hed (conc test-name "/" item-path)'() '() #f #f #f #f #f)))
(debug:print 4 "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path ": " results)
(if (and (null? results)
(not (null? tal)))
(loop (car tal)(cdr tal))
(if (null? results) #f
(car results))))))))))
;; get the previous records for when these tests were run where all keys match but runname
;; NB// Merge this with test:get-previous-test-run-records? This one looks for all matching tests
;; can use wildcards. Also can likely be factored in with get test paths?
;;
;; Run this remotely!!
;;
(define (test:get-matching-previous-test-run-records db run-id test-name item-path)
(let* ((keys (db:get-keys db))
(selstr (string-intersperse (map (lambda (x)(vector-ref x 0)) keys) ","))
(qrystr (string-intersperse (map (lambda (x)(conc (vector-ref x 0) "=?")) keys) " AND "))
(keyvals #f)
(tests-hash (make-hash-table)))
;; first look up the key values from the run selected by run-id
(sqlite3:for-each-row
(lambda (a . b)
(set! keyvals (cons a b)))
db
(conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") run-id)
(if (not keyvals)
'()
(let ((prev-run-ids '()))
(apply sqlite3:for-each-row
(lambda (id)
(set! prev-run-ids (cons id prev-run-ids)))
db
(conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id)))
;; collect all matching tests for the runs then
;; extract the most recent test and return that.
(debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals
", previous run ids found: " prev-run-ids)
(if (null? prev-run-ids) '() ;; no previous runs? return null
(let loop ((hed (car prev-run-ids))
(tal (cdr prev-run-ids)))
(let ((results (db:get-tests-for-run db hed (conc test-name "/" item-path) '() '() #f #f #f #f #f)))
(debug:print 4 "Got tests for run-id " run-id ", test-name " test-name
", item-path " item-path " results: " (intersperse results "\n"))
;; Keep only the youngest of any test/item combination
(for-each
(lambda (testdat)
(let* ((full-testname (conc (db:test-get-testname testdat) "/" (db:test-get-item-path testdat)))
(stored-test (hash-table-ref/default tests-hash full-testname #f)))
(if (or (not stored-test)
(and stored-test
(> (db:test-get-event_time testdat)(db:test-get-event_time stored-test))))
;; this test is younger, store it in the hash
(hash-table-set! tests-hash full-testname testdat))))
results)
(if (null? tal)
(map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests
(loop (car tal)(cdr tal))))))))))
|
| ︙ | | |
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
|
189
190
191
192
193
194
195
196
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
|
-
+
-
-
-
+
-
+
-
+
|
#t
(loop (car tal)(cdr tal)))
#f))))))
(pop-directory)
result)))))
(define (tests:test-force-state-status! test-id state status)
(cdb:test-set-status-state *runremote* test-id status state #f)
(rmt:test-set-status-state test-id status state #f)
(mt:process-triggers test-id state status))
;; Do not rpc this one, do the underlying calls!!!
(define (tests:test-set-status! test-id state status comment dat #!key (work-area #f))
(debug:print-info 4 "tests:test-set-status! test-id=" test-id ", state=" state ", status=" status ", dat=" dat)
(let* ((db #f)
(real-status status)
(testdat (cdb:get-test-info-by-id *runremote* test-id))
(testdat (rmt:get-test-info-by-id test-id))
(run-id (db:test-get-run_id testdat))
(test-name (db:test-get-testname testdat))
(item-path (db:test-get-item-path testdat))
;; before proceeding we must find out if the previous test (where all keys matched except runname)
;; was WAIVED if this test is FAIL
;; NOTES:
;; 1. Is the call to test:get-previous-run-record remotified?
;; 2. Add test for testconfig waiver propagation control here
;;
(prev-test (if (equal? status "FAIL")
(cdb:remote-run test:get-previous-test-run-record #f run-id test-name item-path)
(rmt:get-previous-test-run-record run-id test-name item-path)
#f))
(waived (if prev-test
(if prev-test ;; true if we found a previous test in this run series
(let ((prev-status (db:test-get-status prev-test))
(prev-state (db:test-get-state prev-test))
(prev-comment (db:test-get-comment prev-test)))
(debug:print 4 "prev-status " prev-status ", prev-state " prev-state ", prev-comment " prev-comment)
|
| ︙ | | |
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
|
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
|
-
+
-
+
|
(set! real-status "WAIVED"))
(debug:print 4 "real-status " real-status ", waived " waived ", status " status)
;; update the primary record IF state AND status are defined
(if (and state status)
(begin
(cdb:test-set-status-state *runremote* test-id real-status state (if waived waived comment))
(rmt:test-set-status-state test-id real-status state (if waived waived comment))
(mt:process-triggers test-id state real-status)))
;; if status is "AUTO" then call rollup (note, this one modifies data in test
;; run area, it does remote calls under the hood.
(if (and test-id state status (equal? status "AUTO"))
(db:test-data-rollup #f test-id status work-area: work-area))
(tdb:test-data-rollup test-id status work-area: work-area))
;; add metadata (need to do this way to avoid SQL injection issues)
;; :first_err
;; (let ((val (hash-table-ref/default otherdat ":first_err" #f)))
;; (if val
;; (sqlite3:execute db "UPDATE tests SET first_err=? WHERE run_id=? AND testname=? AND item_path=?;" val run-id test-name item-path)))
|
| ︙ | | |
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
|
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
333
334
335
|
-
+
-
-
-
+
-
-
+
+
-
+
-
+
-
-
+
-
+
|
type )))
;; This was run remote, don't think that makes sense.
(db:csv->test-data #f test-id
dat))))
;; need to update the top test record if PASS or FAIL and this is a subtest
(if (not (equal? item-path ""))
(mt:roll-up-pass-fail-counts run-id test-name item-path status))
(rmt:roll-up-pass-fail-counts run-id test-name item-path status))
(if (or (and (string? comment)
(string-match (regexp "\\S+") comment))
waived)
(let ((cmt (if waived waived comment)))
(cdb:remote-run db:test-set-comment #f test-id cmt)))
))
(define (tests:test-set-toplog! db run-id test-name logf)
(cdb:client-call *runremote* 'tests:test-set-toplog #t 2 logf run-id test-name))
(define (tests:test-set-toplog! run-id test-name logf)
(rmt:general-call 'tests:test-set-toplog logf run-id test-name))
(define (tests:summarize-items db run-id test-id test-name force)
(define (tests:summarize-items run-id test-id test-name force)
;; if not force then only update the record if one of these is true:
;; 1. logf is "log/final.log
;; 2. logf is same as outputfilename
(let* ((outputfilename (conc "megatest-rollup-" test-name ".html"))
(orig-dir (current-directory))
(logf-info (cdb:remote-run db:test-get-logfile-info #f run-id test-name))
(logf-info (rmt:test-get-logfile-info run-id test-name))
(logf (if logf-info (cadr logf-info) #f))
(path (if logf-info (car logf-info) #f)))
;; This query finds the path and changes the directory to it for the test
(if (and (string? path)
(directory? path)) ;; can get #f here under some wierd conditions. why, unknown ...
(begin
(debug:print 4 "Found path: " path)
(change-directory path))
;; (set! outputfilename (conc path "/" outputfilename)))
(print "No such path: " path))
(debug:print 4 "summarize-items with logf " logf ", outputfilename " outputfilename " and force " force)
(if (or (equal? logf "logs/final.log")
(equal? logf outputfilename)
force)
(begin
(if ;; (not (obtain-dot-lock outputfilename 1 5 7)) ;; retry every second for 20 seconds, call it dead after 30 seconds and steal the lock
(not (lock-queue:wait-turn outputfilename test-id))
(testdat (cdb:remote-run db:test-get-records-for-index-file #f run-id test-name)))
(testdat (rmt:test-get-records-for-index-file run-id test-name)))
(with-output-to-port
oup
(lambda ()
(set! outtxt (conc outtxt "<html><title>Summary: " test-name
"</title><body><h2>Summary for " test-name "</h2>"))
(for-each
(lambda (testrecord)
|
| ︙ | | |
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
|
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
|
-
+
+
-
+
|
(hash-table-keys counts))
(print "<tr><td>Total</td><td>" tot "</td></tr></table>")
(print "</td></td></tr></table>")
(print "<table cellspacing=\"0\" border=\"1\">"
"<tr><td>Item</td><td>State</td><td>Status</td><td>Comment</td>"
outtxt "</table></body></html>")
(release-dot-lock outputfilename)))
;; (release-dot-lock outputfilename)
))
(close-output-port oup)
(lock-queue:release-lock outputfilename test-id)
(change-directory orig-dir)
;; NB// tests:test-set-toplog! is remote internal...
(tests:test-set-toplog! db run-id test-name outputfilename)
(tests:test-set-toplog! run-id test-name outputfilename)
)))))))
;;======================================================================
;; Gather data from test/task specifications
;;======================================================================
;; (define (tests:get-valid-tests testsdir test-patts) ;; #!key (test-names '()))
|
| ︙ | | |
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
|
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
|
-
-
+
+
-
-
+
+
|
(lambda (testkeyname)
(let* ((test-record (hash-table-ref testrecordshash testkeyname))
(test-name (tests:testqueue-get-testname test-record))
(itemdat (tests:testqueue-get-itemdat test-record))
(item-path (tests:testqueue-get-item_path test-record))
(waitons (tests:testqueue-get-waitons test-record))
(keep-test #t)
(test-id (cdb:remote-run db:get-test-id-cached #f run-id test-name item-path))
(tdat (cdb:remote-run db:get-testinfo-state-status #f test-id))) ;; (cdb:get-test-info-by-id *runremote* test-id)))
(test-id (rmt:get-test-id run-id test-name item-path))
(tdat (rmt:get-testinfo-state-status test-id))) ;; (cdb:get-test-info-by-id *runremote* test-id)))
(if tdat
(begin
;; Look at the test state and status
(if (or (and (member (db:test-get-status tdat)
'("PASS" "WARN" "WAIVED" "CHECK" "SKIP"))
(equal? (db:test-get-state tdat) "COMPLETED"))
(member (db:test-get-state tdat)
'("INCOMPLETE" "KILLED")))
(set! keep-test #f))
;; examine waitons for any fails. If it is FAIL or INCOMPLETE then eliminate this test
;; from the runnable list
(if keep-test
(for-each (lambda (waiton)
;; for now we are waiting only on the parent test
(let* ((parent-test-id (cdb:remote-run db:get-test-id-cached #f run-id waiton ""))
(wtdat (cdb:remote-run db:get-testinfo-state-status #f test-id))) ;; (cdb:get-test-info-by-id *runremote* test-id)))
(let* ((parent-test-id (rmt:get-test-id run-id waiton ""))
(wtdat (rmt:get-testinfo-state-status test-id))) ;; (cdb:get-test-info-by-id *runremote* test-id)))
(if (or (and (equal? (db:test-get-state wtdat) "COMPLETED")
(member (db:test-get-status wtdat) '("FAIL")))
(member (db:test-get-status wtdat) '("KILLED"))
(member (db:test-get-state wtdat) '("INCOMPETE")))
;; (if (or (member (db:test-get-status wtdat)
;; '("FAIL" "KILLED"))
;; (member (db:test-get-state wtdat)
|
| ︙ | | |
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
|
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
|
-
+
-
-
-
+
-
+
-
+
-
+
-
-
+
-
+
-
+
-
-
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
;;======================================================================
;; test steps
;;======================================================================
;; teststep-set-status! used to be here
(define (test-get-kill-request test-id) ;; run-id test-name itemdat)
(let* ((testdat (cdb:remote-run db:get-testinfo-state-status #f test-id))) ;; (cdb:get-test-info-by-id *runremote* test-id))) ;; run-id test-name item-path)))
(let* ((testdat (rmt:get-test-info-by-id test-id)))
(and testdat
(equal? (test:get-state testdat) "KILLREQ"))))
(define (test:tdb-get-rundat-count tdb)
(if tdb
(let ((res 0))
(sqlite3:for-each-row
(lambda (count)
(set! res count))
tdb
"SELECT count(id) FROM test_rundat;")
res))
0)
(define (tests:update-central-meta-info test-id cpuload diskfree minutes uname hostname)
;; This is a good candidate for threading the requests to enable
;; transactionized write at the server
(cdb:tests-update-cpuload-diskfree *runremote* test-id cpuload diskfree)
(cdb:tests-update-run-duration *runremote* test-id minutes))
(rmt:general-call 'update-run-duration minutes test-id))
(if (and uname hostname)
(cdb:tests-update-uname-host *runremote* test-id uname hostname)))
(rmt:general-call 'update-uname-host uname hostname test-id)))
(define (tests:set-full-meta-info db test-id run-id minutes work-area)
(define (tests:set-full-meta-info test-id run-id minutes work-area)
;; DOES cdb:remote-run under the hood!
(let* ((num-records 0) ;; (test:tdb-get-rundat-count tdb))
(tests:update-testdat-meta-info db test-id work-area cpuload diskfree minutes)
(tdb:update-testdat-meta-info test-id work-area cpuload diskfree minutes)
(tests:update-central-meta-info test-id cpuload diskfree minutes uname hostname)))
(define (tests:set-partial-meta-info db test-id run-id minutes work-area)
(define (tests:set-partial-meta-info test-id run-id minutes work-area)
;; DOES cdb:remote-run under the hood!
(tests:update-testdat-meta-info db test-id work-area cpuload diskfree minutes)
(tdb:update-testdat-meta-info test-id work-area cpuload diskfree minutes)))
;; Update central with uname and hostname = #f
;; Is this one of the performance problems? This info should come from testdat-meta anyway
;; (tests:update-central-meta-info test-id cpuload diskfree minutes #f #f)
))
(define (tests:update-testdat-meta-info db test-id work-area cpuload diskfree minutes)
(let ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area)))
(if (sqlite3:database? tdb)
(begin
(sqlite3:execute tdb "INSERT INTO test_rundat (update_time,cpuload,diskfree,run_duration) VALUES (strftime('%s','now'),?,?,?);"
cpuload diskfree minutes)
(sqlite3:finalize! tdb))
(debug:print 2 "Can't update testdat.db for test " test-id " read-only or non-existant"))))
(define (tests:testdat-get-testinfo db test-id work-area)
(let ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area))
(res '()))
(if (sqlite3:database? tdb)
(begin
(sqlite3:for-each-row
(lambda (update-time cpuload diskfree run-duration)
(set! res (cons (vector update-time cpuload diskfree run-duration) res)))
tdb
"SELECT update_time,cpuload,diskfree,run_duration FROM test_rundat ORDER BY update_time ASC;")
(sqlite3:finalize! tdb)))
res))
|