Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -35,85 +35,129 @@ ""))) (system (conc "cd " rundir ";xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&"))) (message-window (conc "Directory " rundir " not found"))))) (refreshdat (lambda () - (set! testdat (db:get-test-data-by-id db test-id)) - (set! teststeps (db:get-steps-for-test db test-id)) - (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)))) + (let ((newtestdat (db:get-test-data-by-id db test-id))) + (if newtestdat + (begin + (set! testdat newtestdat) + (set! teststeps (db:get-steps-for-test db test-id)) + (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))) + (begin + (sqlite3:finalize! db) + (exit 0)))))) (widgets (make-hash-table)) (self #f) (store-label (lambda (name lbl cmd) (hash-table-set! widgets name (lambda () (iup:attribute-set! lbl "TITLE" (cmd)))) lbl)) - (store-button (lambda (name btn cmd) - (hash-table-set! widgets name (lambda (cmd) - (iup:attribute-set! btn "TITLE" (cmd)))) - btn)) - ) + (store-button store-label)) (cond ((not testdat)(begin (print "ERROR: bad test info for " test-id)(exit 1))) ((not rundat)(begin (print "ERROR: found test info but there is a problem with the run info for " run-id)(exit 1))) (else ;; (test-set-status! db run-id test-name state status itemdat) (set! self (iup:dialog #:title testfullname (iup:hbox #:expand "BOTH" ;; Need a full height box for all the test steps - (iup:vbox #:expand "BOTH" + (iup:vbox #:expand "VERTICAL" + ;; The run and test info (iup:hbox #:expand "BOTH" - (iup:frame #:title "Run Info" #:expand "VERTICAL" - (iup:hbox #:expand "BOTH" - (apply iup:vbox #:expand "BOTH" + (iup:frame #:title "Megatest Run Info" #:expand "VERTICAL" + (iup:hbox #:expand "VERTICAL" + (apply iup:vbox #:expand "VERTICAL" (append (map (lambda (keyval) (iup:label (conc (car keyval) " ") #:expand "HORIZONTAL")) keydat) (list (iup:label "runname ")))) (apply iup:vbox (append (map (lambda (keyval) (iup:label (cadr keyval) #:expand "HORIZONTAL")) keydat) - (list (iup:label runname)))))) + (list (iup:label runname)(iup:label "" #:expand "VERTICAL")))))) (iup:frame #:title "Test Info" #:expand "VERTICAL" - (iup:hbox #:expand "BOTH" - (apply iup:vbox #:expand "BOTH" - (map (lambda (val) - (iup:label val #:expand "HORIZONTAL")) - (list "Testname: " - "Item path: " - "Current state: " - "Current status: " - "Test comment: "))) + (iup:hbox #:expand "VERTICAL" + (apply iup:vbox #:expand "VERTICAL" + (append (map (lambda (val) + (iup:label val #:expand "HORIZONTAL")) + (list "Testname: " + "Item path: " + "Current state: " + "Current status: " + "Test comment: ")) + (list (iup:label "" #:expand "VERTICAL")))) (apply iup:vbox #:expand "BOTH" (list - (iup:label (db:test-get-testname testdat) #:expand "BOTH") - (iup:label (db:test-get-item-path testdat) #:expand "BOTH") + (iup:label (db:test-get-testname testdat) #:expand "HORIZONTAL") + (iup:label (db:test-get-item-path testdat) #:expand "HORIZONTAL") (store-label "teststate" - (iup:label "TestState" #:expand "BOTH") + (iup:label (db:test-get-state testdat) #:expand "HORIZONTAL") (lambda () (db:test-get-state testdat))) - (store-label "teststatus" - (iup:label "TestStatus" #:expand "BOTH") - (lambda () - (db:test-get-status testdat))) + (let ((lbl (iup:button (db:test-get-status testdat) #:expand "HORIZONTAL")) + (color (get-color-for-state-status (db:test-get-state testdat) + (db:test-get-status testdat)))) + (hash-table-set! widgets "teststatus" + (lambda () + (iup:attribute-set! lbl "BGCOLOR" color) + (db:test-get-status testdat))) + lbl) (store-label "testcomment" - (iup:label "TestComment" #:expand "BOTH") + (iup:label "TestComment " + #:expand "HORIZONTAL") (lambda () - (db:test-get-comment testdat)))))))))))) + (db:test-get-comment testdat)))))))) + ;; The run host info + (iup:frame #:title "Remote host and Test Run Info" #:expand "HORIZONTAL" + (iup:hbox #:expand "HORIZONTAL" + (apply iup:vbox #:expand "VERTICAL" ;; The heading labels + (append (map (lambda (val) + (iup:label val #:expand "HORIZONTAL")) + (list "Hostname: " + "Uname -a: " + "Disk free: " + "CPU Load: " + "Run duration: " + "Logfile: ")) + (iup:label "" #:expand "VERTICAL"))) + (apply iup:vbox #:expand "VERTICAL" + (list + ;; NOTE: Yes, the host can change! + (store-label "HostName" + (iup:label (db:test-get-host testdat) #:expand "HORIZONTAL") + (lambda ()(db:test-get-host testdat))) + (store-label "Uname" + (iup:label " " #:expand "HORIZONTAL") + (lambda ()(db:test-get-uname testdat))) + (store-label "DiskFree" + (iup:label (conc (db:test-get-diskfree testdat)) #:expand "HORIZONTAL") + (lambda ()(conc (db:test-get-diskfree testdat)))) + (store-label "CPULoad" + (iup:label (conc (db:test-get-cpuload testdat)) #:expand "HORIZONTAL") + (lambda ()(conc (db:test-get-cpuload testdat)))) + (store-label "RunDuration" + (iup:label (conc (db:test-get-run_duration testdat)) #:expand "HORIZONTAL") + (lambda ()(conc (db:test-get-run_duration testdat)))) + (store-label "CPULoad" + (iup:label (conc (db:test-get-final_logf testdat)) #:expand "HORIZONTAL") + (lambda ()(conc (db:test-get-final_logf testdat)))))))) + )))) (iup:show self) ;; Now start keeping the gui updated from the db (let loop ((i 0)) (thread-sleep! 0.1) (refreshdat) ;; update from the db here (thread-suspend! other-thread) ;; update the gui elements here (for-each (lambda (key) - (print "Updating " key) + ;; (print "Updating " key) ((hash-table-ref widgets key))) (hash-table-keys widgets)) (thread-resume! other-thread) (loop i)))))) Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -11,11 +11,11 @@ (use format) (require-library iup) (import (prefix iup iup:)) -;; (use canvas-draw) +(use canvas-draw) (use sqlite3 srfi-1 posix regex regex-case srfi-69) (import (prefix sqlite3 sqlite3:)) @@ -145,10 +145,26 @@ (iup:attribute-set! labl "TITLE" name))) (set! rown (+ 1 rown))) (if (> (length *alltestnamelst*) *start-test-offset*) (drop *alltestnamelst* *start-test-offset*) '())))) ;; *alltestnamelst*)))) + +(define (get-color-for-state-status state status) + (case (string->symbol state) + ((COMPLETED) + (if (equal? status "PASS") + "70 249 73" + (if (equal? status "WARN") + "255 172 13" + "223 33 49"))) ;; greenish orangeish 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"))) (define (update-buttons uidat numruns numtests) (let* ((runs (if (> (length *allruns*) numruns) (take-right *allruns* numruns) (pad-list *allruns* numruns))) @@ -189,15 +205,15 @@ ;; ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration (set! rundat (vector (make-vector 20 #f) '() (map (lambda (x) "") *keys*))));; 3))) (let* ((run (vector-ref rundat 0)) (testsdat (vector-ref rundat 1)) (key-val-dat (vector-ref rundat 2)) - (run-id (db-get-value-by-header run *header* "id")) + (run-id (db:get-value-by-header run *header* "id")) (testnames (delete-duplicates (append *alltestnamelst* (map test:test-get-fullname testsdat)))) ;; (take (pad-list testsdat numtests) numtests)) (key-vals (append key-val-dat - (list (let ((x (db-get-value-by-header run *header* "runname"))) + (list (let ((x (db:get-value-by-header run *header* "runname"))) (if x x ""))))) (run-key (string-intersperse key-vals "\n"))) ;; (run-ht (hash-table-ref/default alldat run-key #f))) ;; fill in the run header key values (set! *alltestnamelst* testnames) @@ -231,24 +247,11 @@ (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" - (if (equal? teststatus "WARN") - "255 172 13" - "223 33 49"))) ;; greenish orangeish 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"))) + (color (get-color-for-state-status teststate teststatus)) (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