| ︙ | | |
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
|
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
|
+
+
+
|
(use sqlite3 srfi-1 posix regex regex-case srfi-69)
(import (prefix sqlite3 sqlite3:))
(declare (unit dashboard-tests))
(declare (uses common))
(declare (uses db))
(declare (uses gutils))
(declare (uses rmt))
(declare (uses ezsteps))
;; (declare (uses sdb))
;; (declare (uses filedb))
(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(define (test-info-panel testdat store-label widgets)
(iup:frame
|
| ︙ | | |
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
|
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
|
+
-
+
|
(db:test-get-status testdat))))
(iup:attribute-set! lbl "TITLE" (db:test-get-status testdat)))))))
lbl)
(store-label "testcomment"
(iup:label "TestComment "
#:expand "HORIZONTAL")
(lambda (testdat)
;; (sdb:qry 'getstr
(db:test-get-comment testdat)))
(db:test-get-comment testdat))) ;; )
(store-label "testid"
(iup:label "TestId "
#:expand "HORIZONTAL")
(lambda (testdat)
(db:test-get-id testdat)))
(store-label "testdate"
(iup:label "TestDate "
|
| ︙ | | |
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
|
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
|
+
-
+
+
+
-
+
|
"Run duration: "
"Logfile: "))
(iup:label "" #:expand "VERTICAL")))
(apply iup:vbox ; #:expand "YES"
(list
;; NOTE: Yes, the host can change!
(store-label "HostName"
(iup:label ;; (sdb:qry 'getstr
(iup:label (db:test-get-host testdat) #:expand "HORIZONTAL")
(db:test-get-host testdat) ;; )
#:expand "HORIZONTAL")
(lambda (testdat)(db:test-get-host testdat)))
(store-label "Uname"
(iup:label " " #:expand "HORIZONTAL")
(lambda (testdat) ;; (sdb:qry 'getstr
(lambda (testdat)(db:test-get-uname testdat)))
(db:test-get-uname testdat))) ;; )
(store-label "DiskFree"
(iup:label (conc (db:test-get-diskfree testdat)) #:expand "HORIZONTAL")
(lambda (testdat)(conc (db:test-get-diskfree testdat))))
(store-label "CPULoad"
(iup:label (conc (db:test-get-cpuload testdat)) #:expand "HORIZONTAL")
(lambda (testdat)(conc (db:test-get-cpuload testdat))))
(store-label "RunDuration"
|
| ︙ | | |
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
|
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
|
-
+
-
+
-
+
|
((vector-ref *state-status* 1) status color)))
(define *dashboard-test-db* #t)
;;======================================================================
;; Set fields
;;======================================================================
(define (set-fields-panel db test-id testdat #!key (db #f))
(define (set-fields-panel dbstruct run-id test-id testdat #!key (db #f))
(let ((newcomment #f)
(newstatus #f)
(newstate #f))
(iup:frame
#:title "Set fields"
(iup:vbox
(iup:hbox (iup:label "Comment:")
(iup:textbox #:action (lambda (val a b)
(db:test-set-state-status-by-id db test-id #f #f b)
(rmt:test-set-state-status-by-id run-id test-id #f #f b)
;; IDEA: Just set a variable with the proc to call?
(set! newcomment b))
#:value (db:test-get-comment testdat)
#:expand "HORIZONTAL"))
(apply iup:hbox
(iup:label "STATE:" #:size "30x")
(let* ((btns (map (lambda (state)
(let ((btn (iup:button state
#:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10"
#:action (lambda (x)
(db:test-set-state-status-by-id db test-id state #f #f)
(rmt:test-set-state-status-by-id run-id test-id state #f #f)
(db:test-set-state! testdat state)))))
btn))
(map cadr *common:std-states*)))) ;; (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "LAUNCHED" "KILLED" "KILLREQ"))))
(vector-set! *state-status* 0
(lambda (state color)
(for-each
(lambda (btn)
|
| ︙ | | |
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
|
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
|
-
-
+
+
|
(cond
((< (tdb:step-get-event_time a)(tdb:step-get-event_time b)) #t)
((eq? (tdb:step-get-event_time a)(tdb:step-get-event_time b))
(< (tdb:step-get-id a) (tdb:step-get-id b)))
(else #f)))))
res))
(define (dashboard-tests:get-compressed-steps db test-id)
(let* ((steps-data (db:get-steps-for-test db test-id))
(define (dashboard-tests:get-compressed-steps dbstruct run-id test-id)
(let* ((steps-data (db:get-steps-for-test dbstruct run-id test-id))
(comprsteps (dashboard-tests:process-steps-table steps-data))) ;; (open-run-close db:get-steps-table #f test-id work-area: work-area)))
(map (lambda (x)
;; take advantage of the \n on time->string
(vector
(vector-ref x 0)
(let ((s (vector-ref x 1)))
(if (number? s)(seconds->time-string s) s))
|
| ︙ | | |
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
|
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
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
|
-
-
-
+
+
+
-
-
+
-
-
-
+
+
+
+
-
+
-
+
|
(conc (vector-ref b 2)))
#f))
(string<? (conc time-a)(conc time-b)))))))))
;;======================================================================
;;
;;======================================================================
(define (examine-test test-id) ;; run-id run-key origtest)
(let* ((db-path (conc *toppath* "/megatest.db"))
(db (open-db))
(define (examine-test run-id test-id) ;; run-id run-key origtest)
(let* ((db-path (conc *toppath* "/db/" run-id ".db"))
(dbstruct (make-dbr:dbstruct path: *toppath* local: #t))
(tdb (tdb:open-test-db-by-test-id-local test-id))
(testdat (db:get-test-info-by-id db test-id))
(let* ((run-id (if testdat (db:test-get-run_id testdat) #f))
(keydat (if testdat (db:get-key-val-pairs db run-id) #f))
(rundat (if testdat (db:get-run-info db run-id) #f))
(let* (;; (run-id (if testdat (db:test-get-run_id testdat) #f))
(keydat (if testdat (db:get-key-val-pairs dbstruct run-id) #f))
(rundat (if testdat (db:get-run-info dbstruct run-id) #f))
(runname (if testdat (db:get-value-by-header (db:get-row rundat)
(db:get-header rundat)
"runname") #f))
(tdb (tdb:open-test-db-by-test-id-local dbstruct run-id test-id))
;; These next two are intentional bad values to ensure errors if they should not
;; get filled in properly.
(logfile "/this/dir/better/not/exist")
(rundir logfile)
(testdat-path (conc rundir "/testdat.db")) ;; this gets recalculated until found
(teststeps (if testdat (dashboard-tests:get-compressed-steps db test-id) '()))
(teststeps (if testdat (dashboard-tests:get-compressed-steps dbstruct run-id test-id) '()))
(testfullname (if testdat (db:test-get-fullname testdat) "Gathering data ..."))
(testname (if testdat (db:test-get-testname testdat) "n/a"))
(testmeta (if testdat
(let ((tm (db:testmeta-get-record db testname)))
(let ((tm (db:testmeta-get-record dbstruct testname)))
(if tm tm (make-db:testmeta)))
(make-db:testmeta)))
(keystring (string-intersperse
(map (lambda (keyval)
;; (conc ":" (car keyval) " " (cadr keyval)))
(cadr keyval))
|
| ︙ | | |
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
|
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
|
-
+
-
+
+
-
+
|
(> (current-milliseconds)(+ last-update 10000)) ;; force update even 10 seconds
request-update))
(newtestdat (if need-update
;; NOTE: BUG HIDER, try to eliminate this exception handler
(handle-exceptions
exn
(debug:print-info 0 "test db access issue: " ((condition-property-accessor 'exn 'message) exn))
(db:get-test-info-by-id db test-id )))))
(db:get-test-info-by-id dbstruct run-id test-id )))))
;; (debug:print-info 0 "need-update= " need-update " curr-mod-time = " curr-mod-time)
(cond
((and need-update newtestdat)
(set! testdat newtestdat)
(set! teststeps (dashboard-tests:get-compressed-steps db test-id))
(set! teststeps (dashboard-tests:get-compressed-steps dbstruct run-id test-id))
(set! logfile (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat)))
(set! rundir ;; (filedb:get-path *fdb*
(set! rundir (db:test-get-rundir testdat))
(db:test-get-rundir testdat)) ;; )
(set! testfullname (db:test-get-fullname testdat))
;; (debug:print 0 "INFO: teststeps=" (intersperse teststeps "\n "))
;; I don't see why this was implemented this way. Please comment it ...
;; (if (eq? curr-mod-time db-mod-time) ;; do only once if same
;; (set! db-mod-time (+ curr-mod-time 1))
;; (set! db-mod-time curr-mod-time))
|
| ︙ | | |
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
|
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
|
-
+
-
+
|
;; (test-set-status! db run-id test-name state status itemdat)
(set! self ;
(iup:dialog #:close_cb (lambda (a)(exit)) ; #:expand "YES"
#:title testfullname
(iup:vbox ; #:expand "YES"
;; The run and test info
(iup:hbox ; #:expand "YES"
(run-info-panel db keydat testdat runname)
(run-info-panel dbstruct keydat testdat runname)
(test-info-panel testdat store-label widgets)
(test-meta-panel testmeta store-meta))
(host-info-panel testdat store-label)
;; The controls
(iup:frame #:title "Actions"
(iup:vbox
(iup:hbox
(iup:button "View Log" #:action viewlog #:size "80x")
(iup:button "Start Xterm" #:action xterm #:size "80x")
(iup:button "Run Test" #:action run-test #:size "80x")
(iup:button "Clean Test" #:action remove-test #:size "80x")
(iup:button "CleanRunExecute!" #:action clean-run-execute #:size "80x")
(iup:button "Kill All Jobs" #:action kill-jobs #:size "80x")
(iup:button "Close" #:action (lambda (x)(exit)) #:size "80x"))
(apply
iup:hbox
(list command-text-box command-launch-button))))
(set-fields-panel db test-id testdat)
(set-fields-panel dbstruct run-id test-id testdat)
(let ((tabs
(iup:tabs
;; Replace here with matrix
(let ((steps-matrix (iup:matrix
#:font "Courier New, -8"
#:expand "YES"
#:scrollbar "YES"
|
| ︙ | | |
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
|
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
|
-
+
|
(db:test-data-get-value x)
(db:test-data-get-expected x)
(db:test-data-get-tol x)
(db:test-data-get-status x)
(db:test-data-get-units x)
(db:test-data-get-type x)
(db:test-data-get-comment x)))
(tdb:open-run-close-db-by-test-id-local test-id #f tdb:read-test-data test-id "%")))
(tdb:open-run-close-db-by-test-id-local dbstruct run-id test-id #f tdb:read-test-data test-id "%")))
"\n")))
(if (not (equal? currval newval))
(iup:attribute-set! test-data "VALUE" newval ))))) ;; "TITLE" newval)))))
test-data))
;;(dashboard:run-controls)
)))
(iup:attribute-set! tabs "TABTITLE0" "Steps")
|
| ︙ | | |