@@ -24,10 +24,11 @@ (declare (unit dashboard-tests)) (declare (uses common)) (declare (uses db)) (declare (uses gutils)) +(declare (uses rmt)) (declare (uses ezsteps)) (include "common_records.scm") (include "db_records.scm") (include "run_records.scm") @@ -208,21 +209,21 @@ (iup:frame #:title "Set fields" (iup:vbox (iup:hbox (iup:label "Comment:") (iup:textbox #:action (lambda (val a b) - (open-run-close db:test-set-state-status-by-id db test-id #f #f b) + (rmt:test-set-state-status-by-id test-id #f #f b) (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) - (open-run-close db:test-set-state-status-by-id db test-id state #f #f) + (rmt:test-set-state-status-by-id test-id state #f #f) (db:test-set-state! testdat state))))) btn)) *common:std-states*))) ;; (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "LAUNCHED" "KILLED" "KILLREQ")))) (vector-set! *state-status* 0 (lambda (state color) @@ -238,11 +239,11 @@ (iup:label "STATUS:" #:size "30x") (let* ((btns (map (lambda (status) (let ((btn (iup:button status #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10" #:action (lambda (x) - (open-run-close db:test-set-state-status-by-id db test-id #f status #f) + (rmt:test-set-state-status-by-id test-id #f status #f) (db:test-set-status! testdat status))))) btn)) *common:std-statuses*))) ;; (list "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP")))) (vector-set! *state-status* 1 (lambda (status color) @@ -286,16 +287,105 @@ ;; (iup:button "Refresh test data" ;; #:expand "HORIZONTAL" ;; #:action (lambda (obj) ;; (print "Refresh test data " stepname)) ))) +;; get a pretty table to summarize steps +;; +(define (dashboard-tests:process-steps-table steps);; db test-id #!key (work-area #f)) +;; (let ((steps (db:get-steps-for-test db test-id work-area: work-area))) + ;; organise the steps for better readability + (let ((res (make-hash-table))) + (for-each + (lambda (step) + (debug:print 6 "step=" step) + (let ((record (hash-table-ref/default + res + (db:step-get-stepname step) + ;; stepname start end status Duration Logfile + (vector (db:step-get-stepname step) "" "" "" "" "")))) + (debug:print 6 "record(before) = " record + "\nid: " (db:step-get-id step) + "\nstepname: " (db:step-get-stepname step) + "\nstate: " (db:step-get-state step) + "\nstatus: " (db:step-get-status step) + "\ntime: " (db:step-get-event_time step)) + (case (string->symbol (db:step-get-state step)) + ((start)(vector-set! record 1 (db:step-get-event_time step)) + (vector-set! record 3 (if (equal? (vector-ref record 3) "") + (db:step-get-status step))) + (if (> (string-length (db:step-get-logfile step)) + 0) + (vector-set! record 5 (db:step-get-logfile step)))) + ((end) + (vector-set! record 2 (any->number (db:step-get-event_time step))) + (vector-set! record 3 (db:step-get-status step)) + (vector-set! record 4 (let ((startt (any->number (vector-ref record 1))) + (endt (any->number (vector-ref record 2)))) + (debug:print 4 "record[1]=" (vector-ref record 1) + ", startt=" startt ", endt=" endt + ", get-status: " (db:step-get-status step)) + (if (and (number? startt)(number? endt)) + (seconds->hr-min-sec (- endt startt)) "-1"))) + (if (> (string-length (db:step-get-logfile step)) + 0) + (vector-set! record 5 (db:step-get-logfile step)))) + (else + (vector-set! record 2 (db:step-get-state step)) + (vector-set! record 3 (db:step-get-status step)) + (vector-set! record 4 (db:step-get-event_time step)))) + (hash-table-set! res (db:step-get-stepname step) record) + (debug:print 6 "record(after) = " record + "\nid: " (db:step-get-id step) + "\nstepname: " (db:step-get-stepname step) + "\nstate: " (db:step-get-state step) + "\nstatus: " (db:step-get-status step) + "\ntime: " (db:step-get-event_time step)))) + ;; (else (vector-set! record 1 (db:step-get-event_time step))) + (sort steps (lambda (a b) + (cond + ((< (db:step-get-event_time a)(db:step-get-event_time b)) #t) + ((eq? (db:step-get-event_time a)(db:step-get-event_time b)) + (< (db:step-get-id a) (db:step-get-id b))) + (else #f))))) + res)) + +(define (dashboard-tests:get-compressed-steps test-id #!key (work-area #f)) + (if (or (not work-area) + (file-exists? (conc work-area "/testdat.db"))) + (let* ((steps-data (rmt:get-steps-for-test test-id work-area)) + (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)) + (let ((s (vector-ref x 2))) + (if (number? s)(seconds->time-string s) s)) + (vector-ref x 3) ;; status + (vector-ref x 4) + (vector-ref x 5))) ;; time delta + (sort (hash-table-values comprsteps) + (lambda (a b) + (let ((time-a (vector-ref a 1)) + (time-b (vector-ref b 1))) + (if (and (number? time-a)(number? time-b)) + (if (< time-a time-b) + #t + (if (eq? time-a time-b) + (string (current-milliseconds)(+ last-update 10000)) ;; force update even 10 seconds request-update)) (newtestdat (if need-update (handle-exceptions exn - (debug:print-info 2 "test db access issue: " ((condition-property-accessor 'exn 'message) exn)) - (open-run-close db:get-test-info-by-id db test-id ))))) + (debug:print-info 0 "test db access issue: " ((condition-property-accessor 'exn 'message) exn)) + (rmt:get-test-info-by-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 (db:get-compressed-steps test-id work-area: rundir)) + (set! teststeps (dashboard-tests:get-compressed-steps test-id work-area: rundir)) (set! logfile (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat))) (set! rundir (db:test-get-rundir testdat)) (set! testfullname (db:test-get-fullname testdat)) ;; (debug:print 0 "INFO: teststeps=" (intersperse teststeps "\n ")) (if (eq? curr-mod-time db-mod-time) ;; do only once if same @@ -536,22 +627,22 @@ ;; (iup:attribute-set! steps-matrix "FIXTOTEXT" "C1") (iup:attribute-set! steps-matrix "RESIZEMATRIX" "YES") (let ((proc (lambda (testdat) (let ((max-row 0)) - (if (not (null? teststeps)) - (let loop ((hed (car teststeps)) - (tal (cdr teststeps)) - (rownum 1) - (colnum 1)) + (if (not (null? teststeps)) + (let loop ((hed (car teststeps)) + (tal (cdr teststeps)) + (rownum 1) + (colnum 1)) (if (> rownum max-row)(set! max-row rownum)) - (let ((val (vector-ref hed (- colnum 1))) - (mtrx-rc (conc rownum ":" colnum))) - (iup:attribute-set! steps-matrix mtrx-rc (if val (conc val) "")) - (if (< colnum 6) - (loop hed tal rownum (+ colnum 1)) - (if (not (null? tal)) + (let ((val (vector-ref hed (- colnum 1))) + (mtrx-rc (conc rownum ":" colnum))) + (iup:attribute-set! steps-matrix mtrx-rc (if val (conc val) "")) + (if (< colnum 6) + (loop hed tal rownum (+ colnum 1)) + (if (not (null? tal)) (loop (car tal)(cdr tal)(+ rownum 1) 1)))))) (if (> max-row 0) (begin ;; we are going to speculatively clear rows until we find a row that is already cleared (let loop ((rownum (+ max-row 1)) @@ -603,11 +694,11 @@ (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))) - (open-run-close db:read-test-data db test-id "%"))) + (rmt: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)