| ︙ | | |
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
|
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
|
-
-
+
+
|
#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))
(define (test:get-previous-test-run-record dbstruct run-id test-name item-path)
(let* ((keys (db:get-keys dbstruct))
(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)))
|
| ︙ | | |
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
|
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
|
-
+
-
-
+
+
|
(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)))
(let ((results (db:get-tests-for-run dbstruct run-id 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))
(define (test:get-matching-previous-test-run-records dbstruct run-id test-name item-path)
(let* ((keys (db:get-keys dbstruct))
(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)
|
| ︙ | | |
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
|
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
|
-
+
|
;; 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)))
(let ((results (db:get-tests-for-run dbstruct run-id 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)))
|
| ︙ | | |
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
|
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
|
-
-
+
+
-
+
-
-
-
+
-
-
-
+
+
+
-
+
|
(if (null? tal)
#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)
(define (tests:test-force-state-status! dbstruct run-id test-id state status)
(db:test-set-status-state dbstruct run-id 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))
(define (tests:test-set-status! dbstruct run-id test-id state status comment dat)
(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))
(run-id (db:test-get-run_id testdat))
(test-name (db:test-get-testname testdat))
(testdat (db:get-test-info-by-id dbstruct run-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)
(test:get-previous-test-run-record dbstruct 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
|
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
|
-
-
+
+
-
+
|
(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))
(mt:process-triggers test-id state real-status)))
(db:test-set-status-state dbstruct run-id test-id real-status state (if waived waived comment))
(mt:process-triggers dbstruct run-id 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))
(db:test-data-rollup dbstruct run-id test-id status))
;; 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)))
|
| ︙ | | |
364
365
366
367
368
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
|
362
363
364
365
366
367
368
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
|
-
+
-
+
-
-
-
+
-
-
+
+
+
+
+
-
+
-
+
-
-
+
+
-
+
|
value ","
expected ","
tol ","
units ","
dcomment ",," ;; extra comma for status
type )))
;; This was run remote, don't think that makes sense.
(db:csv->test-data #f test-id
(db:csv->test-data dbstruct run-id 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))
(mt:roll-up-pass-fail-counts dbstruct 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! dbstruct run-id test-name logf)
(sqlite3:execute (db:get-db dbstruct run-id)
(db:get-query 'tests:test-set-toplog)
(db:save-string dbstruct logf)
test-name))
(define (tests:summarize-items db run-id test-id test-name force)
(define (tests:summarize-items dbstruct 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 (db:test-get-logfile-info dbstruct 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))
(print "Not updating " outputfilename " as another test item has signed up for the job")
(begin
(print "Obtained lock for " outputfilename)
(let ((oup (open-output-file outputfilename))
(counts (make-hash-table))
(let ((oup (open-output-file outputfilename))
(counts (make-hash-table))
(statecounts (make-hash-table))
(outtxt "")
(tot 0)
(testdat (cdb:remote-run db:test-get-records-for-index-file #f run-id test-name)))
(testdat (db:test-get-records-for-index-file dbstruct 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)
|
| ︙ | | |
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
|
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
|
-
+
|
"<tr><td>Item</td><td>State</td><td>Status</td><td>Comment</td>"
outtxt "</table></body></html>")
(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! dbstruct run-id test-name outputfilename)
)))))))
;;======================================================================
;; Gather data from test/task specifications
;;======================================================================
;; (define (tests:get-valid-tests testsdir test-patts) ;; #!key (test-names '()))
|
| ︙ | | |
543
544
545
546
547
548
549
550
551
552
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
|
542
543
544
545
546
547
548
549
550
551
552
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
|
-
+
-
-
+
+
-
-
+
+
|
#t ;; this is the correct order, b is waiting on a and b is before a
(if (> a-priority b-priority)
#t ;; if a is a higher priority than b then we are good to go
#f))))))))
;; for each test:
;;
(define (tests:filter-non-runnable run-id testkeynames testrecordshash)
(define (tests:filter-non-runnable dbstruct run-id testkeynames testrecordshash)
(let ((runnables '()))
(for-each
(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 #f run-id test-name item-path))
(tdat (cdb:get-test-info-by-id *runremote* test-id)))
(test-id (db:get-test-id dbstruct run-id test-name item-path))
(tdat (db:get-test-info-by-id dbstruct run-id 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 #f run-id waiton ""))
(wtdat (cdb:get-test-info-by-id *runremote* test-id)))
(let* ((parent-test-id (db:get-test-id dbstruct run-id waiton ""))
(wtdat (db:get-test-info-by-id dbstruct run-id 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)
|
| ︙ | | |
677
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
|
676
677
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
|
-
-
+
+
-
+
-
+
-
+
-
+
-
+
-
+
+
+
-
+
-
-
+
+
-
+
-
+
-
-
-
+
+
-
|
;;======================================================================
;; test steps
;;======================================================================
;; teststep-set-status! used to be here
(define (test-get-kill-request test-id) ;; run-id test-name itemdat)
(let* ((testdat (cdb:get-test-info-by-id *runremote* test-id))) ;; run-id test-name item-path)))
(define (test-get-kill-request dbstruct run-id test-id) ;; run-id test-name itemdat)
(let* ((testdat (db:get-test-info-by-id run-id test-id))) ;; run-id test-name item-path)))
(and testdat
(equal? (test:get-state testdat) "KILLREQ"))))
(define (test:tdb-get-rundat-count tdb)
(define (test:tdb-get-rundat-count dbstruct run-id)
(if tdb
(let ((res 0))
(sqlite3:for-each-row
(lambda (count)
(set! res count))
tdb
(db:get-db dbstruct run-id)
"SELECT count(id) FROM test_rundat;")
res))
0)
(define (tests:update-central-meta-info test-id cpuload diskfree minutes uname hostname)
(define (tests:update-central-meta-info dbstruct run-id 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)
(db:tests-update-cpuload-diskfree dbstruct run-id test-id cpuload diskfree)
(if minutes
(cdb:tests-update-run-duration *runremote* test-id minutes))
(db:tests-update-run-duration dbstruct run-id test-id minutes))
(if (and uname hostname)
(cdb:tests-update-uname-host *runremote* test-id uname hostname)))
(db:tests-update-uname-host dbstruct run-id test-id uname hostname)))
;; OPTIMIZE THESE!!! They are redundant!!
(define (tests:set-full-meta-info db test-id run-id minutes work-area)
(define (tests:set-full-meta-info dbstruct test-id run-id minutes work-area)
;; DOES cdb:remote-run under the hood!
(let* ((num-records 0) ;; (test:tdb-get-rundat-count tdb))
(cpuload (get-cpu-load))
(diskfree (get-df (current-directory)))
(uname (get-uname "-srvpio"))
(hostname (get-host-name)))
(tests:update-testdat-meta-info db test-id work-area cpuload diskfree minutes)
(tests:update-central-meta-info test-id cpuload diskfree minutes uname hostname)))
;; (tests:update-testdat-meta-info dbstruct run-id test-id work-area cpuload diskfree minutes)
(tests:update-central-meta-info dbstruct run-id 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 dbstruct test-id run-id minutes work-area)
;; DOES cdb:remote-run under the hood!
(let* ((cpuload (get-cpu-load))
(diskfree (get-df (current-directory))))
(tests:update-testdat-meta-info db test-id work-area cpuload diskfree minutes)
;; Update central with uname and hostname = #f
(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)
(define (tests:update-testdat-meta-info dbstruct run-id test-id work-area cpuload diskfree minutes)
(let ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area)))
(sqlite3:execute tdb "INSERT INTO test_rundat (update_time,cpuload,diskfree,run_duration) VALUES (strftime('%s','now'),?,?,?);"
cpuload diskfree minutes)
(sqlite3:finalize! tdb)))
|