Megatest

newdashboard.scm at [5820f690ed]
Login

File newdashboard.scm artifact b85c6e1ccc part of check-in 5820f690ed


;;======================================================================
;; 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)