k;;======================================================================
;; Copyright 2006-2011, Matthew Welland.
;;
;; This program is made available under the GNU GPL version 2.0 or
;; greater. See the accompanying file COPYING for details.
;;
;; This program is distributed WITHOUT ANY WARRANTY; without even the
;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;; PURPOSE.
;;======================================================================
(use format)
(require-library iup)
(import (prefix iup iup:))
(use canvas-draw)
(use sqlite3 srfi-1 posix regex regex-case srfi-69)
(import (prefix sqlite3 sqlite3:))
(declare (uses common))
(declare (uses margs))
(declare (uses keys))
(declare (uses items))
(declare (uses db))
(declare (uses configf))
(declare (uses process))
(declare (uses launch))
(declare (uses runs))
(declare (uses dboard))
(declare (uses dashboard-tests))
(declare (uses megatest-version))
(include "common_records.scm")
(define help (conc
"Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
version " megatest-version "
license GPL, Copyright (C) Matt Welland 2011
Usage: dashboard [options]
-h : this help
-run runid : control run identified by runid
-test testid : control test identified by testid
Misc
-rows N : set number of rows
"))
;; process args
(define remargs (args:get-args
(argv)
(list "-rows"
"-run"
"-test"
"-debug"
)
(list "-h"
"-v"
"-q"
)
args:arg-hash
0))
(if (args:get-arg "-h")
(begin
(print help)
(exit)))
(if (not (setup-for-run))
(begin
(print "Failed to find megatest.config, exiting")
(exit 1)))
(define *db* (open-db))
(define toplevel #f)
(define dlg #f)
(define max-test-num 0)
(define *keys* (get-keys *db*))
(define *dbkeys* (map (lambda (x)(vector-ref x 0))
(append *keys* (list (vector "runname" "blah")))))
(define *header* #f)
(define *allruns* '())
(define *buttondat* (make-hash-table)) ;; <run-id color text test run-key>
(define *alltestnamelst* '())
(define *searchpatts* (make-hash-table))
(define *num-runs* 8)
(define *tot-run-count* (db:get-num-runs *db* "%"))
(define *last-update* (current-seconds))
(define *num-tests* 15)
(define *start-run-offset* 0)
(define *start-test-offset* 0)
(define *examine-test-dat* (make-hash-table))
(define *exit-started* #f)
(define *verbosity* (cond
((args:get-arg "-debug")(string->number (args:get-arg "-debug")))
((args:get-arg "-v") 2)
((args:get-arg "-q") 0)
(else 1)))
(define uidat #f)
;; (megatest-dashboard)
;(define img1 (iup:image/palette 16 16 (u8vector->blob (u8vector
; 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 2
; 1 1 1 1 1 1 1 1 1 1 1 1 1 1 2 2
; 1 1 1 1 1 1 1 1 1 1 1 1 1 2 2 2
; 1 1 1 1 1 1 1 1 1 1 1 1 2 2 2 2
; 1 1 1 1 1 1 1 1 1 1 1 2 2 2 2 2
; 1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2
; 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2
; 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2
; 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2
; 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2
; 2 2 2 0 2 2 2 2 2 2 2 2 2 2 2 2
; 2 2 2 0 2 2 2 2 2 2 2 2 2 2 2 2
; 2 2 2 0 2 0 2 0 2 2 0 2 2 2 0 0
; 2 2 2 0 2 0 0 2 0 0 2 0 2 0 2 2
; 2 2 2 0 2 0 2 2 0 2 2 0 2 2 2 2
; 2 2 2 0 2 0 2 2 0 2 2 0 2 2 0 0
; 2 2 2 0 2 0 2 2 0 2 2 0 2 0 2 1))))
;
;(define img2 (iup:image/palette 16 16 (u8vector->blob (u8vector
; 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1
; 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1
; 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1 1
; 1 1 1 1 1 1 1 1 1 1 1 1 2 2 2 2
; 1 1 1 1 1 1 1 1 1 1 1 2 2 2 2 2
; 1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2
; 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2
; 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2
; 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2
; 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2
; 2 2 2 0 2 2 2 2 2 2 2 2 2 2 2 2
; 2 2 2 0 2 2 2 2 2 2 2 2 2 2 2 2
; 2 2 2 0 2 0 2 0 2 2 0 2 2 2 0 0
; 2 2 2 0 2 0 0 2 0 0 2 0 2 0 2 2
; 2 2 2 0 2 0 2 2 0 2 2 0 2 2 2 2
; 2 2 2 0 2 0 2 2 0 2 2 0 2 2 0 0
; 2 2 2 0 2 0 2 2 0 2 2 0 2 0 2 1))))
;
;(iup:handle-name-set! img1 "img1")
;(iup:attribute-set! img1 "0" "0 0 0")
;(iup:attribute-set! img1 "1" "BGCOLOR")
;(iup:attribute-set! img1 "2" "255 0 0")
;
;(iup:handle-name-set! img2 "img2")
;(iup:attribute-set! img2 "0" "0 0 0")
;(iup:attribute-set! img2 "1" "BGCOLOR")
;(iup:attribute-set! img2 "2" "255 0 0")
(define (message-window msg)
(iup:show
(iup:dialog
(iup:vbox
(iup:label msg #:margin "40x40")))))
(define (iuplistbox-fill-list lb items . default)
(let ((i 1)
(selected-item (if (null? default) #f (car default))))
(iup:attribute-set! lb "VALUE" (if selected-item selected-item ""))
(for-each (lambda (item)
(iup:attribute-set! lb (number->string i) item)
(if selected-item
(if (equal? selected-item item)
(iup:attribute-set! lb "VALUE" item))) ;; (number->string i))))
(set! i (+ i 1)))
items)
i))
(define (pad-list l n)(append l (make-list (- n (length l)))))
(define (colors-similar? color1 color2)
(let* ((c1 (map string->number (string-split color1)))
(c2 (map string->number (string-split color2)))
(delta (map (lambda (a b)(abs (- a b))) c1 c2)))
(null? (filter (lambda (x)(> x 3)) delta))))
;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
(define (update-rundat runnamepatt numruns testnamepatt itemnamepatt keypatts)
(let* ((allruns (db:get-runs *db* runnamepatt numruns *start-run-offset* keypatts))
(header (db:get-header allruns))
(runs (db:get-rows allruns))
(result '())
(maxtests 0))
(if (> (+ *last-update* 300) (current-seconds)) ;; every five minutes
(begin
(set! *last-update* (current-seconds))
(set! *tot-run-count* (db:get-num-runs *db* runnamepatt))))
(for-each (lambda (run)
(let* ((run-id (db:get-value-by-header run header "id"))
(tests (db-get-tests-for-run *db* run-id testnamepatt itemnamepatt))
(key-vals (get-key-vals *db* run-id)))
(if (> (length tests) maxtests)
(set! maxtests (length tests)))
(set! result (cons (vector run tests key-vals) result))))
runs)
(set! *header* header)
(set! *allruns* result)
maxtests))
(define *collapsed* (make-hash-table))
; (define *row-lookup* (make-hash-table)) ;; testname => (rownum lableobj)
(define (toggle-hide lnum) ; fulltestname)
(let* ((btn (vector-ref (vector-ref uidat 0) lnum))
(fulltestname (iup:attribute btn "TITLE"))
(parts (string-split fulltestname "("))
(basetestname (if (null? parts) "" (car parts))))
;(print "Toggling " basetestname " currently " (hash-table-ref/default *collapsed* basetestname #f))
(if (hash-table-ref/default *collapsed* basetestname #f)
(begin
;(iup:attribute-set! btn "FGCOLOR" "0 0 0")
(hash-table-delete! *collapsed* basetestname))
(begin
;(iup:attribute-set! btn "FGCOLOR" "0 192 192")
(hash-table-set! *collapsed* basetestname #t)))))
(define blank-line-rx (regexp "^\\s*$"))
(define (run-item-name->vectors lst)
(map (lambda (x)
(let ((splst (string-split x "("))
(res (vector "" "")))
(vector-set! res 0 (car splst))
(if (> (length splst) 1)
(vector-set! res 1 (car (string-split (cadr splst) ")"))))
res))
lst))
(define (collapse-rows inlst)
(let* ((newlst (filter (lambda (x)
(let* ((tparts (string-split x "("))
(basetname (if (null? tparts) x (car tparts))))
;(print "x " x " tparts: " tparts " basetname: " basetname)
(cond
((string-match blank-line-rx x) #f)
((equal? x basetname) #t)
((hash-table-ref/default *collapsed* basetname #f)
;(print "Removing " basetname " from items")
#f)
(else #t))))
inlst))
(vlst (run-item-name->vectors newlst))
;; sort by second field
(vlst-s1 (sort vlst (lambda (a b)
(let ((astr (vector-ref a 1))
(bstr (vector-ref b 1)))
(if (string=? astr "") #f #t)))))
;; (>= (string-length (vector-ref a 1))(string-length (vector-ref b 1))))))
(vlst-s2 (sort vlst-s1 (lambda (a b)
(string>= (vector-ref a 0)(vector-ref b 0))))))
(map (lambda (x)
(if (equal? (vector-ref x 1) "")
(vector-ref x 0)
(conc (vector-ref x 0) "(" (vector-ref x 1) ")")))
vlst-s2)))
;; (sort newlst (lambda (a b)
;; (let* ((partsa (string-split a "("))
;; (partsb (string-split b "("))
;; (lena (length partsa))
;; (lenb (length partsb)))
;; (if (or (and (eq? lena 1)(> lenb 1))
;; (and (eq? lenb 1)(> lena 1)))
;; (if (equal? (car partsa)(car partsb)) ;; same test
;; (> lenb lena)
;; #t)
;; #t))))))
(define (update-labels uidat)
(let* ((rown 0)
(lftcol (vector-ref uidat 0))
(numcols (vector-length lftcol))
(maxn (- numcols 1))
(allvals (make-vector numcols "")))
(for-each (lambda (name)
(if (<= rown maxn)
(let ((labl (vector-ref lftcol rown)))
(vector-set! allvals rown name)))
(set! rown (+ 1 rown)))
*alltestnamelst*)
; (if (> (length *alltestnamelst*) *start-test-offset*)
; (drop *alltestnamelst* *start-test-offset*)
; '()))
(let loop ((i 0))
(let* ((lbl (vector-ref lftcol i))
(oldval (iup:attribute lbl "TITLE"))
(newval (vector-ref allvals i)))
(if (not (equal? oldval newval))
(iup:attribute-set! lbl "TITLE" newval))
(iup:attribute-set! lbl "FGCOLOR" (if (hash-table-ref/default *collapsed* newval #f) "0 112 112" "0 0 0"))
(if (< i maxn)
(loop (+ i 1)))))))
(define (get-color-for-state-status state status)
(case (string->symbol state)
((COMPLETED)
(if (equal? status "PASS")
"70 249 73"
(if (or (equal? status "WARN")
(equal? status "WAIVED"))
"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")
((NOT_STARTED) "240 240 240")
(else "192 192 192")))
(define (update-buttons uidat numruns numtests)
(let* ((runs (if (> (length *allruns*) numruns)
(take-right *allruns* numruns)
(pad-list *allruns* numruns)))
(lftcol (vector-ref uidat 0))
(tableheader (vector-ref uidat 1))
(table (vector-ref uidat 2))
(coln 0))
(set! *alltestnamelst* '())
;; create a concise list of test names
(for-each
(lambda (rundat)
(if (vector? rundat)
(let* ((testdat (vector-ref rundat 1))
(testnames (map test:test-get-fullname testdat)))
(for-each (lambda (testname)
(if (not (member testname *alltestnamelst*))
(begin
(set! *alltestnamelst* (append *alltestnamelst* (list testname))))))
testnames))))
runs)
(set! *alltestnamelst* (collapse-rows *alltestnamelst*)) ;;; argh. please clean up this sillyness
(set! *alltestnamelst* (let ((xl (if (> (length *alltestnamelst*) *start-test-offset*)
(drop *alltestnamelst* *start-test-offset*)
'())))
(append xl (make-list (- *num-tests* (length xl)) ""))))
(update-labels uidat)
(for-each
(lambda (rundat)
(if (not rundat) ;; handle padded runs
;; ;; 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"))
(key-vals (append key-val-dat
(list (let ((x (db:get-value-by-header run *header* "runname")))
(if x x "")))))
(run-key (string-intersperse key-vals "\n")))
;; fill in the run header key values
(let ((rown 0)
(headercol (vector-ref tableheader coln)))
(for-each (lambda (kval)
(let* ((labl (vector-ref headercol rown)))
(if (not (equal? kval (iup:attribute labl "TITLE")))
(iup:attribute-set! (vector-ref headercol rown) "TITLE" kval))
(set! rown (+ rown 1))))
key-vals))
;; For this run now fill in the buttons for each test
(let ((rown 0)
(columndat (vector-ref table coln)))
(for-each
(lambda (testname)
(let ((buttondat (hash-table-ref/default *buttondat* (mkstr coln rown) #f)))
(if buttondat
(let* ((test (let ((matching (filter
(lambda (x)(equal? (test:test-get-fullname x) testname))
testsdat)))
(if (null? matching)
(vector -1 -1 "" "" "" 0 "" "" 0 "" "" "" 0 "" "")
(car matching))))
(testname (db:test-get-testname test))
(itempath (db:test-get-item-path test))
(testfullname (test:test-get-fullname test))
(teststatus (db:test-get-status test))
(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 (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 (not (equal? curr-color color))
(iup:attribute-set! button "BGCOLOR" color))
(if (not (equal? curr-title buttontxt))
(iup:attribute-set! button "TITLE" buttontxt))
(vector-set! buttondat 0 run-id)
(vector-set! buttondat 1 color)
(vector-set! buttondat 2 buttontxt)
(vector-set! buttondat 3 test)
(vector-set! buttondat 4 run-key)))
(set! rown (+ rown 1))))
*alltestnamelst*))
(set! coln (+ coln 1))))
runs)))
(define (mkstr . x)
(string-intersperse (map conc x) ","))
(define (update-search x val)
;; (print "Setting search for " x " to " val)
(hash-table-set! *searchpatts* x val))
(define (make-dashboard-buttons nruns ntests keynames)
(let* ((nkeys (length keynames))
(runsvec (make-vector nruns))
(header (make-vector nruns))
(lftcol (make-vector ntests))
(controls '())
(lftlst '())
(hdrlst '())
(bdylst '())
(result '())
(i 0))
;; controls (along bottom)
(set! controls
(iup:hbox
(iup:textbox #:size "60x15" #:fontsize "10" #:value "%"
#:action (lambda (obj unk val)
(update-search "test-name" val)))
(iup:textbox #:size "60x15" #:fontsize "10" #:value "%"
#:action (lambda (obj unk val)
(update-search "item-name" val)))
(iup:button "Quit" #:action (lambda (obj)(sqlite3:finalize! *db*)(exit)))
(iup:button "<- Left" #:action (lambda (obj)(set! *start-run-offset* (+ *start-run-offset* 1))))
(iup:button "Up ^" #:action (lambda (obj)(set! *start-test-offset* (if (> *start-test-offset* 0)(- *start-test-offset* 1) 0))))
(iup:button "Down v" #:action (lambda (obj)(set! *start-test-offset* (if (>= *start-test-offset* (length *alltestnamelst*))(length *alltestnamelst*)(+ *start-test-offset* 1)))))
(iup:button "Right ->" #:action (lambda (obj)(set! *start-run-offset* (if (> *start-run-offset* 0)(- *start-run-offset* 1) 0))))
(iup:valuator #:valuechanged_cb (lambda (obj)
(let ((val (inexact->exact (round (string->number (iup:attribute obj "VALUE")))))
(maxruns *tot-run-count*)) ;;; (+ *num-runs* (length *allruns*))))
(set! *start-run-offset* val)
(debug:print 3 "maxruns: " maxruns ", val: " val)
(iup:attribute-set! obj "MAX" maxruns)))
#:expand "YES"
#:max (+ *num-runs* (length *allruns*)))
;(iup:button "inc rows" #:action (lambda (obj)(set! *num-tests* (+ *num-tests* 1))))
;(iup:button "dec rows" #:action (lambda (obj)(set! *num-tests* (if (> *num-tests* 0)(- *num-tests* 1) 0))))
)
)
;; create the left most column for the run key names and the test names
(set! lftlst (list (iup:hbox
(iup:label) ;; (iup:valuator)
(apply iup:vbox
(map (lambda (x)
(let ((res (iup:hbox
(iup:label x #:size "40x15" #:fontsize "10") ;; #:expand "HORIZONTAL")
(iup:textbox #:size "60x15" #:fontsize "10" #:value "%" ;; #:expand "HORIZONTAL"
#:action (lambda (obj unk val)
(update-search x val))))))
(set! i (+ i 1))
res))
keynames)))))
(let loop ((testnum 0)
(res '()))
(cond
((>= testnum ntests)
;; now lftlst will be an hbox with the test keys and the test name labels
(set! lftlst (append lftlst (list (iup:hbox
(iup:valuator #:valuechanged_cb (lambda (obj)
(let ((val (iup:attribute obj "VALUE")))
(set! *start-test-offset* (inexact->exact (round (string->number val))))
(iup:attribute-set! obj "MAX" (length *alltestnamelst*))
) )
#:expand "YES"
#:orientation "VERTICAL")
(apply iup:vbox (reverse res)))))))
(else
(let ((labl (iup:button ""
#:flat "YES"
; #:image img1
; #:impress img2
#:size "100x15"
#:fontsize "10"
#:action (lambda (obj)
(toggle-hide testnum))))) ;; (iup:attribute obj "TITLE"))))
(vector-set! lftcol testnum labl)
(loop (+ testnum 1)(cons labl res))))))
;;
(let loop ((runnum 0)
(keynum 0)
(keyvec (make-vector nkeys))
(res '()))
(cond ;; nb// no else for this approach.
((>= runnum nruns) #f)
((>= keynum nkeys)
(vector-set! header runnum keyvec)
(set! hdrlst (cons (apply iup:vbox (reverse res)) hdrlst))
(loop (+ runnum 1) 0 (make-vector nkeys) '()))
(else
(let ((labl (iup:label "" #:size "60x15" #:fontsize "10"))) ;; #:expand "HORIZONTAL"
(vector-set! keyvec keynum labl)
(loop runnum (+ keynum 1) keyvec (cons labl res))))))
;; By here the hdrlst contains a list of vboxes containing nkeys labels
(let loop ((runnum 0)
(testnum 0)
(testvec (make-vector ntests))
(res '()))
(cond
((>= runnum nruns) #f) ;; (vector tableheader runsvec))
((>= testnum ntests)
(vector-set! runsvec runnum testvec)
(set! bdylst (cons (apply iup:vbox (reverse res)) bdylst))
(loop (+ runnum 1) 0 (make-vector ntests) '()))
(else
(let* ((button-key (mkstr runnum testnum))
(butn (iup:button "" ;; button-key
#:size "60x15"
;; #:expand "HORIZONTAL"
#:fontsize "10"
#:action (lambda (x)
(let* ((toolpath (car (argv)))
(buttndat (hash-table-ref *buttondat* button-key))
(test-id (db:test-get-id (vector-ref buttndat 3)))
(cmd (conc toolpath " -test " test-id "&")))
;(print "Launching " cmd)
(system cmd))))))
(hash-table-set! *buttondat* button-key (vector 0 "100 100 100" button-key #f #f))
(vector-set! testvec testnum butn)
(loop runnum (+ testnum 1) testvec (cons butn res))))))
;; now assemble the hdrlst and bdylst and kick off the dialog
(iup:show
(iup:dialog
#:title "Megatest dashboard"
(iup:vbox
(apply iup:hbox
(cons (apply iup:vbox lftlst)
(list
(iup:vbox
;; the header
(apply iup:hbox (reverse hdrlst))
(apply iup:hbox (reverse bdylst))))))
controls)))
(vector lftcol header runsvec)))
(if (or (args:get-arg "-rows")
(get-environment-variable "DASHBOARDROWS" ))
(begin
(set! *num-tests* (string->number (or (args:get-arg "-rows")
(get-environment-variable "DASHBOARDROWS"))))
(update-rundat "%" *num-runs* "%" "%" '()))
(set! *num-tests* (min (max (update-rundat "%" *num-runs* "%" "%" '()) 8) 20)))
(define *tim* (iup:timer))
(define *ord* #f)
(iup:attribute-set! *tim* "TIME" 300)
(iup:attribute-set! *tim* "RUN" "YES")
;; Move this stuff to db.scm FIXME
;;
(define *last-db-update-time* (file-modification-time (conc *toppath* "/megatest.db")))
(define (db:been-changed)
(> (file-modification-time (conc *toppath* "/megatest.db")) *last-db-update-time*))
(define (db:set-db-update-time)
(set! *last-db-update-time* (file-modification-time (conc *toppath* "/megatest.db"))))
(define (run-update x)
(update-buttons uidat *num-runs* *num-tests*)
;; (if (db:been-changed)
(begin
(update-rundat (hash-table-ref/default *searchpatts* "runname" "%") *num-runs*
(hash-table-ref/default *searchpatts* "test-name" "%")
(hash-table-ref/default *searchpatts* "item-name" "%")
(let ((res '()))
(for-each (lambda (key)
(let ((val (hash-table-ref/default *searchpatts* key #f)))
(if val (set! res (cons (list key val) res)))))
*dbkeys*)
res))
; (db:set-db-update-time)
))
(cond
((args:get-arg "-run")
(let ((runid (string->number (args:get-arg "-run"))))
(if runid
(begin
(lambda (x)
(on-exit (lambda ()
(sqlite3:finalize! *db*)))
(examine-run *db* runid)))
(begin
(print "ERROR: runid is not a number " (args:get-arg "-run"))
(exit 1)))))
((args:get-arg "-test")
(let ((testid (string->number (args:get-arg "-test"))))
(if testid
(examine-test *db* testid)
(begin
(print "ERROR: testid is not a number " (args:get-arg "-test"))
(exit 1)))))
(else
(set! uidat (make-dashboard-buttons *num-runs* *num-tests* *dbkeys*))
(iup:callback-set! *tim*
"ACTION_CB"
(lambda (x)
(run-update x)))))
;(print x)))))
(iup:main-loop)