Megatest

(declare (uses tdb))
(declare (uses mt))
(declare (uses api))
(declare (uses tasks)) ;; only used for debugging.
(declare (uses env))
(declare (uses diff-report))
(declare (uses mutils))
(declare (uses adjutant))
(import adjutant)

(declare (uses mttop))
(import mttop)

;; (declare (uses ftail))
;; (import ftail)

(define *db* #f) ;; this is only for the repl, do not use in general!!!!

(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "megatest-fossil-hash.scm")

(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (prefix base64 base64:)
     readline apropos json http-client directory-utils typed-records matchable
     http-client srfi-18 extras format call-with-environment-variables)

;; Added for csv stuff - will be removed
;;
(use sparse-vectors)

(import mutils)

  version " megatest-version "
  license GPL, Copyright Matt Welland 2006-2017
 
Usage: megatest [options]
  -h                      : this help
  -manual                 : show the Megatest user manual
  -version                : print megatest version (currently " megatest-version ")
  help                    : help for the new Megatest interface

Launching and managing runs
  -run                    : run all tests or as specified by -testpatt
  -remove-runs            : remove the data for a run, requires -runname and -testpatt
                            Optionally use :state and :status, use -keep-records to remove only
                            the run data. Use -kill-wait to override the 10 second
                            per test wait after kill delay (e.g. -kill-wait 0). 

  -sync-to-megatest.db    : pull data from cache files in /tmp/$USER to megatest.db
  -sync-to dest           : sync to new postgresql central style database
  -update-meta            : update the tests metadata for all tests
  -setvars VAR1=val1,VAR2=val2 : Add environment variables to a run NB// these are
                                 overwritten by values set in config files.
  -server -|hostname      : start the server (reduces contention on megatest.db), use
                            - to automatically figure out hostname
  -adjutant host-type     : start the server/adjutant with given host-type
                            use 0,0 to auto use full machine
  -transport http|rpc     : use http or rpc for transport (default is http) 
  -log logfile            : send stdout and stderr to logfile
  -list-servers           : list the servers 
  -kill-servers           : kill all servers
  -repl                   : start a repl (useful for extending megatest)
  -load file.scm          : load and run file.scm

Called as " (string-intersperse (argv) " ") "
Version " megatest-version ", built from " megatest-fossil-hash ))

;;  -gui                    : start a gui interface
;;  -config fname           : override the runconfigs file with fname


(mttop-run (command-line-arguments)
	   '("help"))

;; process args
(define remargs (args:get-args 
		 (argv)
		 (list  "-runtests"  ;; run a specific test
			"-config"    ;; override the config file name
			"-append-config"
			"-execute"   ;; run the command encoded in the base64 parameter

;;
(if (args:get-arg "-server")
    (let ((tl        (launch:setup))
          (transport-type (string->symbol (or (args:get-arg "-transport") "http"))))
      (server:launch 0 transport-type)
      (set! *didsomething* #t)))


(define (naylist->alist inlst)
  (map (lambda (dat)
	 (cons (car dat)
	       (or (if (list?   (cdr dat))
		       (if (null? (cdr dat)) ""
			   (cadr dat))
		       (cdr dat))
		   ""))) ;; we need a string for call-with-environment-variables
       inlst))

;; The adjutant is a bit different, it does NOT run (launch:setup) as it is not necessarily tied to
;; a specific Megatest area. Detail are being hashed out and this may change.
;;
(if (args:get-arg "-adjutant")
    (let* ((host-type (args:get-arg "-adjutant")))
      (launch:setup) ;; dang it, wish this wasn't needed
      (print "Running the adjutant!")
      (let loop ((wait-count 0))
	(if (< wait-count 10) ;; 6 x 10 seconds = one minute
	    (let* ((dat (rmt:no-sync-take-job host-type)))
	      (match dat
		  ((id ht vars exekey cmdline state event-time last-update)
		      (let ((vars-alist (with-input-from-string vars read)
					))
			(print "Vars:")
			(pp vars-alist)
			(call-with-environment-variables
			 (naylist->alist vars-alist)
			 (lambda ()
			   (system cmdline))))
		      (loop 0))
		  (else
		   (thread-sleep! 10)
		   (loop (+ wait-count 1)))))
	    (print "I'm bored. Exiting.")))
      ;; (adjutant-run (args:get-arg "-ajutant") rmt:no-sync-take-job)
      (set! *didsomething* #t)))

(if (or (args:get-arg "-list-servers")
        (args:get-arg "-kill-servers"))
    (let ((tl (launch:setup)))
      (if tl ;; all roads from here exit
	  (let* ((servers (server:get-list *toppath*))