Megatest

;; (include "common.scm")
;; (include "megatest-version.scm")

;; fake out readline usage of toplevel-command
(define (toplevel-command . a) #f)













(declare (uses common))
(declare (uses megatest-version))
(declare (uses margs))
(declare (uses runs))
(declare (uses launch))
(declare (uses server))
(declare (uses client))
(declare (uses tests))
(declare (uses genexample))
;; (declare (uses daemon))
(declare (uses db))
;; (declare (uses dcommon))
(declare (uses stml2))
(declare (uses pkts))
(declare (uses mutils))

(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 commonmod))
(declare (uses adjutant))
;; (declare (uses ftail))
;; (import ftail)

(import stml2 mutils commonmod adjutant)

;; invoke the imports
;; (declare (uses mtargs.import))
;; (declare (uses mtconfigf.import))
(declare (uses cookie.import))
(declare (uses stml2.import))
(declare (uses pkts.import))
(declare (uses commonmod.import))
(declare (uses adjutant.import))

(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
     http-client srfi-18 extras format)

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

(import mutils ducttape-lib stml2)

;; (use zmq)

(define *usage-log-file* #f)    ;; put path to file for logging usage in this var in the ~/.megatestrc file
(define *usage-use-seconds* #t) ;; for Epoc seconds in usage logging change this to #t in ~/.megatestrc file

;; load the ~/.megatestrc file, put (use trace)(trace-call-sites #t)(trace function-you-want-to-trace) in this file
;;
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.megatestrc")))

  -version                : print megatest version (currently " megatest-version ")

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). 
  -kill-runs              : kill existing run(s) (all incomplete tests killed)
  -kill-rerun             : kill an existing run (all incomplete tests killed and run is rerun)
  -set-state-status X,Y   : set state to X and status to Y, requires controls per -remove-runs
  -rerun FAIL,WARN...     : force re-run for tests with specificed status(s)
  -rerun-clean            : set all tests not COMPLETED+PASS,WARN,WAIVED to NOT_STARTED,n/a
                            and then run the specified testpatt with -preclean
  -rerun-all              : set all tests to NOT_STARTED,n/a and run with -preclean

  -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 C,M           : start the server/adjutant with allocated cores C and Mem M (Gig), 
                            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
  -mark-incompletes       : find and mark incomplete tests

  -refdb2dat refdb        : convert refdb to sexp or to format specified by s-dumpmode
                            formats: perl, ruby, sqlite3, csv (for csv the -o param
                            will substitute %s for the sheet name in generating 
                            multiple sheets)
  -o                      : output file for refdb2dat (defaults to stdout)
  -archive cmd            : archive runs specified by selectors to one of disks specified
                            in the [archive-disks] section.
                            cmd: keep-html, restore, save, save-remove, get (use 
                            -dest to set destination), -include path1,path2... to get or save specific files
  -generate-html          : create a simple html dashboard for browsing your runs
  -generate-html-structure  : create a top level html veiw to list targets/runs and a Run view within each run directory.  
  -list-run-time          : list time requered to complete runs. It supports following switches
                            -run-patt <patt> -target-patt <patt> -dumpmode <csv,json,plain-text>
  -list-test-time	  : list time requered to complete each test in a run. It following following arguments
                            -runname <patt> -target <patt> -dumpmode <csv,json,plain-text>
  -syscheck               : do some very basic checks; write access and space in tmp, home, runs, links and 
                            is $DISPLAY valid 


Diff report
  -diff-rep               : generate diff report (must include -src-target, -src-runname, -target, -runname
                                                  and either -diff-email or -diff-html)
  -src-target <target>
  -src-runname <target>
  -diff-email <emails>    : comma separated list of email addresses to send diff report
  -diff-html  <rep.html>  : path to html file to generate

Spreadsheet generation
  -extract-ods fname.ods  : extract an open document spreadsheet from the database
  -pathmod path           : insert path, i.e. path/runame/itempath/logfile.html
                            will clear the field if no rundir/testname/itempath/logfile
                            if it contains forward slashes the path will be converted
                            to windows style
Getting started
  -create-megatest-area   : create a skeleton megatest area. You will be prompted for paths
  -create-test testname   : create a skeleton megatest test. You will be prompted for info

Examples

# Get test path, use '.' to get a single path or a specific path/file pattern
megatest -test-files 'logs/*.log' -target ubuntu/n%/no% -runname w49% -testpatt test_mt%

Called as " (string-intersperse (argv) " ") "

			"-logpro"
			"-m"
			"-rerun"

			"-days"
			"-rename-run"
			"-to"
			"-dest"
			;; values and messages
			":category"
			":variable"
			":value"
			":expected"
			":tol"
			":units"
			;; misc
			"-start-dir"
                        "-run-patt"
                        "-target-patt"   
			"-contour"
                        "-area-tag"  
                        "-area"  
			"-run-tag"
			"-server"
			"-adjutant"
			"-transport"
			"-port"
			"-extract-ods"
			"-pathmod"
			"-env2file"
			"-envcap"
			"-envdelta"
			"-setvars"
			"-set-state-status"

                        ;; move runs stuff here
                        "-remove-keep"           
			"-set-run-status"
			"-age"

			;; archive 
			"-archive"
			"-actions"
			"-precmd"
			"-include"
			"-exclude-rx"
			"-exclude-rx-from"
			
			"-debug" ;; for *verbosity* > 2
			"-create-test"
			"-override-timeout"
			"-test-files"  ;; -test-paths is for listing all
			"-load"        ;; load and exectute a scheme file
			"-section"

			"-sync-to-megatest.db"
                        "-sync-brute-force"
			"-logging"
			"-v" ;; verbose 2, more than normal (normal is 1)
			"-q" ;; quiet 0, errors/warnings only

                        "-diff-rep"

			"-syscheck"
                        )
		 args:arg-hash
		 0))

;; Add args that use remargs here
;;
(if (and (not (null? remargs))

;;(if (not (args:get-arg "-server"))
;;    (thread-start! *watchdog*)) ;; if starting a server; wait till we get to running state before kicking off watchdog
(let* ((no-watchdog-args
       '("-list-runs"
         "-testdata-csv"
         "-list-servers"
         "-server"
	 "-adjutant"
         "-list-disks"
         "-list-targets"
         "-show-runconfig"
         ;;"-list-db-targets"
         "-show-runconfig"
         "-show-config"
         "-show-cmdinfo"
	 "-cleanup-db"))
       (no-watchdog-args-vals (filter (lambda (x) x)
                                      (map args:get-arg no-watchdog-args)))
       (start-watchdog (null? no-watchdog-args-vals)))
  ;;(BB> "no-watchdog-args="no-watchdog-args "no-watchdog-args-vals="no-watchdog-args-vals) 
  (if start-watchdog
      (thread-start! *watchdog*)))


;; bracket open-output-file with code to make leading directory if it does not exist and handle exceptions
(define (open-logfile logpath-in)
  (condition-case
   (let* ((log-dir (or (pathname-directory logpath-in) "."))
	  (fname   (pathname-strip-directory logpath-in))
	  (logpath (if (> (string-length fname) 250)
		       (let ((newlogf (conc log-dir "/" (common:get-signature fname) ".log")))
			 (debug:print 0 *default-log-port* "WARNING: log file " logpath-in " path too long, converted to " newlogf)
			 newlogf)
		       logpath-in)))
     (if (not (directory-exists? log-dir))
         (system (conc "mkdir -p " log-dir)))
     (open-output-file logpath))
   (exn ()
        (debug:print-error 0 *default-log-port* "Could not open log file for write: "logpath)
        (define *didsomething* #t)  
        (exit 1))))

;; Server? Start up here.
;;
(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)))

;; 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")
    (begin
      (adjutant-run)
      (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*))
		 (fmtstr  "~8a~22a~20a~20a~8a\n"))

;;======================================================================
;; Remove old run(s)
;;======================================================================

;; since several actions can be specified on the command line the removal
;; is done first
(define (operate-on action #!key (mode #f)(target-in #f)(runname-in #f)(keys-in #f)(keyvals-in #f)) ;; #f is "use default"
  (let* ((runrec (runs:runrec-make-record))
	 (target (or target-in   (common:args-get-target))) ;; eventually get rid of the call to common:args-get-target
	 (runname (or runname-in
		      (args:get-arg "-runname"))) ;; eventually get rid of the get-arg calls
	 (testpatt (or (args:get-arg "-testpatt")
		       (and (eq? action 'archive) ;; if it is an archive command fallback to MT_TEST_NAME and MT_ITEMPATH
			    (common:get-full-test-name))
		       (and (eq? action 'kill-runs)
			    "%/%") ;; I'm just guessing that this is correct :(
		       (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")))
		       ))) ;;
    (cond
     ((not target)
      (debug:print-error 0 *default-log-port* "Missing required parameter for "
			 action ", you must specify -target or -reqtarg")
      (exit 1))

     ((not runname)
      (debug:print-error 0 *default-log-port* "Missing required parameter for "
			 action ", you must specify the run name pattern with -runname patt")
      (exit 2))
     ((not testpatt)
      (debug:print-error 0 *default-log-port* "Missing required parameter for "
			 action ", you must specify the test pattern with -testpatt")
      (exit 3))
     (else
      (if (not (car *configinfo*))
	  (begin
	    (debug:print-error 0 *default-log-port* "Attempted " action "on test(s) but run area config file not found")
	    (exit 1))
	  ;; put test parameters into convenient variables
	  (begin
	    ;; check for correct version, exit with message if not correct
	    (common:exit-on-version-changed)
	    (runs:operate-on  action
			      target
			      runname
			      testpatt
			      state:  (common:args-get-state)
			      status: (common:args-get-status)
			      new-state-status: (args:get-arg "-set-state-status")
                              mode: mode)))
      (set! *didsomething* #t)))))

(if (args:get-arg "-kill-runs")
    (general-run-call 

;;       (print (sort run-ids <))
;;       (set! *didsomething* #t)))
      
      
;;======================================================================
;; full run
;;======================================================================

(define (handle-run-requests target runname keys keyvals need-clean)	 
  (if (or (args:get-arg "-kill-rerun") (args:get-arg "-rerun-clean")) ;; first set states/statuses correct
      ;; For rerun-clean do we or do we not support the testpatt?
      (let ((states   (or (configf:lookup *configdat* "validvalues" "cleanrerun-states")
			  "KILLREQ,KILLED,UNKNOWN,INCOMPLETE,STUCK,NOT_STARTED"))
	    (statuses (or (configf:lookup *configdat* "validvalues" "cleanrerun-statuses")
			  "FAIL,INCOMPLETE,ABORT,CHECK,DEAD,PREQ_FAIL,PREQ_DISCARDED")))
	(hash-table-set! args:arg-hash "-preclean" #t)
	(runs:operate-on 'set-state-status
			 target
			 (common:args-get-runname)  ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
			 ;; "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
			 (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
			 state:  states
			 ;; status: statuses
			 new-state-status: "NOT_STARTED,n/a")
	(runs:clean-cache target runname *toppath*)
	(runs:operate-on 'set-state-status
			 target
			 (common:args-get-runname)  ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
			 ;; "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
			 (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
			 ;; state:  states
			 status: statuses
			 new-state-status: "NOT_STARTED,n/a")))
  ;; RERUN ALL
  (if (args:get-arg "-rerun-all") ;; first set states/statuses correct
      (let* ((rconfig (full-runconfigs-read)))
	(hash-table-set! args:arg-hash "-preclean" #t)
	(runs:operate-on 'set-state-status
			 target
			 (common:args-get-runname)  ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
			 (common:args-get-testpatt rconfig) ;; (args:get-arg "-testpatt")
			 state:  #f
			 ;; status: statuses
			 new-state-status: "NOT_STARTED,n/a")
	(runs:clean-cache target runname *toppath*)
	(runs:operate-on 'set-state-status
			 target
			 (common:args-get-runname)  ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
			 (common:args-get-testpatt rconfig) ;; (args:get-arg "-testpatt")
			 ;; state:  states
			 status: #f
			 new-state-status: "NOT_STARTED,n/a")))
  (let* ((config-reruns      (let ((x (configf:lookup *configdat* "setup" "reruns")))
			       (if x (string->number x) #f)))
	 (rerun-cnt (if config-reruns
			config-reruns
			1)))

    (runs:run-tests target
		    runname
		    #f ;; (common:args-get-testpatt #f)
		    ;; (or (args:get-arg "-testpatt")
		    ;;     "%")
		    user
		    args:arg-hash
		    run-count: rerun-cnt)))

;; get lock in db for full run for this directory
;; for all tests with deps
;;   walk tree of tests to find head tasks
;;   add head tasks to task queue
;;   add dependant tasks to task queue 
;;   add remaining tasks to task queue

(if (or (args:get-arg "-runall")
	(args:get-arg "-run")
	(args:get-arg "-rerun-clean")
	(args:get-arg "-rerun-all")
	(args:get-arg "-runtests")
        (args:get-arg "-kill-rerun"))
    (let ((need-clean (or (args:get-arg "-rerun-clean")
                          (args:get-arg "-rerun-all")))
	  (orig-cmdline (string-intersperse (argv) " ")))
      (general-run-call 
       "-runall"
       "run all tests"
       (lambda (target runname keys keyvals)








	 (if (or (string-search "%" target)






		 (string-search "%" runname)) ;; we are being asked to re-run multiple runs
	     (let* ((run-specs (rmt:simple-get-runs runname #f #f target #f))) ;; list of simple-run records
	       (debug:print-info 0 *default-log-port* "Pattern supplied for target or runname with "
				 (length run-specs) " matches round. Running each in turn.")
	       (if (null? run-specs)
		   (debug:print 0 *default-log-port* "WARNING: No runs match target " target " and runname " runname))


	       (for-each (lambda (spec) 
			   (let* ((precmd     (if (args:get-arg "-precmd")(conc (args:get-arg "-precmd") " ") ""))


				  (newcmdline (conc



					       precmd
					       (string-substitute
						(conc "target " target)







						(conc "target " (simple-run-target spec))






						(string-substitute
						 (conc "runname " runname)
						 (conc "runname " (simple-run-runname spec))
						 orig-cmdline)))))
			     (debug:print 0 *default-log-port* "ORIG: " orig-cmdline)
			     (debug:print 0 *default-log-port* "NEW:  " newcmdline)
			     (system newcmdline)))
			 run-specs))





	     (handle-run-requests target runname keys keyvals need-clean))))))

;;======================================================================
;; run one test
;;======================================================================

;; 1. find the config file
;; 2. change to the test directory

;;======================================================================
;; Archive tests
;;======================================================================
;; Archive tests matching target, runname, and testpatt
(if (args:get-arg "-archive")
    ;; else do a general-run-call
    (begin
      ;; for the archive get we need to preserve the starting dir as part of the target path
      (if (and (args:get-arg "-dest")
	       (not (equal? (substring (args:get-arg "-dest") 0 1) "/")))
	  (let ((newpath  (conc (current-directory) "/" (args:get-arg "-dest"))))
	    (debug:print-info 1 *default-log-port* "Preserving original path to destination, was " (args:get-arg "-dest") ", now " newpath)
	    (hash-table-set! args:arg-hash "-dest" newpath)))
      (general-run-call 
       "-archive"
       "Archive"
       (lambda (target runname keys keyvals)
	 (operate-on 'archive target-in: target runname-in: runname )))))

;;======================================================================
;; Extract a spreadsheet from the runs database
;;======================================================================

(if (args:get-arg "-extract-ods")
    (general-run-call

     
(if (args:get-arg "-generate-html")
    (let* ((toppath (launch:setup)))
      (if (tests:create-html-tree #f)
          (debug:print-info 0 *default-log-port* "HTML output created in " toppath "/lt/page0.html")
          (debug:print 0 *default-log-port* "Failed to create HTML output in " toppath "/lt/runs-index.html"))
      (set! *didsomething* #t)))

(if (args:get-arg "-generate-html-structure")
    (let* ((toppath (launch:setup)))
      ;(if (tests:create-html-tree #f)
 				(if (tests:create-html-summary #f)
          (debug:print-info 0 *default-log-port* "HTML output created in " toppath "/lt/targets.html")
          (debug:print 0 *default-log-port* "Failed to create HTML output in " toppath "/lt/runs-index.html"))
      (set! *didsomething* #t)))

(if (args:get-arg "-syscheck")
    (begin
      (mutils:syscheck common:raw-get-remote-host-load
		       server:get-best-guess-address
		       read-config)
      (set! *didsomething* #t)))

;;======================================================================
;; Exit and clean up
;;======================================================================

(if (not *didsomething*)
    (debug:print 0 *default-log-port* help)
    (set! *time-to-exit* #t)