Megatest

;;======================================================================
;; Copyright 2006-2013, Matthew Welland.
;; 
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;; 
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.
;;======================================================================

(use format numbers sql-de-lite srfi-1 posix regex regex-case srfi-69 nanomsg srfi-18 call-with-environment-variables)
(require-library iup)
(import (prefix iup iup:))
(use canvas-draw)

(declare (uses margs))
(declare (uses megatest-version))
(declare (uses gutils))
(declare (uses tree))
(declare (uses configf))
(declare (uses portlogger))
(declare (uses keys))

(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

;; (if (args:get-arg "-host")
;;     (begin
;;       (set! (common:get-remote remote) (string-split (args:get-arg "-host" ":")))
;;       (client:launch))
;;     (client:launch))

(define *runremote* #f)
(define *windows* (make-hash-table))

(debug:setup)

(define *tim* (iup:timer))
(define *ord* #f)

(iup:attribute-set! *tim* "TIME" 300)

	    ((0) (areadat-maindb-set!    areadat db))
	    (else (rundat-db-set!        rundat  db)))
	  db))))

;; populate the areadat tests info, does NOT fill the tests data itself
;;
(define (areadb:populate-run-info areadat)
  (let* ((runs   (or (areadat-runs areadat) (make-hash-table)))
	 (keys   (areadat-run-keys areadat))
	 (maindb (areadb:open areadat 0)))
    (query (for-each-row (lambda (row)
			   (let ((id  (list-ref row 0))
				 (dat (apply make-rundat (append row (list #f #f))))) ;; add placeholders for tests and db
			     (print row)
			     (hash-table-set! runs id dat))))
	   (sql maindb (conc "SELECT id,"
			     (string-intersperse keys "||'/'||")
			     ",runname,state,status,event_time FROM runs WHERE state != 'DELETED';")))
    areadat))
	
;; initialize and refresh data
;;		
(define (dboard:general-updater con port)
  (for-each
   (lambda (window-id)
     (print "Processing for window-id " window-id)
     (let* ((window-dat (hash-table-ref *windows* window-id))
	    (areas      (data-areas     window-dat)))
       ;; now for each area in the window gather the data
       (for-each
	(lambda (area-name)
	  (print "Processing for area-name " area-name)
	  (let ((area-dat (hash-table-ref areas area-name)))
	    (print "Processing " area-dat " for area-name " area-name)
	    (areadb:populate-run-info area-dat)))
	(hash-table-keys areas))))
   (hash-table-keys *windows*)))

;;======================================================================
;; D A S H B O A R D   D B 
;;======================================================================
		
(define (mddb:open-db)
  (let* ((db (open-database (conc (get-environment-variable "HOME") "/.dashboard.db"))))
    (set-busy-handler! db (busy-timeout 10000))

       view-matrix)))))

;;======================================================================
;; A R E A S
;;======================================================================

(define (dashboard:init-area data area-name apath)
  (let* ((mtconf      (dboard:read-mtconf apath))

	 (area-dat    (let ((ad (make-areadat
				 area-name ;; area name
				 apath     ;; path to area
				 ;; 'http     ;; transport
				 mtconf    ;; megatest.config
				 (make-hash-table) ;; denoise hash
				 #f        ;; client-signature
				 #f        ;; remote connections
				 (keys:config-get-fields mtconf) ;; run keys
				 (make-hash-table) ;; run-id -> (hash of test-ids => dat)
				 (and (file-exists? apath)(file-write-access? apath)) ;; read-only
				 #f
				 #f
				 )))
			(hash-table-set! (data-areas data) area-name ad)
			ad)))

		      #f           ;; controls
		      #f           ;; cached data
		      #f           ;; filters
		      #f           ;; the run-id
		      (make-hash-table) ;; run-id -> test-id, for current test id
		      ""
		      )))
    (hash-table-set! (data-areas data) aname area-dat) ;; dboard-dat)
    (hash-table-set! (data-tab-ids data) window-id dboard-dat)
    (tab-tree-set!   dboard-dat tb)
    (tab-matrix-set! dboard-dat ad)
    (iup:split
     #:value 200
     tb ad)))

		 (print  "path " curr-mtpath))))
	   #t)
	 (begin
	   (debug:print-info 0 "Need to create a config but no megatest.config found: " curr-mtcfgdat)
	   #f))))
;; )

(define (dboard:read-mtconf apath)
  (let* ((mtconffile  (conc apath "/megatest.config")))
    (call-with-environment-variables
     (list (cons "MT_RUN_AREA_HOME" apath))
     (lambda ()
       (read-config mtconffile (make-hash-table) #f)) ;; megatest.config
     )))
	 

;;======================================================================
;; G U I   S T U F F 
;;======================================================================

;;; main. Theoretically could have multiple windows (each with a group of tags, thus window-id
;;;
(define (dboard:make-window window-id)
  (let* (;; (window-id 0)
	 (groupn    (or (args:get-arg "-group") "default"))
	 (cfgdat    (dboard:get-config groupn))
	 ;; (cfgdat    (if (file-exists? cfname)(read-config cfname (make-hash-table) #t)(make-hash-table)))
	 (data      (make-data
		     cfgdat ;; this is the data from ~/.megatest for the selected group
		     (make-hash-table) ;; areaname -> area-rec
		     0                 ;; current window id
		     0                 ;; current tab id
		     #f                ;; redraw needed for current tab id
		     (make-hash-table) ;; tab-id -> areaname
		     )))
    (hash-table-set! *windows* window-id data)
    (iup:show (dashboard:main-panel data window-id))
    (iup:main-loop)))



;; ease debugging by loading ~/.dashboardrc
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc")))
  (if (file-exists? debugcontrolf)
      (load debugcontrolf)))

(let-values 
 (((con port)(dboard:server-start #f)))
 (let ((portnum   (if (string? port)(string->number port) port)))
   ;; got here, monitor/dashboard was started
   (mddb:register-dashboard portnum)
   (thread-start! (make-thread (lambda ()(dboard:server-service con portnum)) "server service"))
   (thread-start! (make-thread (lambda ()
				 (let loop ()
				   (dboard:general-updater con portnum)
				   (thread-sleep! 1)
				   (loop))) "general updater"))
   (dboard:make-window 0)
   (mddb:unregister-dashboard (get-host-name) portnum)
   (dboard:server-close con port)))