Megatest

    ok))

;; Do all the connection work, look up the transport type and set up the
;; connection if required.
;;
;; There are two scenarios. 
;;   1. We are a test manager and we received *transport-type* and *runremote* via cmdline
;;   2. We are a run tests, list runs or other interactive process and we must figure out
;;      *transport-type* and *runremote* from the monitor.db
;;
;; client:setup
(define (client:setup #!key (numtries 3))
  (if (not *toppath*)
      (if (not (setup-for-run))
	  (begin
	    (debug:print 0 "ERROR: failed to find megatest.config, exiting")
	    (exit))))
  (push-directory *toppath*) ;; This is probably NOT needed 
  (debug:print-info 11 "*transport-type* is " *transport-type* ", *runremote* is " *runremote*)

  (let* ((hostinfo  (open-run-close tasks:get-best-server tasks:open-db)))



    (debug:print-info 11 "CLIENT SETUP, hostinfo=" hostinfo)
    (set! *transport-type* (if hostinfo 
    			       (string->symbol (tasks:hostinfo-get-transport hostinfo))
			       'fs))



    (debug:print-info 11 "Using transport type of " *transport-type* (if hostinfo (conc " to connect to " hostinfo) ""))
    (case *transport-type* 
      ((fs)(if (not *megatest-db*)(set! *megatest-db* (open-db))))











      ((http)
       (http-transport:client-connect (tasks:hostinfo-get-interface hostinfo)
				      (tasks:hostinfo-get-port hostinfo)))
      ((zmq)
       (zmq-transport:client-connect (tasks:hostinfo-get-interface hostinfo)
				     (tasks:hostinfo-get-port      hostinfo)
				     (tasks:hostinfo-get-pubport   hostinfo)))

		       (if *db* (sqlite3:finalize! *db*))))
	    (cdb:remote-run examine-run *db* runid)))
	(begin
	  (print "ERROR: runid is not a number " (args:get-arg "-run"))
	  (exit 1)))))
 ((args:get-arg "-test")
  (let ((testid (string->number (args:get-arg "-test"))))
    (if (and (number? testid)
	     (>= testid 0))
	(examine-test testid)
	(begin

	  (debug:print 3 "INFO: tried to open test with invalid test-id. " (args:get-arg "-test"))
	  (exit 1)))))
 ((args:get-arg "-guimonitor")
  (gui-monitor *db*))
 (else
  (set! uidat (make-dashboard-buttons *num-runs* *num-tests* *dbkeys*))
  (iup:callback-set! *tim*
		     "ACTION_CB"

                                              runscript))))) ;; assume it is on the path
	       (rollup-status 0))
	  (change-directory top-path)
	  (debug:print 2 "Exectuing " test-name " (id: " test-id ") on " (get-host-name))
	  ;; Setup the *runremote* global var
	  (if *runremote* (debug:print 2 "ERROR: I'm not expecting *runremote* to be set at this time"))
	  ;; (set! *runremote* runremote)
	  ;; (set! *transport-type* (string->symbol transport))
	  (set! keys       (cdb:remote-run db:get-keys #f))
	  (set! keyvals    (keys:target->keyval keys target))
	  ;; apply pre-overrides before other variables. The pre-override vars must not
	  ;; clobbers things from the official sources such as megatest.config and runconfigs.config
	  (if (string? set-vars)
	      (let ((varpairs (string-split set-vars ",")))
		(debug:print 4 "varpairs: " varpairs)

    (begin
      (print megatest-version)
      (exit)))

(define *didsomething* #f)

;; Force default transport to fs
;; (if ;; (and (or (args:get-arg "-list-targets")
;;     ;;          (args:get-arg "-list-db-targets"))
;;  (not (args:get-arg "-transport"))
;;  (hash-table-set! args:arg-hash "-transport" "fs"))

;;======================================================================
;; Misc setup stuff
;;======================================================================

(debug:setup)

	  (transport (or (configf:lookup *configdat* "setup" "transport")
			 (args:get-arg "-transport" "http"))))
      (debug:print 2 "Launching server using transport " transport)
      (server:launch (string->symbol transport)))

    ;; Not a server? This section will decide how to communicate
    ;;
    ;;  Setup client for all expect listed here
    (if (null? (lset-intersection 
		     equal?
		     (hash-table-keys args:arg-hash)


		     '("-list-servers"
		       "-stop-server"
		       "-show-cmdinfo")))
	(if (setup-for-run)
	    (begin

	      ;; if not list or kill then start a client (if appropriate)
	      (if (or (args-defined? "-h" "-version" "-gen-megatest-area" "-gen-megatest-test")
		      (eq? (length (hash-table-keys args:arg-hash)) 0))
		  (debug:print-info 1 "Server connection not needed")
		  ;; ok, so lets connect to the server
		  (let* ((transport-from-config   (configf:lookup *configdat* "setup" "transport"))
			 (transport-from-cmdln    (args:get-arg "-transport"))
			 (transport-from-cmdinfo  (if (getenv "MT_CMDINFO")
						      (let ((res (assoc 'transport 
									(read
									 (open-input-string 
									  (base64:base64-decode
									   (getenv "MT_CMDINFO")))))))
							(if res (cadr res) #f))
						      #f))
			 (chosen-transport        (string->symbol (or transport-from-cmdln
								      transport-from-cmdinfo
								      transport-from-config
								      "fs"))))
		    (debug:print 0 "chosen-transport: " chosen-transport " have; config=" transport-from-config ", cmdln=" transport-from-cmdln ", cmdinfo=" transport-from-cmdinfo)
		    (case chosen-transport
		      ((http)
		       (set! *transport-type 'http)
		       (server:ensure-running)
		       (client:launch))
		      (else ;; (fs)
		       (set! *transport-type* 'fs)
		       (set! *megatest-db* (open-db))))))))))
;; 		    (cond
;; 		     ;; command line overrides other mechanisms
;; 		     (transport-from-cmdln
;; 		      (if (equal? transport-from-cmdln "fs")
;; 			  (set! *transport-type* 'fs)
;; 			  (begin
;; 			    (server:ensure-running)
;; 			    (client:launch))))
;; 		     ;; cmdinfo is second priority
;; 		     (transport-from-cmdinfo
;; 		      (if (equal? transport-from-cmdinfo "fs")
;; 			  (set! *transport-type* 'fs)
;; 			  (begin
;; 			    (server:ensure-running)
;; 			    (client:launch))))
;; 		     ;; config file is next highest priority for determinining transport
;; 		     (transport-from-config
;; 		      (if (equal? transport-from-config "fs")
;; 			  (set! *transport-type* 'fs)
;; 			  (begin
;; 			    (server:ensure-running)
;; 			    (client:launch))))
;; 		     (else
;; 		      (set! *transport-type* 'fs)))))))))

(if (or (args:get-arg "-list-servers")
	(args:get-arg "-stop-server"))
    (let ((tl (setup-for-run)))
      (if tl 
	  (let* ((servers (open-run-close tasks:get-all-servers tasks:open-db))
		 (fmtstr  "~5a~12a~8a~20a~24a~10a~10a~10a~10a\n")

	       (db        #f)
	       (state     (args:get-arg ":state"))
	       (status    (args:get-arg ":status"))
	       (target    (args:get-arg "-target"))
	       (toppath   (assoc/default 'toppath   cmdinfo)))
	  (change-directory toppath)
	  ;; (set! *runremote* runremote)
	  ;; (set! *transport-type* (string->symbol transport))
	  (if (not target)
	      (begin
		(debug:print 0 "ERROR: -target is required.")
		(exit 1)))
	  (if (not (setup-for-run))
	      (begin
		(debug:print 0 "Failed to setup, giving up on -test-paths or -test-files, exiting")

	       (itemdat   (assoc/default 'itemdat   cmdinfo))
	       (db        #f)
	       (state     (args:get-arg ":state"))
	       (status    (args:get-arg ":status"))
	       (target    (args:get-arg "-target")))
	  (change-directory testpath)
	  ;; (set! *runremote* runremote)
	  ;; (set! *transport-type* (string->symbol transport))
	  (if (not target)
	      (begin
		(debug:print 0 "ERROR: -target is required.")
		(exit 1)))
	  (if (not (setup-for-run))
	      (begin
		(debug:print 0 "Failed to setup, giving up on -archive, exiting")

	     (run-id    (assoc/default 'run-id    cmdinfo))
	     (test-id   (assoc/default 'test-id   cmdinfo))
	     (itemdat   (assoc/default 'itemdat   cmdinfo))
	     (work-area (assoc/default 'work-area cmdinfo))
	     (db        #f))
	(change-directory testpath)
	;; (set! *runremote* runremote)
	;; The transport is handled earlier in the loading process of megatest.
	;; (set! *transport-type* (string->symbol transport))
	(if (not (setup-for-run))
	    (begin
	      (debug:print 0 "Failed to setup, exiting")
	      (exit 1)))
	(if (and state status)
	    ;; DO NOT remote run, makes calls to the testdat.db test db.
	    (db:teststep-set-status! db test-id step state status msg logfile work-area: work-area)

	       (test-id   (assoc/default 'test-id   cmdinfo))
	       (itemdat   (assoc/default 'itemdat   cmdinfo))
	       (work-area (assoc/default 'work-area cmdinfo))
	       (db        #f) ;; (open-db))
	       (state     (args:get-arg ":state"))
	       (status    (args:get-arg ":status")))
	  ;; (set! *runremote* runremote)
	  ;; (set! *transport-type* (string->symbol transport))
	  (if (not (setup-for-run))
	      (begin
		(debug:print 0 "Failed to setup, exiting")
		(exit 1)))

	  (if (args:get-arg "-runstep")(debug:print-info 1 "Running -runstep, first change to directory " work-area))
	  (change-directory work-area)

	(begin
	  (if (even? trycount) ;; just do the server start every other time through this loop (every 8 seconds)
	      (begin
		(debug:print 0 "INFO: Starting server as none running ...")
		;; (server:launch (string->symbol (args:get-arg "-transport" "http"))))
		;; no need to use fork, no need to do the list-servers trick. Just start the damn server, it will exit on it's own
		;; if there is an existing server
		(system (conc (if (getenv "MT_MEGATEST") (getenv "MT_MEGATEST") "megatest")
			      " -server - -daemonize"))
		(thread-sleep! 3)
		;; (process-run (car (argv)) (list "-server" "-" "-daemonize" "-transport" (args:get-arg "-transport" "http")))
		;; (system (conc "megatest -list-servers | egrep '" megatest-version ".*alive' || megatest -server - -daemonize && sleep 3"))
		;; (process-fork (lambda ()
		;;       	  (daemon:ize)
		;;       	  (server:launch (string->symbol (args:get-arg "-transport" "http")))))
		)

(define (tasks:have-clients? mdb server-id)
  (null? (tasks:get-logged-in-clients mdb server-id)))

;; ping each server in the db and return first found that responds. 
;; remove any others. will not necessarily remove all!
(define (tasks:get-best-server mdb)
  (let ((res '())
	(best #f)
	(transport (if (and *transport-type*
			    (not (eq? *transport-type* 'fs)))
		       (conc *transport-type*)
		       "%")))
    (sqlite3:for-each-row
     (lambda (id interface port pubport transport pid hostname)
       (set! res (cons (vector id interface port pubport transport pid hostname) res))
       ;;(debug:print-info 2 "Found existing server " hostname ":" port " registered in db"))
       )
     mdb
     
     "SELECT id,interface,port,pubport,transport,pid,hostname FROM servers
          WHERE strftime('%s','now')-heartbeat < 10 
          AND mt_version=? AND transport LIKE ? 
          ORDER BY start_time DESC LIMIT 1;" (common:version-signature) transport)
    ;; for now we are keeping only one server registered in the db, return #f or first server found
    (if (null? res) #f (car res))))

;; BUG: This logic is probably needed unless methodology changes completely...
;;
;;     (if (null? res) #f
;; 	(let loop ((hed (car res))

	touch cleanprep

fullprep : cleanprep
	cd fullrun;$(MEGATEST) -remove-runs :runname $(RUNNAME)% -target %/%/% -testpatt %/%
	cd fullrun;$(BINPATH)/dashboard -rows 15 &

dashboard : cleanprep
	cd fullrun && $(BINPATH)/dashboard -transport fs -rows 20 &

dashboard-http : cleanprep
	cd fullrun && $(BINPATH)/dashboard -transport http -rows 20 &

remove :
	cd fullrun;$(MEGATEST) -remove-runs :runname $(RUN)  -testpatt % -itempatt % :sysname % :fsname % :datapath %

clean  : 
	rm cleanprep