;;======================================================================
;; Copyright 2006-2016, Matthew Welland.
;;
;; This file is part of Megatest.
;;
;; Megatest is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; Megatest is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;======================================================================
;; (declare (uses common))
;; (declare (uses megatest-version))
(declare (uses mtargs))
(declare (uses treemod))
(use srfi-1
posix regex regex-case srfi-69 typed-records sparse-vectors
format
extras
(prefix iup iup:)
canvas-draw
sqlite3)
(import canvas-draw-iup)
(module ndboard
*
(import scheme
chicken
data-structures
extras
format
(prefix iup iup:)
canvas-draw
canvas-draw-iup
matchable
srfi-1 posix regex regex-case
srfi-69 typed-records sparse-vectors ;; defstruct
sqlite3
treemod
(prefix mtargs args:)
)
(include "megatest-version.scm")
;; (declare (uses launch))
;; (declare (uses gutils))
;; (declare (uses db))
;; (declare (uses server))
;; (declare (uses synchash))
;; (declare (uses dcommon))
;;
;; (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
version " megatest-version "
license GPL, Copyright (C) Matt Welland 2011
Usage: dashboard [options]
-h : this help
-server host:port : connect to host:port instead of db access
-test testid : control test identified by testid
-guimonitor : control panel for runs
Misc
-rows N : set number of rows
"))
;; process args
(define remargs (args:get-args
(argv)
(list "-rows"
"-run"
"-test"
"-debug"
"-host"
)
(list "-h"
"-guimonitor"
"-main"
"-v"
"-q"
)
args:arg-hash
0))
(if (args:get-arg "-h")
(begin
(print help)
(exit)))
;; ease debugging by loading ~/.dashboardrc
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.newdashboardrc")))
(if (file-exists? debugcontrolf)
(load debugcontrolf)))
(define *tim* (iup:timer))
(define *ord* #f)
(iup:attribute-set! *tim* "TIME" 300)
(iup:attribute-set! *tim* "RUN" "YES")
;; areas
;;
(define *areas* (make-hash-table))
(defstruct area
path
keys
targets
targets-update-time
(dbhs (make-hash-table))
)
(define (area-get-path area-name)
(let* ((adat (get-area-info area-name)))
(if adat
(area-path adat)
#f)))
(define (get-areas-file)
(conc (get-environment-variable "HOME")"/.ndboard/areas.scm"))
(define (get-areas)
(let* ((areas-file (get-areas-file)))
(if (file-exists? areas-file)
(with-input-from-file areas-file read))))
(define (register-area areadat)
(hash-table-set! *areas* (car areadat)
(make-area path: (cdr areadat))))
(define (get-area-info area-name)
(hash-table-ref/default *areas* area-name #f))
(define (area-save-dbh area-name dbname mtdbh)
(hash-table-set! (area-dbhs (get-area-info area-name)) dbname mtdbh))
(define (area-get-dbh area-name dbname)
(hash-table-ref/default (area-dbhs (get-area-info area-name)) dbname #f))
;; megatest calls, run in "area"
;;
;; TODO store the last time the query was run
;; and clear cache based on timestamp on main.db
;;
(define (megatest-get-targets area-name)
(let* ((ainfo (get-area-info area-name))
(targets (area-targets ainfo)))
(if targets
targets
(let* ((path (area-get-path area-name))
(raw-targs (with-input-from-pipe
(conc "megatest -list-targets -start-dir "path)
read-lines))
(clean-targs (filter (lambda (x)
(not (equal? x "default")))
raw-targs)))
(area-targets-set! ainfo clean-targs)
(area-targets-update-time-set! ainfo (current-seconds))
clean-targs))))
(define (megatest-get-keys area-name)
(let* ((ainfo (get-area-info area-name))
(keys (area-keys ainfo)))
(if keys
keys
(let* ((path (area-path ainfo))
(keysstr (with-input-from-pipe
(conc "megatest -show-keys -start-dir "path)
read-line)))
(if (not (string? keysstr))
(print "Unknown error getting keys for area "area-name", path: "path)
(let* ((keys (string-split keysstr)))
(area-keys-set! ainfo keys)
keys))))))
;; megatest area database access functions
;;
(defstruct mtdb
name
db
path)
;; fall back to old megatest db if .megatest/dbname not found
;;
(define (megatest-find-db path dbname)
(let ((newpath (conc path"/.megatest/"dbname))
(oldpath (conc path"/megatest.db")))
(if (file-exists? newpath)
newpath
(if (file-exists? oldpath)
oldpath
#f))))
;; dbname is main.db, 1.db ...
(define (megatest-open-db area-name dbname)
(let* ((mtdbh (area-get-dbh area-name dbname)))
(if mtdbh
mtdbh
(let* ((ainfo (get-area-info area-name))
(path (area-path ainfo))
(dbpath (megatest-find-db path dbname))
(dbexists (and dbpath
(file-exists? dbpath)
(file-read-access? dbpath))))
(if dbexists
(let* ((db (open-database dbpath)))
(set-busy-handler! db (make-busy-timeout 136000))
(execute db "PRAGMA synchronous = 0;")
(let* ((mtdbh (make-mtdb db: db path: dbpath)))
(area-save-dbh area-name dbname mtdbh)
mtdbh))
#f)))))
;; ADD on-exit to close the opened dbs
;; keys is list, targpatts is list, both same length
;; and *fully* specified
;; returns targvals and runname
(define (megatest-get-run-names area-name keys targpatts)
(let* ((mtdbh (megatest-open-db area-name "main.db"))
(selector (string-intersperse
(map (lambda (k v)(conc k" like '"v"'")) keys targpatts)
" AND "))
(field-sel (string-intersperse keys ","))
(fullqry (conc "SELECT "field-sel",runname FROM runs WHERE "selector";")))
(print "fullqry="fullqry)
(fold-row ;; proc init db-or-stmt . params)
(lambda (res . row)
(cons row res))
'()
(mtdb-db mtdbh) ;; get the db handle
fullqry)))
;; gui utils
;;
(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))
;; simple widget registration and finding
(define *widgets* (make-hash-table))
(define (add-widget name wgt)
(hash-table-set! *widgets* name wgt)
wgt)
(define (get-widget name)
(hash-table-ref/default *widgets* name #f))
(define (pad-list l n)(append l (make-list (- n (length l)))))
;; the main tree, everything starts from here
;;
(define (main-tree)
(iup:treebox
#:value 0
#:title "Areas"
#:expand "YES"
#:addexpanded "YES"
#:size "10x"
#:selection-cb
(lambda (obj id state)
(let* ((path (tree:node->path obj id)))
(match path
((treename) #f) ;;(print "nothing to do here"))
((treename area)
(let ((tb (get-widget "main-tree"))) ;; wait, isn't this just "obj"?
(refresh-targets tb area)))
((treename area . target)
(let* ((keys (megatest-get-keys area)))
(if (eq? (length keys)(length target))
(let* ((runnames (megatest-get-run-names area keys target)))
(for-each
(lambda (runnamedat)
(tree:add-node obj "Areas" (cons area runnamedat)))
runnames)))))
(else
(print "path: "path))
)
#;(print "obj: "obj", id: "id", state: "state", path: "path)))))
(define (refresh-targets tb area)
(let* ((targets (megatest-get-targets area)))
(for-each
(lambda (target)
(let* ((t-path (string-split target "/")))
(tree:add-node tb "Areas" (cons area t-path))))
targets)))
(define (runs window-id)
(iup:hbox
(add-widget "main-tree" (main-tree))
))
(define (runs-init)
(let* ((areas (get-areas))
(tb (get-widget "main-tree")))
(for-each
(lambda (areadat)
(tree:add-node tb "Areas" `(,(car areadat)))
(register-area areadat))
areas)))
;; Browse and control a single run
;;
(define (runcontrol window-id)
(iup:hbox))
;; Main Panel
(define (main-panel window-id)
(iup:dialog
#:title "Megatest Control Panel"
;; #:menu (dcommon:main-menu)
#:shrink "YES"
(let ((tabtop (iup:tabs
(add-widget "runs" (runs window-id))
;; (tests window-id)
(runcontrol window-id)
;; (mtest *toppath* window-id)
;; (rconfig window-id)
)))
(iup:attribute-set! tabtop "TABTITLE0" "Runs")
;; (iup:attribute-set! tabtop "TABTITLE1" "Tests")
(iup:attribute-set! tabtop "TABTITLE1" "Run Control")
;; (iup:attribute-set! tabtop "TABTITLE3" "megatest.config")
;; (iup:attribute-set! tabtop "TABTITLE4" "runconfigs.config")
tabtop)))
(define *current-window-id* 0)
(define (newdashboard dbstruct)
(let* ((data (make-hash-table))
(keys '()) ;; (db:get-keys dbstruct))
(runname "%")
(testpatt "%")
(keypatts '()) ;; (map (lambda (k)(list k "%")) keys))
(states '())
(statuses '())
(nextmintime (current-milliseconds))
(my-window-id *current-window-id*))
(set! *current-window-id* (+ 1 *current-window-id*))
;; (dboard:data-runs-set! *data* data) ;; make this data available to the rest of the application
(iup:show (main-panel my-window-id))
(runs-init)
;; Yes, running iup:show will pop up a new panel
;; (iup:show (main-panel my-window-id))
(iup:callback-set! *tim*
"ACTION_CB"
(lambda (x)
;; Want to dedicate no more than 50% of the time to this so skip if
;; 2x delta time has not passed since last query
#t
#;(if (< nextmintime (current-milliseconds))
(let* ((starttime (current-milliseconds))
;; (changes (dcommon:run-update keys data runname keypatts testpatt states statuses 'full my-window-id))
(endtime (current-milliseconds)))
(set! nextmintime (+ endtime (* 2 (- endtime starttime))))
;; (debug:print 11 *default-log-port* "CHANGE(S): " (car changes) "..."))
)
(print "Server overloaded"))))))
)
;;======================================================================
;; D A S H B O A R D
;;======================================================================
(import ndboard)
(newdashboard #f)
(iup:main-loop)