@@ -31,11 +31,11 @@ (include "common_records.scm") (include "db_records.scm") (include "key_records.scm") (define help (conc -"Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest + "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 @@ -54,36 +54,19 @@ "-debug" ) (list "-h" "-v" "-q" - ) + ) args:arg-hash 0)) (if (args:get-arg "-h") (begin (print help) (exit))) -;;; REMOVE ME, this is a stop-gap -(define *area-dat* (make-megatest:area - "default" ;; area name - #f ;; area path - 'http ;; transport - #f ;; configinfo - #f ;; configdat - (make-hash-table) ;; denoise - #f ;; client signature - #f ;; remote connections - )) - -(if (not (launch:setup-for-run *area-dat*)) - (begin - (print "Failed to find megatest.config, exiting") - (exit 1))) - ;; (if (args:get-arg "-host") ;; (begin ;; (set! (common:get-remote remote) (string-split (args:get-arg "-host" ":"))) ;; (client:launch)) ;; (client:launch)) @@ -200,11 +183,11 @@ (iup:attribute-set! validvals-matrix "WIDTH1" "290") (iup:attribute-set! envovrd-matrix "WIDTH1" "290") (iup:vbox (iup:hbox - + (iup:vbox (let ((tabs (iup:tabs ;; The required tab (iup:hbox ;; The keys @@ -250,11 +233,11 @@ validvals-matrix) )))) (iup:attribute-set! tabs "TABTITLE0" "Required settings") (iup:attribute-set! tabs "TABTITLE1" "Optional settings") tabs)) - )))) + )))) ;; The runconfigs.config file ;; (define (rconfig window-id) (iup:vbox @@ -358,12 +341,12 @@ ;; (iup:attribute-set! mat "0:0" "Var") (iup:attribute-set! mat "HEIGHT0" 0) (iup:attribute-set! mat "ALIGNMENT1" "ALEFT") ;; (iup:attribute-set! mat "FIXTOTEXT" "C1") (iup:attribute-set! mat "RESIZEMATRIX" "YES")) - ;; (iup:attribute-set! mat "WIDTH1" "120") - ;; (iup:attribute-set! mat "WIDTH0" "100")) + ;; (iup:attribute-set! mat "WIDTH1" "120") + ;; (iup:attribute-set! mat "WIDTH0" "100")) (list run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix)) ;; Steps matrix (iup:attribute-set! steps-matrix "0:1" "Step Name") (iup:attribute-set! steps-matrix "0:2" "Start") @@ -406,44 +389,44 @@ (list (list run-info-matrix '("Run Id" "Target" "Runname" "Run Start Time" )) (list test-info-matrix '("Test Id" "Testname" "Itempath" "State" "Status" "Test Start Time" "Comment")) (list test-run-matrix '("Hostname" "Host info" "Disk Free" "CPU Load" "Run Duration")) (list meta-dat-matrix '("Author" "Owner" "Last Reviewed" "Tags" "Description")))) - - (iup:split - #:orientation "HORIZONTAL" - (iup:vbox - (iup:hbox - (iup:vbox - run-info-matrix - test-info-matrix) - ;; test-info-matrix) - (iup:vbox - test-run-matrix - meta-dat-matrix)) - (iup:vbox - (iup:vbox - (iup:hbox - (iup:button "View Log" #:action viewlog #:size "60x" ) ;; #:size "30x" - (iup:button "Start Xterm" #:action xterm #:size "60x" )) ;; #:size "30x" - (iup:hbox - (iup:button "Run Test" #:action run-test #:size "60x" ) ;; #:size "30x" - (iup:button "Clean Test" #:action remove-test #:size "60x" ))) ;; #:size "30x" - (iup:hbox - ;; hiup:split ;; hbox - ;; #:orientation "HORIZONTAL" - ;; #:value 300 - command-text-box - command-launch-button))) - (iup:vbox - (let ((tabs (iup:tabs - steps-matrix - data-matrix))) - (iup:attribute-set! tabs "TABTITLE0" "Test Steps") - (iup:attribute-set! tabs "TABTITLE1" "Test Data") - tabs))))) - + + (iup:split + #:orientation "HORIZONTAL" + (iup:vbox + (iup:hbox + (iup:vbox + run-info-matrix + test-info-matrix) + ;; test-info-matrix) + (iup:vbox + test-run-matrix + meta-dat-matrix)) + (iup:vbox + (iup:vbox + (iup:hbox + (iup:button "View Log" #:action viewlog #:size "60x" ) ;; #:size "30x" + (iup:button "Start Xterm" #:action xterm #:size "60x" )) ;; #:size "30x" + (iup:hbox + (iup:button "Run Test" #:action run-test #:size "60x" ) ;; #:size "30x" + (iup:button "Clean Test" #:action remove-test #:size "60x" ))) ;; #:size "30x" + (iup:hbox + ;; hiup:split ;; hbox + ;; #:orientation "HORIZONTAL" + ;; #:value 300 + command-text-box + command-launch-button))) + (iup:vbox + (let ((tabs (iup:tabs + steps-matrix + data-matrix))) + (iup:attribute-set! tabs "TABTITLE0" "Test Steps") + (iup:attribute-set! tabs "TABTITLE1" "Test Data") + tabs))))) + ;; Test browser (define (tree-browser data adat window-id) ;; (iup:split (let* ((tb (iup:treebox #:selection-cb @@ -478,11 +461,11 @@ run-id '())) (target (if (null? targ/runname) "" (string-intersperse (reverse (cdr (reverse targ/runname))) "/"))) (runname (if (null? targ/runname) "" (car (cdr targ/runname)))) (steps-dat (tests:get-compressed-steps *dbstruct-local* run-id test-id))) - + (if test-data (begin ;; (for-each (lambda (data) @@ -525,15 +508,15 @@ (db:test-get-cpuload test-data) (seconds->hr-min-sec (db:test-get-run_duration test-data))) (make-list 5 ""))) )) (dcommon:populate-steps steps-dat steps-matrix)))))) - ;;(list meta-dat-matrix - ;; (if test-id - ;; (list ( +;;(list meta-dat-matrix +;; (if test-id +;; (list ( - + ;;====================================================================== ;; R U N C O N T R O L ;;====================================================================== ;; General displayer @@ -568,14 +551,14 @@ ;;====================================================================== ;; D A S H B O A R D ;;====================================================================== (define (make-area-panel data area-name window-id) - (let* ((adat (hash-table-ref areas area-name)) + (let* ((adat (hash-table-ref (dboard:data-areas data) area-name)) (tb (tree-browser data adat window-id)) ;; (dboard:areas-tree-browser data) (ad (area-display data adat window-id)) - (areas (dboard:data-areas data))) + (areas (dboard:data-areas data))) (dboard:area-tree-set! adat tb) (dboard:area-matrix-set! adat ad) (iup:split #:value 200 tb ad))) @@ -594,33 +577,39 @@ area-names)) (tabtop (apply iup:tabs areas))) (let loop ((index 0) (hed (car area-names)) (tal (cdr area-names))) - (let* ((apath (hash-table-ref (dboard:data-cfgdat data)) hed) + (let* ((apath (hash-table-ref (dboard:data-cfgdat data) hed)) (mtconf (read-config apath (make-hash-table) #f)) ;; megatest.config - (area-dat (make-megatest:area - hed ;; area name - apath ;; path to area - 'http ;; transport - (list apath mtconf) ;; configinfo (legacy) - mtconf ;; megatest.config - (make-hash-table) - #f - #f ;; remote connections - #f ;; run keys - (make-hash-table) ;; run-id -> (hash of test-ids => dat) - ))) + (area-dat (make-megatest:area + hed ;; area name + apath ;; path to area + 'http ;; transport + (list apath mtconf) ;; configinfo (legacy) + mtconf ;; megatest.config + (make-hash-table) ;; denoise hash + #f ;; client-signature + #f ;; remote connections + #f ;; run keys + (make-hash-table) ;; run-id -> (hash of test-ids => dat) + (and (file-exists? apath)(file-write-access? apath)) ;; read-only + ))) (hash-table-set! (dboard:data-areas data) hed - (make-dboard:area - #f ;; tree - #f ;; matrix - (and (file-exists? apath) - (file-write-access? apath)) - area-dat - hed - + (make-dboard:area + #f ;; tree + #f ;; matrix + area-dat ;; + #f ;; view path + 'default ;; view type + #f ;; matrix + #f ;; controls + #f ;; cached data + #f ;; filters + #f ;; the run-id + (make-hash-table) ;; run-id -> test-id, for current test id + "" )) (debug:print 0 "Adding area " hed " with index " index " to dashboard") (iup:attribute-set! tabtop (conc "TABTITLE" index) hed) (if (not (null? tal)) (loop (+ index 1)(car tal)(cdr tal))))