;; General data
;;
(define (dcommon:general-info)
(let ((general-matrix (iup:matrix
#:alignment1 "ALEFT"
#:expand "YES" ;; "HORIZONTAL"
#:numcol 1
#:numlin 2
#:numcol-visible 1
#:numlin-visible 2)))
(iup:attribute-set! general-matrix "WIDTH1" "150")
(iup:attribute-set! general-matrix "0:1" "About this Megatest area")
;; User (this is not always obvious - it is common to run as a different user
(iup:attribute-set! general-matrix "1:0" "User")
(iup:attribute-set! general-matrix "1:1" (current-user-name))
;; Megatest area
;; (iup:attribute-set! general-matrix "2:0" "Area")
;; (iup:attribute-set! general-matrix "2:1" *toppath*)
;; Megatest version
(iup:attribute-set! general-matrix "2:0" "Version")
(iup:attribute-set! general-matrix "2:1" (conc megatest-version "-" (substring megatest-fossil-hash 0 4)))
general-matrix))
(define (dcommon:run-stats commondat tabdat #!key (tab-num #f))
(let* ((stats-matrix (iup:matrix expand: "YES"))
(changed #f)
(stats-updater (lambda ()
(if (dashboard:database-changed? commondat tabdat context-key: 'run-stats)
(let* ((run-stats (rmt:get-run-stats))
(indices (common:sparse-list-generate-index run-stats)) ;; proc: set-cell))
(row-indices (car indices))
(col-indices (cadr indices))
(max-row (if (null? row-indices) 1 (common:max (map cadr row-indices))))
(max-col (if (null? col-indices) 1
(common:max (map cadr col-indices))))
(max-visible (max (- (dboard:tabdat-num-tests tabdat) 15) 3))
(max-col-vis (if (> max-col 10) 10 max-col))
(numrows 1)
(numcols 1))
(iup:attribute-set! stats-matrix "CLEARVALUE" "CONTENTS")
(iup:attribute-set! stats-matrix "NUMCOL" max-col )
(iup:attribute-set! stats-matrix "NUMLIN" (if (< max-row max-visible) max-visible max-row)) ;; min of 20
(iup:attribute-set! stats-matrix "NUMCOL_VISIBLE" max-col-vis)
(iup:attribute-set! stats-matrix "NUMLIN_VISIBLE" (if (> max-row max-visible) max-visible max-row))
;; Row labels
(for-each (lambda (ind)
(let* ((name (car ind))
(num (cadr ind))
(key (conc num ":0")))
(if (not (equal? (iup:attribute stats-matrix key) name))
(begin
(set! changed #t)
(iup:attribute-set! stats-matrix key name)))))
row-indices)
;; Col labels
(for-each (lambda (ind)
(let* ((name (car ind))
(num (cadr ind))
(key (conc "0:" num)))
(if (not (equal? (iup:attribute stats-matrix key) name))
(begin
(set! changed #t)
(iup:attribute-set! stats-matrix key name)))))
col-indices)
;; Cell contents
(for-each (lambda (entry)
(let* ((row-name (car entry))
(col-name (cadr entry))
(value (caddr entry))
(row-num (cadr (assoc row-name row-indices)))
(col-num (cadr (assoc col-name col-indices)))
(key (conc row-num ":" col-num)))
(if (not (equal? (iup:attribute stats-matrix key) value))
(begin
(set! changed #t)
(iup:attribute-set! stats-matrix key value)))))
run-stats)
(if changed (iup:attribute-set! stats-matrix "REDRAW" "ALL")))
))))
;; (dboard:commondat-please-update-set! commondat #t) ;; force redraw on first pass
;; (mark-for-update tabdat)
;; (stats-updater)
(dboard:commondat-add-updater commondat stats-updater tab-num: tab-num)
;; (set! dashboard:update-summary-tab updater)
(iup:attribute-set! stats-matrix "WIDTHDEF" "40")
(iup:vbox
;; (iup:label "Run statistics" #:expand "HORIZONTAL")
stats-matrix)))
(define (dcommon:servers-table commondat tabdat)
(let* ((colnum 0)
(rownum 0)
(servers-matrix (iup:matrix #:expand "YES"
#:numcol 7
#:numcol-visible 7
#:numlin-visible 5
))
(colnames (list "Id" "MTver" "Pid" "Host" "Interface:OutPort" "RunTime" "State" "RunId"))
(updater (lambda ()
(if (dashboard:monitor-changed? commondat tabdat)
(let ((servers (server:get-list *toppath* limit: 10)))
(iup:attribute-set! servers-matrix "NUMLIN" (length servers))
;; (set! colnum 0)
;; (for-each (lambda (colname)
;; ;; (print "colnum: " colnum " colname: " colname)
;; (iup:attribute-set! servers-matrix (conc "0:" colnum) colname)
;; (set! colnum (+ 1 colnum)))
;; colnames)
(set! rownum 1)
(for-each
(lambda (server)
(set! colnum 0)
(match-let (((mod-time host port start-time pid)
server))
(let* ((uptime (- (current-seconds) mod-time))
(runtime (if start-time
(- mod-time start-time)
0))
(vals (list "-" ;; (vector-ref server 0) ;; Id
"-" ;; (vector-ref server 9) ;; MT-Ver
pid ;; (vector-ref server 1) ;; Pid
host ;; (vector-ref server 2) ;; Hostname
(conc host ":" port) ;; (conc (vector-ref server 3) ":" (vector-ref server 4)) ;; IP:Port
(seconds->hr-min-sec runtime) ;; (- (current-seconds) start-time)) ;; (vector-ref server 6)))
(cond
((< uptime 5) "alive")
((< uptime 16) "probably alive");; less than 15 seconds since mod, call it alive (vector-ref server 8) ;; State
(else "dead"))
"-" ;; (vector-ref server 12) ;; RunId
)))
(for-each (lambda (val)
(let* ((row-col (conc rownum ":" colnum))
(curr-val (iup:attribute servers-matrix row-col)))
(if (not (equal? (conc val) curr-val))
(begin
(iup:attribute-set! servers-matrix row-col val)
(iup:attribute-set! servers-matrix "FITTOTEXT" (conc "C" colnum))))
(set! colnum (+ 1 colnum))))
vals)
(set! rownum (+ rownum 1)))
(iup:attribute-set! servers-matrix "REDRAW" "ALL")))
(sort servers (lambda (a b)(> (car a)(car b))))))))))
(set! colnum 0)
(for-each (lambda (colname)
(iup:attribute-set! servers-matrix (conc "0:" colnum) colname)
(iup:attribute-set! servers-matrix "FITTOTEXT" (conc "C" colnum))
(set! colnum (+ colnum 1)))
colnames)
;; (set! dashboard:update-servers-table updater)
(dboard:commondat-add-updater commondat updater)
;; (iup:attribute-set! servers-matrix "WIDTHDEF" "40")
;; (iup:hbox
;; (iup:vbox
;; (iup:button "Start"
;; ;; #:size "50x"
;; #:expand "YES"
;; #:action (lambda (obj)
;; (let ((cmd (conc ;; "xterm -geometry 180x20 -e \""
;; "megatest -server - &")))
;; ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &")))
;; (system cmd))))
;; (iup:button "Stop"
;; #:expand "YES"
;; ;; #:size "50x"
;; #:action (lambda (obj)
;; (let ((cmd (conc ;; "xterm -geometry 180x20 -e \""
;; "megatest -stop-server 0 &")))
;; ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &")))
;; (system cmd))))
;; (iup:button "Restart"
;; #:expand "YES"
;; ;; #:size "50x"
;; #:action (lambda (obj)
;; (let ((cmd (conc ;; "xterm -geometry 180x20 -e \""
;; "megatest -stop-server 0;megatest -server - &")))
;; ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &")))
;; (system cmd)))))
;; servers-matrix
;; )))
servers-matrix
))
;; The main menu
(define (dcommon:main-menu)
(iup:menu ;; a menu is a special attribute to a dialog (think Gnome putting the menu at screen top)
(iup:menu-item "Files" (iup:menu ;; Note that you can use either #:action or action: for options
(iup:menu-item "Open" action: (lambda (obj)
(let* ((area-name (iup:textbox #:expand "HORIZONTAL"))
(fd (iup:file-dialog #:dialogtype "DIR"))
(top (iup:show fd #:modal? "YES")))
(iup:attribute-set! source-tb "VALUE"
(iup:attribute fd "VALUE"))
(iup:destroy! fd))))
;; (lambda (obj)
;; (iup:show (iup:file-dialog))
;; (print "File->open " obj)))
(iup:menu-item "Save" #:action (lambda (obj)(print "File->save " obj)))
(iup:menu-item "Exit" #:action (lambda (obj)(exit)))))
(iup:menu-item "Tools" (iup:menu
(iup:menu-item "Create new blah" #:action (lambda (obj)(print "Tools->new blah")))
;; (iup:menu-item "Show dialog" #:action (lambda (obj)
;; (show message-window
;; #:modal? #t
;; ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current
;; ;; #:x 'mouse
;; ;; #:y 'mouse
;; )
))))
;;======================================================================
;; CANVAS STUFF FOR TESTS
;;======================================================================
(define (dcommon:draw-test cnv xoffset yoffset scalef x y w h name selected)
(let* ((llx (dcommon:x->canvas x scalef xoffset))
(lly (dcommon:y->canvas y scalef yoffset))
(urx (dcommon:x->canvas (+ x w) scalef xoffset))
(ury (dcommon:y->canvas (+ y h) scalef yoffset)))
(canvas-text! cnv (+ llx 5)(+ lly 5) name)
(canvas-rectangle! cnv llx urx lly ury)
(if selected (canvas-box! cnv llx (+ llx 5) lly (+ lly 5)))))
(define (dcommon:draw-arrow cnv test-box-center waiton-center)
(let* ((test-box-center-x (vector-ref test-box-center 0))
(test-box-center-y (vector-ref test-box-center 1))
(waiton-center-x (vector-ref waiton-center 0))
(waiton-center-y (vector-ref waiton-center 1))
(delta-y (- waiton-center-y test-box-center-y))
(delta-x (- waiton-center-x test-box-center-x))
(abs-delta-x (abs delta-x))
(abs-delta-y (abs delta-y))
(use-delta-x (> abs-delta-x abs-delta-y)) ;; use the larger one
(delta-ratio (if use-delta-x
(if (> abs-delta-x 0)
(/ abs-delta-y abs-delta-x)
1)
(if (> abs-delta-y 0)
(/ abs-delta-x abs-delta-y)
1)))
(x-adj (if use-delta-x
8
(* delta-ratio 8)))
(y-adj (if use-delta-x
(* x-adj delta-ratio)
8))
(new-waiton-x (inexact->exact
(round (if (> delta-x 0) ;; have positive x
(- waiton-center-x x-adj)
(+ waiton-center-x x-adj)))))
(new-waiton-y (inexact->exact
(round (if (> delta-y 0)
(- waiton-center-y y-adj)
(+ waiton-center-y y-adj))))))
;; (canvas-line-width-set! cnv 5)
(canvas-line! cnv
test-box-center-x
test-box-center-y
new-waiton-x
new-waiton-y
)
(canvas-mark! cnv new-waiton-x new-waiton-y)))
(define (dcommon:get-box-center box)
(let* ((llx (list-ref box 0))
(lly (list-ref box 1))
(boxw (list-ref box 4))
(boxh (list-ref box 5)))
(vector (+ llx (/ boxw 2))
(+ lly (/ boxh 2)))))
(define-inline (num->int num)
(inexact->exact (round num)))
(define (dcommon:draw-edges cnv xoffset yoffset scalef edges)
(for-each
(lambda (e)
(let loop ((x1 (car e))
(y1 (cadr e))
(x2 #f)
(y2 #f)
(tal (cddr e)))
(if (and x1 y1 x2 y2)
(canvas-line!
cnv
(num->int (dcommon:x->canvas x1 scalef xoffset))
(num->int (dcommon:y->canvas y1 scalef yoffset))
(num->int (dcommon:x->canvas x2 scalef xoffset))
(num->int (dcommon:y->canvas y2 scalef yoffset)))) ;; (num->int x1)(num->int y1)(num->int x2)(num->int y2)))
(if (< (length tal) 2)
(canvas-mark! cnv
(num->int (dcommon:x->canvas x1 scalef xoffset))
(num->int (dcommon:y->canvas y1 scalef yoffset))) ;; (num->int x1)(num->int y1))
(loop (car tal)(cadr tal) x1 y1 (cddr tal)))))
;; (map (lambda (e)(map (lambda (x)(num->int (* x scalef))) e)) edges)))
edges))
(define (dcommon:draw-arrows cnv testname tests-hash test-records)
(let* ((test-box-info (hash-table-ref tests-hash testname))
(test-box-center (dcommon:get-box-center test-box-info))
(test-record (hash-table-ref test-records testname))
(waitons (vector-ref test-record 2)))
(for-each
(lambda (waiton)
(let* ((waiton-box-info (hash-table-ref/default tests-hash waiton #f))
(waiton-center (dcommon:get-box-center (or waiton-box-info test-box-info))))
(dcommon:draw-arrow cnv test-box-center waiton-center)))
waitons)
;; (debug:print 0 *default-log-port* "test-box-info=" test-box-info)
;; (debug:print 0 *default-log-port* "test-record=" test-record)
))
(define (dcommon:estimate-scale sizex sizey originx originy nodes)
;; (print "sizex: " sizex " sizey: " sizey " originx: " originx " originy: " originy " nodes: " nodes)
(let* ((maxx 1)
(maxy 1))
(for-each
(lambda (node)
(if (equal? (car node) "node")
(let ((x (string->number (list-ref node 2)))
(y (string->number (list-ref node 3))))
(if (and x (> x maxx))(set! maxx x))
(if (and y (> y maxy))(set! maxy y)))))
nodes)
(let ((scalex (/ sizex maxx))
(scaley (/ sizey maxy)))
;; (print "maxx: " maxx " maxy: " maxy " scalex: " scalex " scaley: " scaley)
(min scalex scaley))))
(define (dcommon:get-xoffset tests-draw-state sizex-in xadj-in)
(let ((xadj (or xadj-in (hash-table-ref/default tests-draw-state 'xadj 0)))
(sizex (or sizex-in (hash-table-ref/default tests-draw-state 'sizex 500))))
(hash-table-set! tests-draw-state 'xadj xadj) ;; for use in de-scaling when handling mouse clicks
(hash-table-set! tests-draw-state 'sizex sizex)
(* (/ sizex 2) (- 0.5 xadj))))
(define (dcommon:get-yoffset tests-draw-state sizey-in yadj-in)
(let ((yadj (or yadj-in (hash-table-ref/default tests-draw-state 'yadj 0)))
(sizey (or sizey-in (hash-table-ref/default tests-draw-state 'sizey 500))))
(hash-table-set! tests-draw-state 'yadj yadj) ;; for use in de-scaling when handling mouse clicks
(hash-table-set! tests-draw-state 'sizey sizey)
(* (/ sizey 2) (- yadj 0.5))))
(define (dcommon:x->canvas x scalef xoffset)
(+ xoffset (* x scalef)))
(define (dcommon:y->canvas y scalef yoffset)
(+ yoffset (* y scalef)))
;; sizex, sizey - canvas size
;; originx, originy - canvas origin
;;
(define (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records)
(let* ((dot-data ;; (map cdr (filter
;; (lambda (x)(equal? "node" (car x)))
(map string-split (tests:lazy-dot test-records "plain" sizex sizey))) ;; (tests:easy-dot test-records "plain")))
(xoffset (dcommon:get-xoffset tests-draw-state sizex xadj))
(yoffset (dcommon:get-yoffset tests-draw-state sizey yadj))
(no-dot (configf:lookup *configdat* "setup" "nodot"))
(boxh 15)
(boxw 10)
(margin 5)
(tests-info (hash-table-ref tests-draw-state 'tests-info))
(selected-tests (hash-table-ref tests-draw-state 'selected-tests ))
(scalef (if no-dot
1
(dcommon:estimate-scale sizex sizey originx originy dot-data)))
(sorted-testnames (if no-dot
(sort sorted-testnames string>=?)
sorted-testnames))
(curr-x 0) ;; NB// NOT screen units
(curr-y (/ (- sizey boxh margin) scalef)) ;; used when no-dot
(scaled-sizex (/ sizex scalef)))
(hash-table-set! tests-draw-state 'scalef scalef)
(let ((longest-str (if (null? sorted-testnames) " " (car (sort sorted-testnames (lambda (a b)(>= (string-length a)(string-length b))))))))
(let-values (((x-max y-max) (canvas-text-size cnv longest-str)))
(if (> x-max boxw)(set! boxw (+ 10 x-max)))))
;; (print "sizex: " sizex " sizey: " sizey " font: " (canvas-font cnv) " originx: " originx " originy: " originy " xtorig: " xtorig " ytorig: " ytorig " xadj: " xadj " yadj: " yadj)
(if (not (null? sorted-testnames))
(let loop ((hed (car (reverse sorted-testnames)))
(tal (cdr (reverse sorted-testnames))))
(let* ((nodedat (if no-dot
#f
(let ((tmpres (filter (lambda (x)
(if (and (not (null? x))
(equal? (car x) "node"))
(equal? hed (cadr x))
#f))
dot-data)))
(if (null? tmpres)
;; llx lly boxw boxh
(list "0" "1" "1" (conc (length tal)) "2" "0.5") ;; return some placeholder junk if no dat found
(car tmpres)))))
(edgedat (if no-dot
'()
(let ((edges (filter (lambda (x) ;; filter for edge
(if (and (not (null? x))
(equal? (car x) "edge"))
(equal? hed (cadr x))
#f))
dot-data)))
(map (lambda (inlst)
(dcommon:process-polyline
(map (lambda (instr)
(string->number instr)) ;; convert to number and scale
(let ((il (cddddr inlst)))
(take il (- (length il) 2))))
(lambda (x y)
(list (+ x 0) ;; xtorig)
(+ y 0))) ;; ytorig)))
#f #f)) ;; process polyline
edges))))
(cx (if no-dot ;; this is the centerpoint!
curr-x
(string->number (list-ref nodedat 2))))
(cy (if no-dot
curr-y
(string->number (list-ref nodedat 3))))
(boxw (if no-dot
boxw
(string->number (list-ref nodedat 4))))
(boxh (if no-dot
boxh
(string->number (list-ref nodedat 5))))
(boxw/2 (/ boxw 2))
(boxh/2 (/ boxh 2))
(urx (+ cx boxw/2))
(ury (+ cy boxh/2))
(llx (- cx boxw/2))
(lly (- cy boxh/2)))
;; if we are in no-dot mode then increment curr-x and curr-y as needed
(if no-dot
(begin
(cond
((< curr-x (- scaled-sizex boxw boxw margin))
(set! curr-x (+ curr-x boxw margin)))
((> curr-x (- scaled-sizex boxw boxw margin))
(set! curr-x 0)
(set! curr-y (- curr-y (+ boxh margin)))))))
; (print "hed " hed " llx " llx " lly " lly " urx " urx " ury " ury)
(dcommon:draw-test cnv xoffset yoffset scalef llx lly boxw boxh hed (hash-table-ref/default selected-tests hed #f))
;; (dcommon:draw-arrows cnv testname tests-info test-records))
(dcommon:draw-edges cnv xoffset yoffset scalef edgedat)
;; data used by mouse click calc. keep the wacky order for now.
(hash-table-set! tests-info hed (list llx lly urx ury boxw boxh edgedat))
(if (not (null? tal))
(loop (car tal)
(cdr tal))))))
))
;; per-point-proc required, remainder optional
;;
(define (dcommon:process-polyline line per-point-proc per-segment-proc last-segment-proc)
(if (< (length line) 2)
'()
(let loop ((x1 (car line))
(y1 (cadr line))
(x2 #f)
(y2 #f)
(tal (cddr line))
(res '()))
(if (and x1 y1 x2 y2 per-segment-proc)
(per-segment-proc x1 y1 x2 y2))
(if (< (length tal) 2)
(begin
(if last-segment-proc (last-segment-proc x1 y1 x2 y2))
(append res (per-point-proc x1 y1)))
(loop (car tal)(cadr tal) x1 y1 (cddr tal) (append res (per-point-proc x1 y1)))))))
(define (dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records)
(let* ((scalef (hash-table-ref tests-draw-state 'scalef))
(xoffset (dcommon:get-xoffset tests-draw-state sizex xadj))
(yoffset (dcommon:get-yoffset tests-draw-state sizey yadj))
(tests-info (hash-table-ref tests-draw-state 'tests-info))
(selected-tests (hash-table-ref tests-draw-state 'selected-tests )))
(if (not (null? sorted-testnames))
(let loop ((hed (car (reverse sorted-testnames)))
(tal (cdr (reverse sorted-testnames))))
(let* ((tvals (hash-table-ref tests-info hed))
(llx (list-ref tvals 0))
(lly (list-ref tvals 1))
(boxw (list-ref tvals 4))
(boxh (list-ref tvals 5))
(edges (map (lambda (pline)
(dcommon:process-polyline pline
(lambda (x1 y1)
(list x1 y1))
#f #f))
(list-ref tvals 6)))
(urx (+ llx boxw))
(ury (+ lly boxh)))
(dcommon:draw-test cnv xoffset yoffset scalef llx lly boxw boxh hed (hash-table-ref/default selected-tests hed #f))
(dcommon:draw-edges cnv xoffset yoffset scalef edges)
(if (not (null? tal))
;; leave a column of space to the right to list items
(loop (car tal)
(cdr tal))))))))
;;======================================================================
;; RUN CONTROLS
;;======================================================================
(define (dcommon:command-execution-control data)
;; The command line display/exectution control
(iup:frame
#:title "Command to be exectuted"
(iup:hbox
(iup:label "Run on" #:size "40x")
(iup:radio
(iup:hbox
(iup:toggle "Local" #:size "40x")
(iup:toggle "Server" #:size "40x")))
(let ((tb (iup:textbox
#:value "megatest "
#:expand "HORIZONTAL"
#:readonly "YES"
#:font "Courier New, -12"
)))
(dboard:tabdat-command-tb-set! data tb)
tb)
(iup:button "Execute" #:size "50x"
#:action (lambda (obj)
;; (let ((cmd (conc ;; "xterm -geometry 180x20 -e \""
(common:run-a-command (iup:attribute (dboard:tabdat-command-tb data) "VALUE")))))))
;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &")))
;; (system cmd)))))))
(define (dcommon:command-action-selector commondat tabdat #!key (tab-num #f))
(iup:frame
#:title "Set the action to take"
(iup:hbox
;; (iup:label "Command to run" #:expand "HORIZONTAL" #:size "70x" #:alignment "LEFT:ACENTER")
(let* ((cmds-list '("run" "remove-runs")) ;; "set-state-status" "lock-runs" "unlock-runs"))
(lb (iup:listbox #:expand "HORIZONTAL"
#:dropdown "YES"
#:action (lambda (obj val index lbstate)
;; (print obj " " val " " index " " lbstate)
(dboard:tabdat-command-set! tabdat val)
(dashboard:update-run-command tabdat))))
(default-cmd (car cmds-list)))
(iuplistbox-fill-list lb cmds-list selected-item: default-cmd)
(dboard:tabdat-command-set! tabdat default-cmd)
lb))))
(define (dcommon:command-runname-selector commondat tabdat #!key (tab-num #f)) ;; alldat data)
(iup:frame
#:title "Runname"
(let* ((default-run-name (seconds->work-week/day (current-seconds)))
(tb (iup:textbox #:expand "HORIZONTAL"
#:action (lambda (obj val txt)
(debug:catch-and-dump
(lambda ()
;; (print "obj: " obj " val: " val " unk: " unk)
(dboard:tabdat-run-name-set! tabdat txt) ;; (iup:attribute obj "VALUE"))
(dashboard:update-run-command tabdat))
"command-runname-selector tb action"))
#:value (or default-run-name (dboard:tabdat-run-name tabdat))))
(lb (iup:listbox #:expand "HORIZONTAL"
#:dropdown "YES"
#:action (lambda (obj val index lbstate)
(debug:catch-and-dump
(lambda ()
(if (not (equal? val ""))
(begin
(iup:attribute-set! tb "VALUE" val)
(dboard:tabdat-run-name-set! tabdat val)
(dashboard:update-run-command tabdat))))
"command-runname-selector lb action"))))
(refresh-runs-list (lambda ()
(if (dashboard:database-changed? commondat tabdat context-key: 'runname-selector-runs-list)
(let* (;; (target (dboard:tabdat-target-string tabdat))
(runs-for-targ (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f 0))
(runs-header (vector-ref runs-for-targ 0))
(runs-dat (vector-ref runs-for-targ 1))
(run-names (cons default-run-name
(map (lambda (x)
(db:get-value-by-header x runs-header "runname"))
runs-dat))))
;; (print "DEBUGINFO: run-names=" run-names)
;; (iup:attribute-set! lb "REMOVEITEM" "ALL")
(iuplistbox-fill-list lb run-names selected-item: default-run-name))))))
;; (dboard:tabdat-updater-for-runs-set! tabdat refresh-runs-list)
(dboard:commondat-add-updater commondat refresh-runs-list tab-num: tab-num)
;; (refresh-runs-list)
(dboard:tabdat-run-name-set! tabdat default-run-name)
(iup:hbox
tb
lb))))
(define (dcommon:command-testname-selector commondat tabdat update-keyvals) ;; key-listboxes)
(iup:vbox
;; Text box for test patterns
(iup:frame
#:title "Test patterns (one per line)"
(let ((tb (iup:textbox #:action (lambda (val a b)
(debug:catch-and-dump
(lambda ()
(dboard:tabdat-test-patts-set!-use
tabdat
(dboard:lines->test-patt b))
(dashboard:update-run-command tabdat))
"command-testname-selector tb action"))
#:value (dboard:test-patt->lines
(dboard:tabdat-test-patts-use tabdat))
#:expand "YES"
#:size "x30" ;; was 10x30
#:multiline "YES")))
(set! test-patterns-textbox tb)
(dboard:tabdat-test-patterns-textbox-set! tabdat tb)
tb))
;; (iup:frame
;; #:title "Target"
;; ;; Target selectors
;; (apply iup:hbox
;; (let* ((dat (dashboard:update-target-selector tabdat action-proc: update-keyvals))
;; (key-lb (car dat))
;; (combos (cadr dat)))
;; combos)))
;; (iup:hbox
;; ;; Text box for STATES
;; (iup:frame
;; #:title "States"
;; (dashboard:text-list-toggle-box
;; ;; Move these definitions to common and find the other useages and replace!
;; (map cadr *common:std-states*) ;; '("COMPLETED" "RUNNING" "STUCK" "INCOMPLETE" "LAUNCHED" "REMOTEHOSTSTART" "KILLED")
;; (lambda (all)
;; (dboard:tabdat-states-set! tabdat all)
;; (dashboard:update-run-command tabdat))))
;; ;; Text box for STATES
;; (iup:frame
;; #:title "Statuses"
;; (dashboard:text-list-toggle-box
;; (map cadr *common:std-statuses*) ;; '("PASS" "FAIL" "n/a" "CHECK" "WAIVED" "SKIP" "DELETED" "STUCK/DEAD")
;; (lambda (all)
;; (dboard:tabdat-statuses-set! tabdat all)
;; (dashboard:update-run-command tabdat)))))
))
(define (dcommon:command-tests-tasks-canvas tabdat test-records sorted-testnames tests-draw-state)
(iup:frame
#:title "Tests and Tasks"
(let* ((updater #f)
(last-xadj 0)
(last-yadj 0)
(the-cnv #f)
(canvas-obj
(iup:canvas #:action (make-canvas-action
(lambda (cnv xadj yadj)
(if (not updater)
(set! updater (lambda (xadj yadj)
;; (print "cnv: " cnv " xadj: " xadj " yadj: " yadj)
(dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames test-records)
(set! last-xadj xadj)
(set! last-yadj yadj))))
(updater xadj yadj)
(set! the-cnv cnv)
))
;; Following doesn't work
#:wheel-cb (lambda (obj step x y dir) ;; dir is 4 for up and 5 for down. I think.
(let ((scalef (hash-table-ref tests-draw-state 'scalef)))
(hash-table-set! tests-draw-state 'scalef (+ scalef
(if (> step 0)
(* scalef 0.01)
(* scalef -0.01))))
(if the-cnv
(dashboard:draw-tests the-cnv last-xadj last-yadj tests-draw-state sorted-testnames test-records))
))
;; #:size "250x250"
#:expand "YES"
#:scrollbar "YES"
#:posx "0.5"
#:posy "0.5"
#:button-cb (lambda (obj btn pressed x y status)
;; (print "obj: " obj ", pressed " pressed ", status " status)
; (print "canvas-origin: " (canvas-origin the-cnv))
;; (let-values (((xx yy)(canvas-origin the-cnv)))
;; (canvas-transform-set! the-cnv #f)
;; (print "canvas-origin: " xx " " yy " click at " x " " y))
(let* ((tests-info (hash-table-ref tests-draw-state 'tests-info))
(selected-tests (hash-table-ref tests-draw-state 'selected-tests))
(scalef (hash-table-ref tests-draw-state 'scalef))
(sizey (hash-table-ref tests-draw-state 'sizey))
(xoffset (dcommon:get-xoffset tests-draw-state #f #f))
(yoffset (dcommon:get-yoffset tests-draw-state #f #f))
(new-y (- sizey y))
(test-patterns-textbox (dboard:tabdat-test-patterns-textbox tabdat)))
;; (print "xoffset=" xoffset ", yoffset=" yoffset)
;; (print "\tx\ty\tllx\tlly\turx\tury")
(for-each (lambda (test-name)
(let* ((rec-coords (hash-table-ref tests-info test-name))
(llx (dcommon:x->canvas (list-ref rec-coords 0) scalef xoffset))
(lly (dcommon:y->canvas (list-ref rec-coords 1) scalef yoffset))
(urx (dcommon:x->canvas (list-ref rec-coords 2) scalef xoffset))
(ury (dcommon:y->canvas (list-ref rec-coords 3) scalef yoffset)))
;; (if (eq? pressed 1)
;; (print "\tx=" x "\ty=" y "\tnew-y=" new-y "\tllx=" llx "\tlly=" lly "\turx=" urx "\tury=" ury "\t" test-name " "))
(if (and (eq? pressed 1)
(>= x llx)
(>= new-y lly)
(<= x urx)
(<= new-y ury))
(let* ((box-patterns (string-split (iup:attribute test-patterns-textbox "VALUE")))
(test-patts (string-split (or (dboard:tabdat-test-patts tabdat)
"")
","))
(patterns (delete-duplicates (append box-patterns test-patts))))
(let* ((selected (not (member test-name patterns)))
(newpatt-list (if selected
(cons test-name patterns)
(delete test-name patterns)))
(newpatt (string-intersperse newpatt-list "\n")))
(iup:attribute-set! test-patterns-textbox "VALUE" newpatt)
(iup:attribute-set! obj "REDRAW" "ALL")
(hash-table-set! selected-tests test-name selected)
(dboard:tabdat-test-patts-set!-use tabdat (dboard:lines->test-patt newpatt))
(dashboard:update-run-command tabdat)
(if updater (updater last-xadj last-yadj)))))))
(hash-table-keys tests-info)))))))
canvas-obj)))
;;======================================================================
;; S T E P S
;;======================================================================
(define (dcommon:populate-steps teststeps steps-matrix run-id test-id)
(let* ((max-row 0)
(max-col 9)
(white "255 255 255")
(testinfo (rmt:get-testinfo-state-status run-id test-id))
(state (db:test-get-state testinfo))
(status (db:test-get-status testinfo))
(test-status-color (car (gutils:get-color-for-state-status state status)))
(running-color (car (gutils:get-color-for-state-status "RUNNING" "STARTED")))
(failcolor (car (gutils:get-color-for-state-status "COMPLETED" "FAIL"))))
(if (null? teststeps)
(begin
(iup:attribute-set! steps-matrix "CLEARATTRIB" "CONTENTS")
(iup:attribute-set! steps-matrix "CLEARVALUE" "CONTENTS"))
(let loop ((hed (car teststeps))
(tal (cdr teststeps))
(rownum 1)
(colnum 1))
(if (> rownum max-row)(set! max-row rownum))
(let* ((status (vector-ref hed 3))
(val (vector-ref hed (- colnum 1)))
(bgcolor (cond
((member (conc status) '("" "-" "#<unspecified>"))
running-color)
((member (conc status) '("0" 0))
white)
(else test-status-color)))
; (else failcolor)))
(mtrx-rc (conc rownum ":" colnum)))
;;(print "BB> status=>"status"< bgcolor="bgcolor)
(iup:attribute-set! steps-matrix mtrx-rc (if val (conc val) ""))
(if (< colnum 5)
(iup:attribute-set! steps-matrix (conc "BGCOLOR" mtrx-rc) bgcolor))
(if (< colnum max-col)
(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))
(colnum 0)
(deleted #f))
;; (debug:print-info 0 *default-log-port* "cleaning " rownum ":" colnum)
(let* ((next-row (if (eq? colnum max-col) (+ rownum 1) rownum))
(next-col (if (eq? colnum max-col) 1 (+ colnum 1)))
(mtrx-rc (conc rownum ":" colnum))
(curr-val (iup:attribute steps-matrix mtrx-rc)))
;; (debug:print-info 0 *default-log-port* "cleaning " rownum ":" colnum " currval= " curr-val)
(if (and (string? curr-val)
(not (equal? curr-val "")))
(begin
(iup:attribute-set! steps-matrix mtrx-rc "")
(loop next-row next-col #t))
(if (eq? colnum max-col) ;; not done, didn't get a full blank row
(if deleted (loop next-row next-col #f)) ;; exit on this not met
(loop next-row next-col deleted)))))
(iup:attribute-set! steps-matrix "REDRAW" "ALL")))))
;;======================================================================
;; U T I L I T I E S
;;======================================================================
(define (dcommon:run-html-viewer lfilename)
(let ((htmlviewercmd (configf:lookup *configdat* "setup" "htmlviewercmd")))
(if htmlviewercmd
(system (conc "(" htmlviewercmd " " lfilename " ) &"))
(iup:send-url lfilename))))
;;======================================================================
;; diff-report
;;======================================================================
(define css "")
(define (diff:tests-mindat->hash tests-mindat)
(let* ((res (make-hash-table)))
(for-each
(lambda (item)
(let* ((test-name+item-path (cons (list-ref item 0) (list-ref item 1)))
(value (list-ref item 2)))
(hash-table-set! res test-name+item-path value)))
tests-mindat)
res))
;; return 1 if status1 is better
;; return 0 if status1 and 2 are equally good
;; return -1 if status2 is better
(define (diff:status-compare3 status1 status2)
(let*
((status-goodness-ranking (list "PASS" "WARN" "WAIVED" "SKIP" "FAIL" "ABORT" #f))
(mem1 (member status1 status-goodness-ranking))
(mem2 (member status2 status-goodness-ranking))
)
(cond
((and (not mem1) (not mem2)) 0)
((not mem1) -1)
((not mem2) 1)
((= (length mem1) (length mem2)) 0)
((> (length mem1) (length mem2)) 1)
(else -1))))
(define (diff:xor-tests-mindat src-tests-mindat dest-tests-mindat #!key (hide-clean #f) (consistent-fail-not-clean #f))
(let* ((src-hash (diff:tests-mindat->hash src-tests-mindat))
(dest-hash (diff:tests-mindat->hash dest-tests-mindat))
(all-keys
(reverse (sort
(delete-duplicates
(append (hash-table-keys src-hash) (hash-table-keys dest-hash)))
(lambda (a b)
(cond
((< 0 (string-compare3 (car a) (car b))) #t)
((> 0 (string-compare3 (car a) (car b))) #f)
((< 0 (string-compare3 (cdr a) (cdr b))) #t)
(else #f)))
))))
(let ((res
(map ;; TODO: rename xor to delta globally in dcommon and dashboard
(lambda (key)
(let* ((test-name (car key))
(item-path (cdr key))
(dest-value (hash-table-ref/default dest-hash key (list 0 "NULL" "NULL"))) ;; (list test-id state status)
(dest-test-id (list-ref dest-value 0))
(dest-state (list-ref dest-value 1))
(dest-status (list-ref dest-value 2))
(src-value (hash-table-ref/default src-hash key (list 0 "NULL" "NULL"))) ;; (list test-id state status)
(src-test-id (list-ref src-value 0))
(src-state (list-ref src-value 1))
(src-status (list-ref src-value 2))
(incomplete-statuses '("DELETED" "INCOMPLETE" "STUCK/DEAD" "N/A")) ;; if any of these statuses apply, treat test as incomplete
(dest-complete
(and dest-value dest-state dest-status
(equal? dest-state "COMPLETED")
(not (member dest-status incomplete-statuses))))
(src-complete
(and src-value src-state src-status
(equal? src-state "COMPLETED")
(not (member src-status incomplete-statuses))))
(status-compare-result (diff:status-compare3 src-status dest-status))
(xor-new-item
(cond
;; complete, for this case means: state=compelte AND status not in ( deleted uncomplete stuck/dead n/a )
;; neither complete -> bad
;; src !complete, dest complete -> better
((and (not dest-complete) (not src-complete))
(list dest-test-id "BOTH-BAD" "BOTH-INCOMPLETE") src-value dest-value)
((not dest-complete)
(list src-test-id "NOT-IN-DEST" "DEST-INCOMPLETE") src-value dest-value)
((not src-complete)
(list dest-test-id "NOT-IN-SRC" "SRC-INCOMPLETE") src-value dest-value)
((and
(equal? src-state dest-state)
(equal? src-status dest-status))
(if (and consistent-fail-not-clean (not (member dest-status '("PASS" "SKIP" "WAIVED" "WARN"))))
(list dest-test-id (conc "BOTH-BAD") (conc "CLEAN-" dest-status) src-value dest-value)
(list dest-test-id (conc "CLEAN") (conc "CLEAN-" dest-status) src-value dest-value)))
;; better or worse: pass > warn > waived > skip > fail > abort
;; pass > warn > waived > skip > fail > abort
((= 1 status-compare-result) ;; src is better, dest is worse
(list dest-test-id "WORSE" (conc src-status "->" dest-status) src-value dest-value))
(else
(list dest-test-id "BETTER" (conc src-status "->" dest-status) src-value dest-value)))))
(list test-name item-path xor-new-item)))
all-keys)))
(if hide-clean
(filter
(lambda (item)
(not
(equal?
"CLEAN"
(list-ref (list-ref item 2) 1))))
res)
res))))
(define (diff:run-name->run-id run-name)
(if (number? run-name)
run-name
(let* ((qry-res (rmt:get-runs run-name 1 0 '())))
(if (eq? 2 (vector-length qry-res))
(vector-ref (car (vector-ref qry-res 1)) 1)
#f))))
(define (diff:target+run-name->run-id target run-name)
(let* ((keys (rmt:get-keys))
(target-parts (if target (string-split target "/") (map (lambda (x) "%") keys))))
(if (not (eq? (length keys) (length keys)))
(begin
(print "Error: Target ("target") item count does not match fields count target tokens="target-parts" fields="keys)
#f)
(let* ((target-map (zip keys target-parts))
(qry-res (rmt:get-runs run-name 1 0 target-map)))
(if (eq? 2 (vector-length qry-res))
(let ((first-ent (vector-ref qry-res 1)))
(if (> (length first-ent) 0)
(vector-ref (car first-ent) 1)
#f))
#f)))))
(define (diff:run-id->tests-mindat run-id #!key (testpatt "%/%"))
(let* ((states '())
(statuses '())
(offset #f)
(limit #f)
(not-in #t)
(sort-by #f)
(sort-order #f)
(qryvals "id,testname,item_path,state,status")
(qryvals "id,testname,item_path,state,status")
(last-update 0)
(mode #f)
)
(map
;; (lambda (row)
;; (match row
;; ((#(id test-name item-path state status)
;; (list test-name item-path (list id state status))))
;; (else #f)))
(lambda (row)
(let* ((id (vector-ref row 0))
(test-name (vector-ref row 1))
(item-path (vector-ref row 2))
(state (vector-ref row 3))
(status (vector-ref row 4)))
(list test-name item-path (list id state status))))
(rmt:get-tests-for-run run-id
testpatt states statuses
offset limit
not-in sort-by sort-order
qryvals
last-update
mode))))
(define (diff:diff-runs src-run-id dest-run-id)
(let* ((src-tests-mindat (diff:run-id->tests-mindat src-run-id))
(dest-tests-mindat (diff:run-id->tests-mindat dest-run-id)))
(diff:xor-tests-mindat src-tests-mindat dest-tests-mindat consistent-fail-not-clean: #t)))
(define (diff:rundiff-find-by-state run-diff state)
(filter
(lambda (x)
(equal? (list-ref (caddr x) 1) state))
run-diff))
(define (diff:rundiff-clean-breakdown run-diff)
(map
(lambda (run-diff-item)
(match run-diff-item
((test-name item-path (junk-id diff-state diff-status (src-test-id src-state src-status) (dest-test-id dest-state dest-status)))
(list test-name item-path "CLEAN" src-status))
(else "")))
(diff:rundiff-find-by-state run-diff "CLEAN")))
(define (diff:summarize-run-diff run-diff)
(let* ((diff-states (list "CLEAN" "BETTER" "WORSE" "BOTH-BAD" "NOT-IN-DEST" "NOT-IN-SRC" )))
(map
(lambda (state)
(list state
(length (diff:rundiff-find-by-state run-diff state))))
diff-states)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Presentation code below, business logic above ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (diff:stml->string in-stml)
(with-output-to-string
(lambda ()
(s:output-new
(current-output-port)
in-stml))))
(define (diff:state-status->bgcolor state status)
(match (list state status)
(("CLEAN" _) "#88ff88")
(("BETTER" _) "#33ff33")
(("WORSE" _) "#ff3333")
(("BOTH-BAD" _) "#ff3333")
((_ "WARN") "#ffff88")
((_ "FAIL") "#ff8888")
((_ "ABORT") "#ff0000")
((_ "PASS") "#88ff88")
((_ "SKIP") "#ffff00")
(else "#ffffff")))
(define (diff:test-state-status->diff-report-cell state status)
(s:td 'bgcolor (diff:state-status->bgcolor state status) status))
(define (diff:diff-state-status->diff-report-cell state status)
(s:td state 'bgcolor (diff:state-status->bgcolor state status)))
(define (diff:megatest-html-logo)
"<pre>
___ ___ _ _
| \\/ | ___ __ _ __ _| |_ ___ ___| |_
| |\\/| |/ _ \\/ _` |/ _` | __/ _ \\/ __| __|
| | | | __/ (_| | (_| | || __/\\__ \\ |_
|_| |_|\\___|\\__, |\\__,_|\\__\\___||___/\\__|
|___/
</pre>")
(define (diff:megatest-html-diff-logo)
"<pre>
___ ___ _ _
| \\/ | ___ __ _ __ _| |_ ___ ___| |_ | _ \\(_)/ _|/ _|
| |\\/| |/ _ \\/ _` |/ _` | __/ _ \\/ __| __| | | | | | |_| |_
| | | | __/ (_| | (_| | || __/\\__ \\ |_ | |_| | | _| _|
|_| |_|\\___|\\__, |\\__,_|\\__\\___||___/\\__| |____/|_|_| |_|
|___/
</pre>")
(define (diff:run-id->target+run-name+starttime run-id)
(let* ((target (rmt:get-target run-id))
(runinfo (rmt:get-run-info run-id)) ; vector of header (list) and result (vector)
(info-hash (alist->hash-table
(map (lambda (x) (cons (car x) (cadr x))) ; make it a useful hash
(zip (vector-ref runinfo 0) (vector->list (vector-ref runinfo 1))))))
(run-name (hash-table-ref/default info-hash "runname" "N/A"))
(start-time (hash-table-ref/default info-hash "event_time" 0)))
(list target run-name start-time)))
(define (diff:deliver-diff-report src-run-id dest-run-id
#!key
(html-output-file #f)
(email-subject-prefix "[MEGATEST DIFF]")
(email-recipients-list '()) )
(let* ((src-info (diff:run-id->target+run-name+starttime src-run-id))
(src-target (car src-info))
(src-run-name (cadr src-info))
(src-start (conc (seconds->string (caddr src-info)) " " (local-timezone-abbreviation)))
(dest-info (diff:run-id->target+run-name+starttime dest-run-id))
(dest-target (car dest-info))
(dest-run-name (cadr dest-info))
(dest-start (conc (seconds->string (caddr dest-info)) " " (local-timezone-abbreviation)))
(run-diff (diff:diff-runs src-run-id dest-run-id ))
(test-count (length run-diff))
(summary-table
(apply s:table 'cellspacing "0" 'border "1"
(s:tr
(s:th "Diff type")
(s:th "% share")
(s:th "Count"))
(map
(lambda (state-count)
(s:tr
(diff:diff-state-status->diff-report-cell (car state-count) #f)
(s:td 'align "right" (fmt #f
(decimal-align 3
(fix 2
(num/fit 6
(* 100 (/ (cadr state-count) test-count)))))))
(s:td 'align "right" (cadr state-count))))
(diff:summarize-run-diff run-diff))))
(meta-table
(s:table 'cellspacing "0" 'border "1"
(s:tr
(s:td 'colspan "2"
(s:table 'cellspacing "0" 'border "1"
(s:tr
(s:th 'align "LEFT" "") (s:th "SOURCE RUN") (s:th "DESTINATION RUN"))
(s:tr
(s:th 'align "LEFT" "Started") (s:td src-start) (s:td dest-start))
(s:tr
(s:th 'align "LEFT" "TARGET") (s:td src-target) (s:td dest-target))
(s:tr
(s:th 'align "LEFT" "RUN NAME") (s:td src-run-name) (s:td dest-run-name)))))))
(main-table
(apply s:table 'cellspacing "0" 'border "1"
(s:tr
(s:th "Test name")
(s:th "Item Path")
(s:th (conc "SOURCE"))
(s:th (conc "DEST"))
(s:th "Diff"))
(map
(lambda (run-diff-item)
(match run-diff-item
((test-name item-path (junk-id diff-state diff-status (src-test-id src-state src-status) (dest-test-id dest-state dest-status)))
(s:tr
(s:td test-name)
(s:td item-path)
(diff:test-state-status->diff-report-cell src-state src-status)
(diff:test-state-status->diff-report-cell dest-state dest-status)
(diff:diff-state-status->diff-report-cell diff-state diff-status)))
(else "")))
(filter (lambda (run-diff-item)
(match run-diff-item
((test-name item-path (junk-id diff-state diff-status (src-test-id src-state src-status) (dest-test-id dest-state dest-status)))
(not (equal? diff-state "CLEAN")))
(else #f)))
run-diff))))
(email-subject (conc email-subject-prefix " " src-target "/" src-run-name" vs. "dest-target"/"dest-run-name))
(html-body (diff:stml->string (s:body
(diff:megatest-html-diff-logo)
(s:h2 "Summary")
(s:table 'border "0"
(s:tr
(s:td "Diff calculated at")
(s:td (conc (seconds->string) " " (local-timezone-abbreviation))))
(s:tr
(s:td "MT_RUN_AREA_HOME" ) (s:td *toppath*))
(s:tr 'valign "TOP"
(s:td summary-table)
(s:td meta-table)))
(s:h2 "Diffs + consistently failing tests")
main-table)))
)
(if html-output-file
(with-output-to-file html-output-file (lambda () (print html-body))))
(when (and email-recipients-list (> (length email-recipients-list) 0))
(sendmail (string-join email-recipients-list ",") email-subject html-body use_html: #t))
html-body))
;; (let* ((src-run-name "all57")
;; (dest-run-name "all60")
;; (src-run-id (diff:run-name->run-id src-run-name))
;; (dest-run-id (diff:run-name->run-id dest-run-name))
;; (to-list (list "bjbarcla")))
;; (diff:deliver-diff-report src-run-id dest-run-id email-recipients-list: to-list html-output-file: "/tmp/bjbarcla/zippy.html")
;; )
(define (do-diff-report src-target src-runname dest-target dest-runname html-file to-list-raw)
(let* (;;(src-target "nope%")
;;(src-runname "all57")
;;(dest-target "%")
;;(dest-runname "all60")
(src-run-id (diff:target+run-name->run-id src-target src-runname))
(dest-run-id (diff:target+run-name->run-id dest-target dest-runname))
;(html-file "/tmp/bjbarcla/zippy.html")
(to-list (if (string? to-list-raw) (string-split to-list-raw ",:") #f))
)
(cond
((not src-run-id)
(print "No match for source target/runname="src-target"/"src-runname)
(print "Cannot proceed.")
#f)
((not dest-run-id)
(print "No match for source target/runname="dest-target"/"dest-runname)
(print "Cannot proceed.")
#f)
(else
(diff:deliver-diff-report src-run-id dest-run-id email-recipients-list: to-list html-output-file: html-file)))))
;;======================================================================
;; env
;;======================================================================
(define (env:open-db fname)
(let* ((db-exists (common:file-exists? fname))
(db (open-database fname)))
(if (not db-exists)
(begin
(exec (sql db "CREATE TABLE envvars (
id INTEGER PRIMARY KEY,
context TEXT NOT NULL,
var TEXT NOT NULL,
val TEXT NOT NULL,
CONSTRAINT envvars_constraint UNIQUE (context,var))"))))
(set-busy-handler! db (busy-timeout 10000))
db))
;; save vars in given context, this is NOT incremental by default
;;
(define (env:save-env-vars db context #!key (incremental #f)(vardat #f))
(with-transaction
db
(lambda ()
;; first clear out any vars for this context
(if (not incremental)(exec (sql db "DELETE FROM envvars WHERE context=?") context))
(for-each
(lambda (varval)
(let ((var (car varval))
(val (cdr varval)))
(if incremental (exec (sql db "DELETE FROM envvars WHERE context=? AND var=?") context var))
(exec (sql db "INSERT INTO envvars (context,var,val) VALUES (?,?,?)") context var val)))
(if vardat
(hash-table->alist vardat)
(get-environment-variables))))))
;; merge contexts in the order given
;; - each context is applied in the given order
;; - variables in the paths list are split on the separator and the components
;; merged using simple delta addition
;; returns a hash of the merged vars
;;
(define (env:merge-contexts db basecontext contexts paths)
(let ((result (make-hash-table)))
(for-each
(lambda (context)
(query
(for-each-row
(lambda (row)
(let ((var (car row))
(val (cadr row)))
(hash-table-set! result var
(if (and (hash-table-ref/default results var #f)
(assoc var paths)) ;; this var is a path and there is a previous path
(let ((sep (cadr (assoc var paths))))
(env:merge-path-envvar sep (hash-table-ref results var) valb))
valb)))))
(sql db "SELECT var,val FROM envvars WHERE context=?")
context))
contexts)
result))
;; get list of removed variables between two contexts
;;
(define (env:get-removed db contexta contextb)
(let ((result (make-hash-table)))
(query
(for-each-row
(lambda (row)
(let ((var (car row))
(val (cadr row)))
(hash-table-set! result var val))))
(sql db "SELECT var,val FROM envvars WHERE context=? AND var NOT IN (SELECT var FROM envvars WHERE context=?)")
contexta contextb)
result))
;; get list of variables added to contextb from contexta
;;
(define (env:get-added db contexta contextb)
(let ((result (make-hash-table)))
(query
(for-each-row
(lambda (row)
(let ((var (car row))
(val (cadr row)))
(hash-table-set! result var val))))
(sql db "SELECT var,val FROM envvars WHERE context=? AND var NOT IN (SELECT var FROM envvars WHERE context=?)")
contextb contexta)
result))
;; get list of variables in both contexta and contexb that have been changed
;;
(define (env:get-changed db contexta contextb)
(let ((result (make-hash-table)))
(query
(for-each-row
(lambda (row)
(let ((var (car row))
(val (cadr row)))
(hash-table-set! result var val))))
(sql db "SELECT var,val FROM envvars AS a WHERE context=? AND val != (SELECT val FROM envvars WHERE var=a.var AND context=?)")
contextb contexta)
result))
;;
(define (env:blind-merge l1 l2)
(if (null? l1) l2
(if (null? l2) l1
(cons (car l1) (cons (car l2) (env:blind-merge (cdr l1) (cdr l2)))))))
;; given a before and an after envvar calculate a new merged path
;;
(define (env:merge-path-envvar separator patha pathb)
(let* ((patha-parts (string-split patha separator))
(pathb-parts (string-split pathb separator))
(common-parts (lset-intersection equal? patha-parts pathb-parts))
(final (delete-duplicates ;; env:blind-merge
(append pathb-parts common-parts patha-parts))))
;; (print "BEFORE: " (string-intersperse patha-parts "\n "))
;; (print "AFTER: " (string-intersperse pathb-parts "\n "))
;; (print "COMMON: " (string-intersperse common-parts "\n "))
(string-intersperse final separator)))
(define (env:process-path-envvar varname separator patha pathb)
(let ((newpath (env:merge-path-envvar separator patha pathb)))
(setenv varname newpath)))
(define (env:have-context db context)
(> (query fetch-value (sql db "SELECT count(id) FROM envvars WHERE context=?") context)
0))
;; this is so the calling block does not need to import sql-de-lite
(define (env:close-database db)
(close-database db))
(define (env:lazy-hash-table->alist indat)
(if (hash-table? indat)
(let ((dat (hash-table->alist indat)))
(if (null? dat)
#f
dat))
#f))
(define (env:inc-path path)
(print "PATH "
(conc "#{scheme (env:min-path \"" path "\" \"#{getenv PATH}\")}")))
;; (conc
;; "#{scheme (string-intersperse "
;; "(delete-duplicates "
;; "(append (string-split \"" path "\" \":\") "
;; "(string-split \"#{getenv PATH}\" \":\")))"
;; " \":\")}")))
(define (env:min-path path1 path2)
(string-intersperse
(delete-duplicates
(append
(string-split path1 ":")
(string-split path2 ":")))
":"))
;; inc path will set a PATH that is incrementally modified when read - config mode only
;;
(define (env:print added removed changed #!key (inc-path #t))
(let ((a (env:lazy-hash-table->alist added))
(r (env:lazy-hash-table->alist removed))
(c (env:lazy-hash-table->alist changed)))
(case (if (args:get-arg "-dumpmode")
(string->symbol (args:get-arg "-dumpmode"))
'bash)
((bash)
(if a
(begin
(print "# Added vars")
(map (lambda (dat)(print "export " (car dat) "=" (cdr dat)))
(hash-table->alist added))))
(if r
(begin
(print "# Removed vars")
(map (lambda (dat)(print "unset " (car dat)))
(hash-table->alist removed))))
(if c
(begin
(print "# Changed vars")
(map (lambda (dat)(print "export " (car dat) "=" (cdr dat)))
(hash-table->alist changed)))))
((csh)
(if a
(begin
(print "# Added vars")
(map (lambda (dat)(print "setenv " (car dat) " " (cdr dat)))
(hash-table->alist added))))
(if r
(begin
(print "# Removed vars")
(map (lambda (dat)(print "unsetenv " (car dat)))
(hash-table->alist removed))))
(if c
(begin
(print "# Changed vars")
(map (lambda (dat)(print "setenv " (car dat) " " (cdr dat)))
(hash-table->alist changed)))))
((config ini)
(if a
(begin
(print "# Added vars")
(map (lambda (dat)
(let ((var (car dat))
(val (cdr dat)))
(if (and inc-path
(equal? var "PATH"))
(env:inc-path val)
(print var " " val))))
(hash-table->alist added))))
(if r
(begin
(print "# Removed vars")
(map (lambda (dat)(print "#{scheme (unsetenv \"" (car dat) "\")}"))
(hash-table->alist removed))))
(if c
(begin
(print "# Changed vars")
(map (lambda (dat)
(let ((var (car dat))
(val (cdr dat)))
(if (and inc-path
(equal? var "PATH"))
(env:inc-path val)
(print var " " val))))
(hash-table->alist changed)))))
(else
(debug:print-error 0 *default-log-port* "No dumpmode specified, use -dumpmode [bash|csh|config]")))))
;;======================================================================
;; ezsteps
;;======================================================================
(define (ezsteps:run-from testdat start-step-name run-one)
;;# TODO - recapture item variables, debug repeated step eval; regen logpro from test
(let* ((do-update-test-state-status #f)
(test-run-dir ;; (filedb:get-path *fdb*
(db:test-get-rundir testdat)) ;; )
(testconfig (read-config (conc test-run-dir "/testconfig") #f #t environ-patt: "pre-launch-env-vars"))
(ezstepslst (hash-table-ref/default testconfig "ezsteps" '()))
(run-mutex (make-mutex))
(rollup-status 0)
(rollup-status-string #f)
(rollup-status-sym #f)
(exit-info (vector #t #t #t))
(test-id (db:test-get-id testdat))
(run-id (db:test-get-run_id testdat))
(test-name (db:test-get-testname testdat))
(orig-test-state (db:test-get-state testdat))
(orig-test-status (db:test-get-status testdat))
(kill-job #f)) ;; for future use (on re-factoring with launch.scm code
;; keep trying till NFS deigns to populate test run dir on this host
(let loop ((count 5))
(if (not (common:file-exists? test-run-dir))
;;(push-directory test-run-dir)
(if (> count 0)
(begin
(debug:print 0 *default-log-port* "WARNING: ezsteps attempting to run but test run directory " test-run-dir " is not there. Waiting and trying again " count " more times")
(sleep 3)
(loop (- count 1))))))
(debug:print-info 0 *default-log-port* "Running in directory " test-run-dir)
(if (not (common:file-exists? ".ezsteps"))(create-directory ".ezsteps"))
;; if ezsteps was defined then we are sure to have at least one step but check anyway
(if (not (> (length ezstepslst) 0))
(message-window "ERROR: You can only re-run steps defined via ezsteps")
(begin
(let loop ((ezstep (car ezstepslst))
(tal (cdr ezstepslst))
(status-sym-so-far 'pass)
;;(runflag #f)
(saw-start-step-name #f)) ;; flag used to skip steps when not starting at the beginning
(if (vector-ref exit-info 1)
(let* ((stepname (car ezstep)) ;; do stuff to run the step
(logpro-used (common:file-exists? (conc test-run-dir "/" stepname ".logpro")))
(stepinfo (cadr ezstep))
(stepparts (string-match (regexp "^(\\{([^\\}]*)\\}\\s*|)(.*)$") stepinfo))
(stepparms (list-ref stepparts 2)) ;; for future use, {VAR=1,2,3}, run step for each
(stepcmd (list-ref stepparts 3))
(script (conc "mt_ezstep '"test-run-dir"' '"stepname"' '"stepcmd"'")) ;; call the command using mt_ezstep
(saw-start-step-name-next (or saw-start-step-name (equal? stepname start-step-name)))
(proceed-with-this-step
(or (not start-step-name)
(equal? stepname start-step-name)
(and saw-start-step-name (not run-one))
saw-start-step-name-next
(and start-step-name (equal? stepname start-step-name))))
)
(set! do-update-test-state-status (and proceed-with-this-step (null? tal)))
;;(BB> "stepname="stepname" proceed-with-this-step="proceed-with-this-step " do-update-test-state-status="do-update-test-state-status " orig-test-state="orig-test-state" orig-test-status="orig-test-status)
(cond
((and (not proceed-with-this-step) (null? tal))
'done)
((not proceed-with-this-step)
(loop (car tal)
(cdr tal)
status-sym-so-far
saw-start-step-name-next))
(else
(debug:print 4 *default-log-port* "ezsteps:\n stepname: " stepname " stepinfo: " stepinfo " stepparts: " stepparts
" stepparms: " stepparms " stepcmd: " stepcmd)
(debug:print 4 *default-log-port* "script: " script)
(rmt:teststep-set-status! run-id test-id stepname "start" "-" #f #f)
;; now launch the script
(let ((pid (process-run script)))
(let processloop ((i 0))
(let-values (((pid-val exit-status exit-code)(process-wait pid #t)))
(mutex-lock! run-mutex)
(vector-set! exit-info 0 pid)
(vector-set! exit-info 1 exit-status)
(vector-set! exit-info 2 exit-code)
(mutex-unlock! run-mutex)
(if (eq? pid-val 0)
(begin
(thread-sleep! 1)
(processloop (+ i 1))))
))
(let ((exinfo (vector-ref exit-info 2))
(logfna (if logpro-used (conc stepname ".html") "")))
(rmt:teststep-set-status! run-id test-id stepname "end" exinfo #f logfna))
(if logpro-used
(rmt:test-set-log! run-id test-id (conc stepname ".html")))
;; set the test final status
(let* ((this-step-status (cond
(logpro-used
(common:logpro-exit-code->status-sym (vector-ref exit-info 2)))
((eq? (vector-ref exit-info 2) 0)
'pass)
(else
'fail)))
(overall-status-sym (common:worse-status-sym this-step-status status-sym-so-far))
(overall-status-string (status-sym->string overall-status-sym)))
(debug:print 4 *default-log-port* "Exit value received: " (vector-ref exit-info 2) " logpro-used: " logpro-used
" this-step-status: " this-step-status " overall-status: " overall-status-sym)
;;" next-status: " next-status " rollup-status: " rollup-status)
(set! rollup-status-string overall-status-string)
(set! rollup-status-sym overall-status-sym)
(tests:test-set-status! run-id test-id "RUNNING" overall-status-string #f #f)))
(if (and
(not run-one)
(common:steps-can-proceed-given-status-sym rollup-status-sym)
(not (null? tal)))
(loop (car tal)
(cdr tal)
rollup-status-sym
saw-start-step-name-next)))))
(debug:print 4 *default-log-port* "WARNING: a prior step failed, stopping at " ezstep)))
;; Once done with step/steps update the test record
;;
(let* ((item-path (db:test-get-item-path testdat)) ;; (item-list->path itemdat))
(testinfo (rmt:get-testinfo-state-status run-id test-id))) ;; refresh the testdat, call it iteminfo in case need prev/curr
;; Am I completed?
(if (equal? (db:test-get-state testinfo) "RUNNING") ;; (not (equal? (db:test-get-state testinfo) "COMPLETED"))
(let ((new-state (if kill-job "KILLED" "COMPLETED") ;; (if (eq? (vector-ref exit-info 2) 0) ;; exited with "good" status
;; "COMPLETED"
;; (db:test-get-state testinfo))) ;; else preseve the state as set within the test
)
(new-status rollup-status-string)
) ;; (db:test-get-status testinfo)))
(debug:print-info 2 *default-log-port* "Test NOT logged as COMPLETED, (state=" (db:test-get-state testinfo) "), updating result, rollup-status is " rollup-status)
(tests:test-set-status! run-id test-id
(if do-update-test-state-status new-state orig-test-state)
(if do-update-test-state-status new-status orig-test-status)
(args:get-arg "-m") #f)
;; need to update the top test record if PASS or FAIL and this is a subtest
(if (and (not (equal? item-path "")) do-update-test-state-status)
(rmt:set-state-status-and-roll-up-items run-id test-name item-path new-state new-status #f))))
;; for automated creation of the rollup html file this is a good place...
(if (not (equal? item-path ""))
(tests:summarize-items run-id test-id test-name #f)) ;; don't force - just update if no
)))
;;(pop-directory)
rollup-status-string))
(define (ezsteps:spawn-run-from testdat start-step-name run-one)
(thread-start!
(make-thread
(lambda ()
(ezsteps:run-from testdat start-step-name run-one))
(conc "ezstep run single step " start-step-name " run-one="run-one)))
)
;;======================================================================
;; genexample
;;======================================================================
(define genexample:example-logpro
#<<EOF
;; You should have at least one expect:required. This ensures that your process ran
;; comment out the line below and replace "put pattern here" with a pattern that will
;; always be seen in your log file if the step runs successfully.
;;
;; (expect:required in "LogFileBody" > 0 "Put description here" #/put pattern here/)
;;
;; You may need ignores to suppress false error or warning hits from the later expects
;; NOTE: Order is important here!
(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/)
(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/)
(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/)) ;; but disallow any other errors
EOF
)
(define genexample:example-script
#<<EOF
#!/usr/bin/env bash
# Run your step here
EOF
)
(define (genexample:mk-megatest.config)
(let ((keystr #f)
(keys #f)
(lntree #f)
(path #f)
(firstd #f))
(print "Note: don't worry too much about typos in this process, you will be able to edit
the generated files before starting your first runs")
;; create the needed area
(print "==================\nWhere can I create your Megatest regresssion/continuous build area? Note, your \n"
"tests will not necessarily be run in this area, disk space needs are modest. Current directory is:\n\n"
(current-directory) "\n")
(display "Enter your megatest directory: ")
(set! path (read-line))
(if (not (directory? path))
(begin
(print "The path " path " does not exist or is not a directory. Attempting to create it now")
(create-directory path #t)))
;; First check that the directory is empty!
(if (and (common:file-exists? path)
(not (null? (glob (conc path "/*")))))
(begin
(print "WARNING: directory " path " is not empty, are you sure you want to continue?")
(display "Enter y/n: ")
(if (equal? "y" (read-line))
(print "Using directory " path " for your Megatest area.")
(begin
(print "INFO: Creation of megatest files in " path " aborted")
(exit 1)))))
;; first prompt user for fields
;;
(print
"==================
Next you must specify fields or keys for your megatest area. These
will be used to organise your runs. One field should probably be
\"RELEASE\". Other examples of useful fields might be \"PLATFORM\",
\"TARGET_OS\" or if you are in the semiconductor business perhaps
things like \"TECHNOLOGY_NODE\", \"DESIGN_KIT\" or \"METAL_STACK\".
The all caps is a convention because the variables you choose will be
available to your tests as environment variables. You can edit these
values later but it is generally a good idea to settle on them
early.
Your runs will be stored in directories specified by your
keys. Example, if you have keys OSFAMILY/VARIANT/OSVER/RELEASE you may
get a test \"build\" in a directory like this:
linux/ubuntu/11.04/rev_1.2/build
Please enter your keys now, separated by spaces or slashes. Only alpha-numeric characters,
upper case recommended. Example: COMPILER_VER/RELEASE_NAME/QUAL_LEVEL
")
(set! keys (let loop ((keystr ""))
(if (equal? keystr "q")
(begin
(print "Quiting ...")
(exit))
(let ((keylst (apply append
(map string-split (string-split keystr "/")))))
(if (or (null? keylst)
(not (null? (filter string-null? keylst))))
(begin
(display "Enter keys separated by spaces or slashes: ")
(loop (read-line)))
keylst)))))
(print "You have choosen " (string-intersperse keys ", ") " for your keys.")
;; Now get the link tree location and a first disk
(print
"==================
Now you need an initial place to store your runs. These are called \"disks\" and you
can add more at any time. To get going provide a writeable directory name.
")
(display "Enter your test runs directory: ")
(set! firstd (read-line))
(if (not (directory? firstd))
(begin
(print "WARNING: you have specified a path " firstd " that does not exist. Attempting to create it...\n")
(create-directory firstd #t)))
(print
"==================
Megatest uses a tree of symlinks to provide a uniform structure for finding all the tests
you run over time. Please provide a path where we can create this link tree.
")
(display "Enter link tree directory: ")
(set! lntree (read-line))
(if (not (directory? lntree))
(begin
(print "WARNING: you have specified a path " lntree "that does not exist. Attempting to create it...\n")
(create-directory lntree #t)))
(with-output-to-file (conc path "/megatest.config")
(lambda ()
(print "# This area uses Megatest. Learn more at http://www.kiatoa.com/fossils/megatest.")
(print "#\n")
(print "[fields]")
(map (lambda (k)(print k " TEXT")) keys)
(print "")
(print "[setup]")
(print "# Adjust max_concurrent_jobs to limit how much you load your machines")
(print "max_concurrent_jobs 50\n")
(print "# This is your link path. Avoid moving it once set.")
(print "linktree " (common:real-path lntree))
(print "\n# Job tools are more advanced ways to control how your jobs are launched")
(print "[jobtools]\nuseshell yes\nlauncher nbfake\nmaxload 1.5\n")
(print "# You can override environment variables for all your tests here")
(print "[env-override]\nEXAMPLE_VAR example value\n")
(print "# As you run more tests you may need to add additional disks, the names are arbitrary but must be unique")
(print "[disks]\ndisk0 " (common:real-path firstd))))
(print
"==================
I'm now creating a runconfigs.config file for you with a default section.
You can use this file to set variables for your tests based on the \"target\" (the combination
of keys).
")
(with-output-to-file (conc path "/runconfigs.config")
(lambda ()
(print "# The variables in the default category will be seen in all runs\n[default]\nALLTESTS see this variable\n")
(print "# Your variables here are grouped by targets [" (string-intersperse keys "/") "]")
(let ((example-target (string-intersperse (map (lambda (k)(conc k "_val")) keys) "/")))
(print "[" example-target "]")
(print "ANOTHERVAR only defined if target is " example-target))
(print "\n# It can be handy to include a file based on the users unix username.\n"
"# To prevent cluttering up the top level directory we'll put this file\n# in a directory called \"configs\".")
(print "[include #{getenv USER}.config]")
))
(create-directory (conc path "/configs") #t)
(with-output-to-file (conc path "/configs/" (current-user-name) ".config")
(lambda ()
(print "# Override settings in ../runconfigs.config for user " (current-user-name) " here.")))
;; Now create a test and logpro file
(print
"==================
You now have the basic common files for your megatest setup. Next run
\"megatest -gen-test\" to create a test.
Thank you for using Megatest.
You can edit your config files and create tests in the " path " directory
")))
;;======================================================================
;; create skeleton files for a test
;;======================================================================
(define (genexample:mk-megatest-test testname)
;; Gather needed data
(let ((waiton #f)
(priority #f)
(description #f)
(steps '())
(scripts '())
(items '())
(rel-path #f))
(cond
((common:file-exists? "megatest.config") (set! rel-path "./"))
((common:file-exists? "../megatest.config") (set! rel-path "../"))
((common:file-exists? "../../megatest.config") (set! rel-path "../../"))
((common:file-exists? "../../../megatest.config")(set! rel-path "../../../"))) ;; good enough dang it.
;; Don't gather data or continue if a) megatest.config can't be found or b) testconfig already exists
(if (not rel-path)
(begin
(print "ERROR: I could not find megatest.config, please run -create-test in the top dir of your megatest area")
(exit 1)))
(if (common:file-exists? (conc rel-path "tests/" testname "/testconfig"))
(begin
(print "WARNING: You already have a testconfig in " rel-path "tests/" testname ", do you want to clobber your files?")
(display "Enter y/n: ")
(if (not (equal? "y" (read-line)))
(begin
(print "INFO: user abort of creation of test " testname)
(exit 1)))))
(print "We are going to generate a skeleton set of files for your test " testname "\n"
" *** Note: do not worry too much about typos, you can edit the files created when you are done.")
(print "\n==================\nPlease describe this test. The description will be visible in various dialogs and reports")
(display "Enter one line description for this test: ")
(set! description (read-line))
(print "\n\n==================\nDoes this test, " testname ", require any other test be run prior to launch?")
(display (conc "Enter space delimited list of tests which " testname " must wait for (default is no waiton): "))
(set! waiton (read-line))
(print "\n\n==================\nDo you wish to prioritize the running of this test over other tests? If so")
(print "enter a number greater than zero here")
(display "Enter a priority of 0 (default) or higher: ")
(set! priority (read-line))
;; Get the steps
(print "\n==================\nNow to enter the one or more steps that make up your test, note; you can add more later")
(print "Hint; use .sh extension on the script names and we'll create a placeholder script."
(let ((stepname #f)
(scriptname #f))
(let loop ((done #f))
(display "Enter the name for this step (blank to stop): ")
(set! stepname (read-line))
(if (not (equal? stepname ""))
(begin
(display "Enter the script or progam to run: ")
(set! scriptname (read-line))
(set! steps (append steps (list (list stepname scriptname))))))
(if (not (equal? stepname ""))
(begin
(print "Added step " stepname " to list of steps.\n")
(loop #f)))))
;; Get the items
(print "\n\n==================\nNext we need to get the variables and values you wish to iterate this test over (blank for none)")
(let ((varname #f)
(values #f))
(let loop ((done #f))
(display "Enter the variable name: ")
(set! varname (read-line))
(if (not (equal? varname ""))
(begin
(display (conc "Enter the space separated list of values for " varname ": "))
(set! values (read-line))
(set! items (append items (list (conc varname " " values))))))
(if (not (equal? varname ""))
(loop #f))))
;; Now create the test
(if (not rel-path)
(begin
(print "ERROR: You must run this command in a megatest area under where the megatest.config file exists.")
(exit 1))
(let ((testdir (conc rel-path "tests/" testname)))
(create-directory testdir #t)
(with-output-to-file (conc testdir "/testconfig")
(lambda ()
(print "# Add additional steps here. Format is \"stepname script\"\n[ezsteps]")
(map (lambda (stp)(print (string-intersperse stp " "))) steps)
(print "")
(print "# Test requirements are specified here\n[requirements]")
(print (if (string-null? waiton) "# " "") "waiton " waiton)
(print "priority " (if (string-null? priority) 0 priority) "\n")
(print "# Iteration for your test is controlled by the items section\n[items]")
(map print items)
(print "")
(print "# Alternatively you could use a [itemstable] section")
(print "# [itemstable]")
(print "# ITEMVAR1 a b c")
(print "# ITEMVAR2 d e f")
(print "#\n# would result in items: a/d b/e c/f\n#\n")
(print "# Logpro rules for each step can be captured here in the testconfig")
(print "# note: The ;; after the stepname and the leading whitespace are required")
(print "#\n[logpro]\n")
(for-each (lambda (step)
(let ((stepname (car step))
(scriptname (cadr step)))
(print stepname " ;; rules for checking output from running step " step " with command " scriptname)
(print genexample:example-logpro "\n")))
steps)
(print "# test_meta is a section for storing additional data on your test\n[test_meta]")
(print "author " (get-environment-variable "USER"))
(print "owner " (get-environment-variable "USER"))
(print "description " description)
(print "tags tagone,tagtwo")
(print "reviewed never")))
;; Now create shell scripts (if extension is .sh) and logpro files
(for-each (lambda (stp)
(let ((stepname (car stp))
(script (cadr stp)))
(if (string-match ".*\\.sh$" script)
(begin
(with-output-to-file (conc testdir "/" script)
(lambda ()
(print genexample:example-script)))
(system (conc "chmod ug+r,a+x " (conc testdir "/" script)))))))
steps))))))
;;======================================================================
;; gutils
;;======================================================================
;; NOTE: These functions will move to iuputils
(define (gutils: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))))
(define gutils:colors
'((PASS . "70 249 73")
(FAIL . "253 33 49")
(SKIP . "230 230 0")))
(define (gutils:get-color-spec effective-state)
(or (alist-ref effective-state gutils:colors)
(alist-ref 'FAIL gutils:colors)))
;; BBnote - state status dashboard button color / text defined here
(define (gutils:get-color-for-state-status state status);; #!key (get-label #f))
;; ((if get-label cadr car)
(case (string->symbol state)
((COMPLETED) ;; ARCHIVED)
(case (string->symbol status)
((PASS) (list "70 249 73" status))
((PREQ_FAIL PREQ_DISCARDED) (list "255 127 127" status))
((WARN WAIVED) (list "255 172 13" status))
((SKIP) (list (gutils:get-color-spec 'SKIP) status))
((ABORT) (list "198 36 166" status))
(else (list "253 33 49" status))))
((ARCHIVED)
(case (string->symbol status)
((PASS) (list "70 170 73" status))
((WARN WAIVED) (list "200 130 13" status))
((SKIP) (list (gutils:get-color-spec 'SKIP) status))
(else (list "180 33 49" status))))
;; (if (equal? status "PASS")
;; '("70 249 73" "PASS")
;; (if (or (equal? status "WARN")
;; (equal? status "WAIVED"))
;; (list "255 172 13" status)
;; (list "223 33 49" status)))) ;; greenish orangeish redish
((LAUNCHED) (list "101 123 142" state))
((CHECK) (list "255 100 50" state))
((REMOTEHOSTSTART) (list "50 130 195" state))
((RUNNING STARTED) (list "9 131 232" state))
((KILLREQ) (list "39 82 206" state))
((KILLED) (list "234 101 17" state))
((NOT_STARTED) (case (string->symbol status)
((CHECK STARTED)(list (gutils:get-color-spec 'SKIP) state))
(else (list "240 240 240" state))))
;; for xor mode below
;;
((CLEAN)
(case (string->symbol status)
((CLEAN-FAIL CLEAN-CHECK CLEAN-ABORT) (list "200 130 13" status)) ;; orange requested for these
(else (list "60 235 63" status))))
((DIRTY-BETTER) (list "160 255 153" status))
((DIRTY-WORSE) (list "165 42 42" status))
((BOTH-BAD) (list "180 33 49" status))
(else (list "192 192 192" state))))
;;======================================================================
;; http-transport
;;======================================================================
(define (http-transport:make-server-url hostport)
(if (not hostport)
#f
(conc "http://" (car hostport) ":" (cadr hostport))))
(define *server-loop-heart-beat* (current-seconds))
;;======================================================================
;; S E R V E R
;; ======================================================================
;; Call this to start the actual server
;;
(define *db:process-queue-mutex* (make-mutex))
(define (http-transport:run hostn)
(debug:print 2 *default-log-port* "Attempting to start the server ...")
(let* ((db #f) ;; (open-db)) ;; we don't want the server to be opening and closing the db unnecesarily
(hostname (get-host-name))
(ipaddrstr (let ((ipstr (if (string=? "-" hostn)
;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".")
(server:get-best-guess-address hostname)
#f)))
(if ipstr ipstr hostn))) ;; hostname)))
(start-port (portlogger:open-run-close portlogger:find-port))
(link-tree-path (common:get-linktree))
(tmp-area (common:get-db-tmp-area *alldat*))
(start-file (conc tmp-area "/.server-start")))
(debug:print-info 0 *default-log-port* "portlogger recommended port: " start-port)
;; set some parameters for the server
(root-path (if link-tree-path
link-tree-path
(current-directory))) ;; WARNING: SECURITY HOLE. FIX ASAP!
(handle-directory spiffy-directory-listing)
(handle-exception (lambda (exn chain)
(signal (make-composite-condition
(make-property-condition
'server
'message "server error")))))
;; http-transport:handle-directory) ;; simple-directory-handler)
;; Setup the web server and a /ctrl interface
;;
(vhost-map `(((* any) . ,(lambda (continue)
;; open the db on the first call
;; This is were we set up the database connections
(let* (($ (request-vars source: 'both))
(dat ($ 'dat))
(res #f))
(cond
((equal? (uri-path (request-uri (current-request)))
'(/ "api"))
(send-response body: (api:process-request *dbstruct-db* $) ;; the $ is the request vars proc
headers: '((content-type text/plain)))
(mutex-lock! *heartbeat-mutex*)
(set! *db-last-access* (current-seconds))
(mutex-unlock! *heartbeat-mutex*))
((equal? (uri-path (request-uri (current-request)))
'(/ ""))
(send-response body: (http-transport:main-page)))
((equal? (uri-path (request-uri (current-request)))
'(/ "json_api"))
(send-response body: (http-transport:main-page)))
((equal? (uri-path (request-uri (current-request)))
'(/ "runs"))
(send-response body: (http-transport:main-page)))
((equal? (uri-path (request-uri (current-request)))
'(/ any))
(send-response body: "hey there!\n"
headers: '((content-type text/plain))))
((equal? (uri-path (request-uri (current-request)))
'(/ "hey"))
(send-response body: "hey there!\n"
headers: '((content-type text/plain))))
((equal? (uri-path (request-uri (current-request)))
'(/ "jquery3.1.0.js"))
(send-response body: (http-transport:show-jquery)
headers: '((content-type application/javascript))))
((equal? (uri-path (request-uri (current-request)))
'(/ "test_log"))
(send-response body: (http-transport:html-test-log $)
headers: '((content-type text/HTML))))
((equal? (uri-path (request-uri (current-request)))
'(/ "dashboard"))
(send-response body: (http-transport:html-dboard $)
headers: '((content-type text/HTML))))
(else (continue))))))))
(with-output-to-file start-file (lambda ()(print (current-process-id))))
(http-transport:try-start-server ipaddrstr start-port)))
;; This is recursively run by http-transport:run until sucessful
;;
(define (http-transport:try-start-server ipaddrstr portnum)
(let ((config-hostname (configf:lookup *configdat* "server" "hostname"))
(config-use-proxy (equal? (configf:lookup *configdat* "client" "use-http_proxy") "yes")))
(if (not config-use-proxy)
(determine-proxy (constantly #f)))
(debug:print-info 0 *default-log-port* "http-transport:try-start-server time=" (seconds->time-string (current-seconds)) " ipaddrsstr=" ipaddrstr " portnum=" portnum " config-hostname=" config-hostname)
(handle-exceptions
exn
(begin
(print-error-message exn)
(if (< portnum 64000)
(begin
(debug:print 0 *default-log-port* "WARNING: attempt to start server failed. Trying again ...")
(debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
(debug:print 5 *default-log-port* "exn=" (condition->list exn))
(portlogger:open-run-close portlogger:set-failed portnum)
(debug:print 0 *default-log-port* "WARNING: failed to start on portnum: " portnum ", trying next port")
(thread-sleep! 0.1)
;; get_next_port goes here
(http-transport:try-start-server ipaddrstr
(portlogger:open-run-close portlogger:find-port)))
(begin
(print "ERROR: Tried and tried but could not start the server"))))
;; any error in following steps will result in a retry
(set! *server-info* (list ipaddrstr portnum))
(debug:print 0 *default-log-port* "INFO: Trying to start server on " ipaddrstr ":" portnum)
;; This starts the spiffy server
;; NEED WAY TO SET IP TO #f TO BIND ALL
;; (start-server bind-address: ipaddrstr port: portnum)
(if config-hostname ;; this is a hint to bind directly
(start-server port: portnum bind-address: (if (equal? config-hostname "-")
ipaddrstr
config-hostname))
(start-server port: portnum))
(portlogger:open-run-close portlogger:set-port portnum "released")
(debug:print 1 *default-log-port* "INFO: server has been stopped"))))
;;======================================================================
;; S E R V E R U T I L I T I E S
;;======================================================================
;;======================================================================
;; C L I E N T S
;;======================================================================
(define *http-mutex* (make-mutex))
;; NOTE: Large block of code from 32436b426188080f72fceb6894af541fbad9921e removed here
;; I'm pretty sure it is defunct.
;; This next block all imported en-mass from the api branch
(define *http-requests-in-progress* 0)
(define *http-connections-next-cleanup* (current-seconds))
(define (http-transport:get-time-to-cleanup)
(let ((res #f))
(mutex-lock! *http-mutex*)
(set! res (> (current-seconds) *http-connections-next-cleanup*))
(mutex-unlock! *http-mutex*)
res))
(define (http-transport:inc-requests-count)
(mutex-lock! *http-mutex*)
(set! *http-requests-in-progress* (+ 1 *http-requests-in-progress*))
;; Use this opportunity to slow things down iff there are too many requests in flight
(if (> *http-requests-in-progress* 5)
(begin
(debug:print-info 0 *default-log-port* "Whoa there buddy, ease up...")
(thread-sleep! 1)))
(mutex-unlock! *http-mutex*))
(define (http-transport:dec-requests-count proc)
(mutex-lock! *http-mutex*)
(proc)
(set! *http-requests-in-progress* (- *http-requests-in-progress* 1))
(mutex-unlock! *http-mutex*))
(define (http-transport:dec-requests-count-and-close-all-connections)
(set! *http-requests-in-progress* (- *http-requests-in-progress* 1))
(let loop ((etime (+ (current-seconds) 5))) ;; give up in five seconds
(if (> *http-requests-in-progress* 0)
(if (> etime (current-seconds))
(begin
(thread-sleep! 0.05)
(loop etime))
(debug:print-error 0 *default-log-port* "requests still in progress after 5 seconds of waiting. I'm going to pass on cleaning up http connections"))
(close-all-connections!)))
(set! *http-connections-next-cleanup* (+ (current-seconds) 10))
(mutex-unlock! *http-mutex*))
(define (http-transport:inc-requests-and-prep-to-close-all-connections)
(mutex-lock! *http-mutex*)
(set! *http-requests-in-progress* (+ 1 *http-requests-in-progress*)))
;; Send "cmd" with json payload "params" to serverdat and receive result
;;
(define (http-transport:client-api-send-receive run-id serverdat cmd params #!key (numretries 3)(area-dat #f))
(let* ((fullurl (if (vector? serverdat)
(http-transport:server-dat-get-api-req serverdat)
(begin
(debug:print 0 *default-log-port* "FATAL ERROR: http-transport:client-api-send-receive called with no server info")
(exit 1))))
(res (vector #f "uninitialized"))
(success #t)
(sparams (db:obj->string params transport: 'http))
(areadat (or area-dat *areadat*)))
(debug:print-info 11 *default-log-port* "fullurl=" fullurl ", cmd=" cmd ", params=" params ", run-id=" run-id "\n")
;; set up the http-client here
(max-retry-attempts 1)
;; consider all requests indempotent
(retry-request? (lambda (request)
#f))
;; send the data and get the response
;; extract the needed info from the http data and
;; process and return it.
(let* ((send-recieve (lambda ()
(mutex-lock! *http-mutex*)
;; (condition-case (with-input-from-request "http://localhost"; #f read-lines)
;; ((exn http client-error) e (print e)))
(set! res (vector ;;; DON'T FORGET - THIS IS THE CLIENT SIDE! NOTE: consider moving this to client.scm since we are only supporting http transport at this time.
success
(db:string->obj
(handle-exceptions
exn
(let ((call-chain (get-call-chain))
(msg ((condition-property-accessor 'exn 'message) exn)))
(set! success #f)
(if (debug:debug-mode 1)
(debug:print-info 0 *default-log-port* "couldn't talk to server, trying again ...")
(begin
(debug:print 0 *default-log-port* "WARNING: failure in with-input-from-request to " fullurl ".")
(debug:print 0 *default-log-port* " message: " msg)
(debug:print 0 *default-log-port* " cmd: " cmd " params: " params)
(debug:print 0 *default-log-port* " call-chain: " call-chain)))
(if areadat
(areadat-conndat-set! areadat #f))
;; Killing associated server to allow clean retry.")
;; (tasks:kill-server-run-id run-id) ;; better to kill the server in the logic that called this routine?
(mutex-unlock! *http-mutex*)
;;; (signal (make-composite-condition
;;; (make-property-condition 'commfail 'message "failed to connect to server")))
;;; "communications failed"
(db:obj->string #f)) ;; end of the error handling part
(with-input-from-request ;; was dat
fullurl
(list (cons 'key (or *server-id* "thekey"))
(cons 'cmd cmd)
(cons 'params sparams))
read-string))
transport: 'http)
0)) ;; added this speculatively
;; Shouldn't this be a call to the managed call-all-connections stuff above?
(close-all-connections!)
(mutex-unlock! *http-mutex*)
))
(time-out (lambda ()
(thread-sleep! 45)
#f))
(th1 (make-thread send-recieve "with-input-from-request"))
(th2 (make-thread time-out "time out")))
(thread-start! th1)
(thread-start! th2)
(thread-join! th1)
(thread-terminate! th2)
(debug:print-info 11 *default-log-port* "got res=" res)
(if (vector? res)
(if (vector-ref res 0) ;; this is the first flag or the second flag?
res ;; this is the *inner* vector? seriously? why?
(if (debug:debug-mode 11)
(let ((call-chain (get-call-chain))) ;; note: this code also called in nmsg-transport - consider consolidating it
(print-call-chain (current-error-port))
(debug:print-error 11 *default-log-port* "error above occured at server, res=" res) ;; there is NO exn at this time " message: " ((condition-property-accessor 'exn 'message) exn))
(debug:print 11 *default-log-port* " server call chain:")
(pp (vector-ref res 1) (current-error-port))
(signal (vector-ref res 0)))
res))
(signal (make-composite-condition
(make-property-condition
'timeout
'message "nmsg-transport:client-api-send-receive-raw timed out talking to server")))))))
;; careful closing of connections stored in *alldat*
;;
(define (http-transport:close-connections #!key (all-dat #f))
(let* ((alldat (or all-dat *alldat*))
(server-dat (if alldat
(alldat-conndat alldat)
#f))) ;; (hash-table-ref/default *areadat* run-id #f)))
(if (vector? server-dat)
(let ((api-dat (http-transport:server-dat-get-api-uri server-dat)))
(handle-exceptions
exn
(begin
(print-call-chain *default-log-port*)
(debug:print-error 0 *default-log-port* " closing connection failed with error: " ((condition-property-accessor 'exn 'message) exn)))
(close-connection! api-dat)
;;(close-idle-connections!)
#t))
#f)))