Megatest

(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 mtargs))
(declare (uses mtargs.import))
(declare (uses debugprint))
(declare (uses debugprint.import))
(declare (uses commonmod))
(declare (uses commonmod.import))

(declare (uses runs))
(declare (uses launch))
(declare (uses server))

(declare (uses tests))
(declare (uses genexample))
;; (declare (uses daemon))

(declare (uses db))
;; (declare (uses dcommon))

(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 db))
(declare (uses dbfile))
(declare (uses dbfile.import))
(declare (uses dbmod))
(declare (uses dbmod.import))
(declare (uses portlogger))
(declare (uses portlogger.import))
(declare (uses tcp-transportmod))
(declare (uses tcp-transportmod.import))
(declare (uses rmtmod))
(declare (uses rmtmod.import))

;; (declare (uses debugprint))
;; (declare (uses debugprint.import))

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

(import (prefix mtargs args:)
        debugprint
	dbmod
	commonmod
	dbfile
	portlogger
	tcp-transportmod
	rmtmod
        )

(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:))
(use readline apropos json http-client directory-utils typed-records)
(use http-client srfi-18 extras format tcp-server tcp)

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

(require-library mutils)

(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

;; set some parameters here - these need to be put in something that can be loaded from other
;; executables such as dashboard and mtutil
;;
(include "transport-mode.scm")
(dbfile:db-init-proc db:initialize-main-db)
(debug:enable-timestamp #t) 


(set! rmtmod:send-receive rmt:send-receive)
 ;;(lambda params (apply rmt:send-receive params))) ;; make send-receive available to rmtmod via parameter


;; 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")))
  (if (common:file-exists? debugcontrolf)
      (load debugcontrolf)))

  -load file.scm          : load and run file.scm
  -mark-incompletes       : find and mark incomplete tests
  -ping run-id|host:port  : ping server, exit with 0 if found
  -debug N|N,M,O...       : enable debug 0-N or N and M and O ...
  -debug-noprop N|M,M,O...: enable debug but do not propagate to subprocesses via MT_DEBUG
  -config fname           : override the megatest.config file with fname
  -append-config fname    : append fname to the megatest.config file
  -import-sexpr fname     : import a sexpr file (use -list-runs % -dumpmode sexpr to create)

Utilities
  -env2file fname         : write the environment to fname.csh and fname.sh
  -envcap a               : save current variables labeled as context 'a' in file envdat.db
  -envdelta a-b           : output enviroment delta from context a to context b to -o fname
                            set the output mode with -dumpmode csh, bash or ini
                            note: ini format will use calls to use curr and minimize path

  -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 
  -list-waivers           : dump waivers for specified target, runname, testpatt to stdout
  -db2db                  : sync db to db, use -from, -to for dbs, -period and -timeout for continuous sync

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

			":state"  
			"-state"
			":status"
			"-status"
			"-list-runs"
                        "-testdata-csv"
			"-testpatt"
                        ;; "--modepatt"
                        "-modepatt"
                        "-tagexpr"
			"-itempatt"
			"-setlog"
			"-set-toplog"
			"-runstep"
			"-logpro"
			"-m"
			"-rerun"

			"-days"
			"-rename-run"
			"-from"
			"-to"
			"-dest"
                        "-source" 
                        "-time-stamp" 
			;; values and messages
			":category"
			":variable"

			"-extract-ods"
			"-pathmod"
			"-env2file"
			"-envcap"
			"-envdelta"
			"-setvars"
			"-set-state-status"
			"-import-sexpr"
			"-period"  ;; sync period in seconds
			"-timeout" ;; exit sync if timeout in seconds exceeded since last change

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

			;; archive 

			"-override-timeout"
			"-test-files"  ;; -test-paths is for listing all
			"-load"        ;; load and exectute a scheme file
			"-section"
			"-var"
			"-dumpmode"
			"-run-id"
			"-db"
			"-ping"
			"-refdb2dat"
			"-o"
			"-log"
                        "-sync-log"
			"-since"
			"-fields"

			"-create-megatest-area"
			"-mark-incompletes"

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

                        "-diff-rep"

        (define *didsomething* #t)  
        (exit 1))))

;; this segment will run launch:setup only if -log is not set. This is fairly safe as servers are not
;; manually started and thus should never be started in a non-megatest area. Thus no need to handle situation
;; where (launch:setup) returns #f?
;;
(if (or (args:get-arg "-log")#;(args:get-arg "-server")) ;; redirect the log always when a server
    (handle-exceptions
	exn
      (begin
	(print "ERROR: Failed to switch to log output. " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn))

      (let* ((tl   (or (args:get-arg "-log")(launch:setup)))   ;; run launch:setup if -server, ensure we do NOT run launch:setup if -log specified
	     (dbname (args:get-arg "-db"))   ;; for the server logfile name
	     (logf (or (args:get-arg "-log") ;; use -log unless we are a server, then craft a logfile name
		       (conc tl "/logs/server-"(or dbname "unk")"-"(current-process-id) "-" (get-host-name) ".log")))
	     (oup  (open-logfile logf)))
	(if (not (args:get-arg "-log"))
	    (hash-table-set! args:arg-hash "-log" logf)) ;; fake out future queries of -log
	(debug:print-info 0 *default-log-port* "Sending log output to " logf)
	(set! *default-log-port* oup))))

(if (or (args:get-arg "-h")

					    (printf "Sending signal/term to ~A\n" pid)
					    (process-signal pid signal/term))))))
		       (process:children #f))
		      (original-exit exit-code)))))

;; for some switches always print the command to stderr
;;
(if (args:any-defined? "-run" "-runall" "-remove-runs" "-set-state-status" "-kill-runs" "-kill-rerun")
    (debug:print 0 *default-log-port* (string-intersperse (argv) " ")))















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

(debug:setup)

      (if out-file (close-output-port out-port))
      (exit) ;; yes, bending the rules here - need to exit since this is a utility
      ))

(if (args:get-arg "-ping")
    (let* ((server-id     (string->number (args:get-arg "-ping"))) ;; extract run-id (i.e. no ":"
	   (host:port     (args:get-arg "-ping")))
      (debug:print 0 *default-log-port* "NOT YET REIMPLEMENTED FOR TCP/INMEM") ;; bug
      (exit)))
      ;; (server:ping (or server-id host:port) #f do-exit: #t)))

;;======================================================================
;; Capture, save and manipulate environments
;;======================================================================

;; NOTE: Keep these above the section where the server or client code is setup

;; Start the server - can be done in conjunction with -runall or -runtests (one day...)
;;   we start the server if not running else start the client thread
;;======================================================================

;; Server? Start up here.
;;
(if (args:get-arg "-server")
    (let* (;; (run-id     (args:get-arg "-run-id"))
	   (dbfname    (args:get-arg "-db"))
	   (tl         (launch:setup))
	   (keys       (keys:config-get-fields *configdat*)))
      (case (rmt:transport-mode)
	((tcp)
	 (let* ((timeout    (server:expiration-timeout)))
	   (debug:print 0 *default-log-port* "INFO: Running using tcp method with server timeout of "timeout)
	   (tt-server-timeout-param timeout)
	   (if dbfname
	       (tt:start-server tl #f dbfname api:tcp-dispatch-request-make-handler keys)
	       (begin
		 (debug:print 0 *default-log-port* "ERROR: transport mode is tcp - -db is required.")
		 (exit 1)))))
	(else (debug:print 0 *default-log-port* "ERROR: rmt:transport-mode value not recognised "(rmt:transport-mode))))
      (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)))
      (debug:print 0 *default-log-port* "NOT YET REIMPLEMENTED FOR TCP/INMEM") ;; BUG
      (exit)
      (if tl ;; all roads from here exit
	  (let* ((servers (server:choose-server *toppath* 'all-valid)) ;; (server:get-list *toppath*))
		 (fmtstr  "~33a~22a~20a~20a~8a\n"))
            (if (not servers)
              (begin
                (debug:print-info 1 *default-log-port* "No servers found")
                (exit)
              )
            )
       	    (format #t fmtstr "PID" "host:port" "age (hms)" "Last mod" "State")
	    (format #t fmtstr "===" "=========" "=========" "========" "=====")
	    (for-each ;;  (ip-addr port? mod-time host port start-time pid )
	     (lambda (server)
	       (let* ((mtm (any->number (caddr server)))
		      (mod (if mtm (- (current-seconds) mtm) "unk"))
		      (age (- (current-seconds)(or (any->number mtm) (current-seconds))))

		      (pid (list-ref server 4))
		      (url (conc (car server) ":" (cadr server)))
		      (alv (if (number? mod)(< mod 360) #f)))
		 (format #t
			 fmtstr
			 pid
			 url
			 (seconds->hr-min-sec age)
			 (seconds->hr-min-sec mod)
			 (if alv "alive" "dead"))
		 (if (and alv
			  (args:get-arg "-kill-servers"))
		     (begin
		       (debug:print-info 0 *default-log-port* "Attempting to kill server with pid " pid)
		       (server:kill server)))))
	     (sort servers (lambda (a b)
			     (let ((ma (or (any->number (car a)) 9e9))
				   (mb (or (any->number (car b)) 9e9)))
			       (> ma mb)))))

	    (set! *didsomething* #t)
	    (exit))
	  (exit))))
      ;; must do, would have to add checks to many/all calls below

;;======================================================================
;; Weird special calls that need to run *after* the server has started?

;; NOTE: list-runs and list-db-targets operate on local db!!!
;;
;; IDEA: megatest list -runname blah% ...
;;
(if (or (args:get-arg "-list-runs")
	(args:get-arg "-list-db-targets"))
    (if (launch:setup)

	(let* ((runpatt     (args:get-arg "-list-runs"))
               (access-mode (db:get-access-mode))
	       (testpatt    (common:args-get-testpatt #f))
	       ;; (if (args:get-arg "-testpatt") 
	       ;;  	        (args:get-arg "-testpatt") 
	       ;;  	        "%"))
	       (keys        (rmt:get-keys)) ;; (db:get-keys dbstruct))
	       ;; (runsdat  (db:get-runs dbstruct runpatt #f #f '()))

	       (tests-spec  (let ((t (alist-ref "tests" fields-spec equal?)))
			      (if (and t (null? t)) ;; all fields
				  db:test-record-fields
				  t)))
	       (adj-tests-spec (delete-duplicates (if tests-spec (cons "id" tests-spec) db:test-record-fields))) ;; '("id"))))
	       (steps-spec  (alist-ref "steps" fields-spec equal?))
	       (test-field-index (make-hash-table)))
	  (if (and (args:get-arg "-dumpmode")
		   (not (member (args:get-arg "-dumpmode") '("sexpr" "json" "ods" "list"))))
	      (begin
		(debug:print 0 *default-log-port* "ERROR: dumpmode "(args:get-arg "-dumpmode")" not recognised. Use sexpr, json, ods or list")
		(exit)))
	  (if (and tests-spec (not (null? tests-spec))) ;; do some validation and processing of the test-spec
	      (let ((invalid-tests-spec (filter (lambda (x)(not (member x db:test-record-fields))) tests-spec)))
		(if (null? invalid-tests-spec)
		    ;; generate the lookup map test-field-name => index-number
		    (let loop ((hed (car adj-tests-spec))
			       (tal (cdr adj-tests-spec))
			       (idx 0))

			;; (mutils:hierhash-set! data (db:get-value-by-header run header "status")     targetstr runname "meta" "status"     )
			;; (mutils:hierhash-set! data (db:get-value-by-header run header "state")      targetstr runname "meta" "state"      )
			;; (mutils:hierhash-set! data (conc (db:get-value-by-header run header "id"))  targetstr runname "meta" "id"         )
			;; (mutils:hierhash-set! data (db:get-value-by-header run header "event_time") targetstr runname "meta" "event_time" )
			;; (mutils:hierhash-set! data (db:get-value-by-header run header "comment")    targetstr runname "meta" "comment"    )
			;; ;; add last entry twice - seems to be a bug in hierhash?
			;; (mutils:hierhash-set! data (db:get-value-by-header run header "comment")    targetstr runname "meta" "comment"    )
		       ((#f list)
			(if (null? runs-spec)
			    (print "Run: " targetstr "/" runname 
				   " status: " (db:get-value-by-header run header "state")
				   " run-id: " run-id ", number tests: " (length tests)
				   " event_time: " (db:get-value-by-header run header "event_time"))
			    (begin
			      (if (not (member "target" runs-spec))
			          ;; (display (conc "Target: " targetstr))
			          (display (conc "Run: " targetstr "/" runname " ")))
			      (for-each
			       (lambda (field-name)
				 (if (equal? field-name "target")
				     (display (conc "target: " targetstr " "))
				     (display (conc field-name ": " (db:get-value-by-header run header (conc field-name)) " "))))
			       runs-spec)
			      (newline))))
		       (else
			(debug:print 0 *default-log-port* "ERROR: dumpmode "(args:get-arg "-dumpmode")" not recognised. Use sexpr, json, ods or list")
			))
		       
		     (for-each 
		      (lambda (test)
		      	(common:debug-handle-exceptions #f
			 exn
			 (begin
			   (debug:print-error 0 *default-log-port* "Bad data in test record? " test)

       "-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 found. 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

;;======================================================================

(if (args:get-arg "-extract-ods")
    (general-run-call
     "-extract-ods"
     "Make ods spreadsheet"
     (lambda (target runname keys keyvals)
       (let ((dbstruct   (make-dbr:dbstruct areapath: *toppath* local: #t))
	     (outputfile (args:get-arg "-extract-ods"))
	     (runspatt   (or (args:get-arg "-runname")(args:get-arg ":runname")))
	     (pathmod    (args:get-arg "-pathmod")))
	     ;; (keyvalalist (keys->alist keys "%")))
	 (debug:print 2 *default-log-port* "Extract ods, outputfile: " outputfile " runspatt: " runspatt " keyvals: " keyvals)
	 (db:extract-ods-file dbstruct outputfile keyvals (if runspatt runspatt "%") pathmod)
	 (db:close-all dbstruct)

	      (begin
		(debug:print 0 *default-log-port* "Failed to setup, exiting")
		(exit 1)))

	  (if (args:get-arg "-runstep")(debug:print-info 1 *default-log-port* "Running -runstep, first change to directory " work-area))
	  (change-directory work-area)
	  ;; can setup as client for server mode now


	  (if (args:get-arg "-load-test-data")
	      ;; has sub commands that are rdb:
	      ;; DO NOT put this one into either rmt: or open-run-close
	      (tdb:load-test-data run-id test-id))
	  (if (args:get-arg "-setlog")
	      (let ((logfname (args:get-arg "-setlog")))

(if (args:get-arg "-cleanup-db")
    (begin
      (if (not (launch:setup))
	  (begin
	    (debug:print 0 *default-log-port* "Failed to setup, exiting") 
	    (exit 1)))

;;      (if (not (server:choose-server *toppath* 'home?))
;;	  (begin
;;	    (debug:print 0 *default-log-port* "Servers are not running on this host or no servers alive. Cannot run cleanup-db")
;;	    (exit 1)))

      (let ((dbstructs (db:setup #f)))
        (common:cleanup-db dbstructs))
      (set! *didsomething* #t)))

(if (args:get-arg "-mark-incompletes")
    (begin
      (if (not (launch:setup))

    (exit 0)))

(if (or (getenv "MT_RUNSCRIPT")
	(args:get-arg "-repl")
	(args:get-arg "-load"))
    (let* ((toppath (launch:setup))
	   (dbstructs (if (and toppath
			       ;; NOTE: server:choose-server is starting a server
			       ;;   either add equivalent for tcp mode or ????
                               #;(server:choose-server toppath 'home?))
                          (db:setup #t)
                          #f))) ;; make-dbr:dbstruct path: toppath local: (args:get-arg "-local")) #f)))
      (if *toppath*
	  (cond
	   ((getenv "MT_RUNSCRIPT")
	    ;; How to run megatest scripts
	    ;;

       'killservers
       'dejunk
       'adj-testids
       'old2new
       )
      (set! *didsomething* #t)))

(if (args:get-arg "-import-sexpr")
    (begin
      (launch:setup)

      (rmt:import-sexpr (args:get-arg "-import-sexpr"))
      (set! *didsomething* #t)))

(if (args:get-arg "-sync-to-megatest.db")
    (let* ((duh      (launch:setup))
	   (dbstruct (db:setup #t))
	   (tmpdbpth (dbr:dbstruct-tmppath dbstruct))
	   (lockfile (conc tmpdbpth ".lock"))
	   (locked   (common:simple-file-lock lockfile)) 

      (set! *didsomething* #t)))

(if (args:get-arg "-sync-to")
    (let ((toppath (launch:setup)))
      (tasks:sync-to-postgres *configdat* (args:get-arg "-sync-to"))
      (set! *didsomething* #t)))

;; use with -from and -to
;;
(if (args:get-arg "-db2db")
    (let* ((duh         (launch:setup))
	   (src-db      (args:get-arg "-from"))
	   (dest-db     (args:get-arg "-to"))
	   ;; (sync-period (args:get-arg-number "-period"))
	   ;; (sync-timeout (args:get-arg-number "-timeout"))
	   (sync-period-in  (args:get-arg "-period"))
	   (sync-timeout-in (args:get-arg "-timeout"))
	   (sync-period     (if sync-period-in (string->number sync-period-in) #f))
	   (sync-timeout    (if sync-timeout-in (string->number sync-timeout-in) #f))
	   (lockfile    (conc dest-db".sync-lock"))
	   (keys        (db:get-keys #f))
	   (thesync     (lambda (last-update)
			  (debug:print-info 0 *default-log-port* "Attempting to sync data from "src-db" to "dest-db"...")
			  (if (not (file-exists? dest-db))
			      (begin
				(debug:print 0 *default-log-port* "Using copy to create "dest-db" from "src-db)
				(file-copy src-db dest-db)
				1)
			      (let ((res (dbmod:db-to-db-sync src-db dest-db last-update (dbfile:db-init-proc) keys)))
				(if res
				    (debug:print-info 0 *default-log-port* "Synced " res " records from "src-db" to "dest-db)
				    (debug:print-info 0 *default-log-port* "No sync due to permissions or other issue."))
				res))))
	   (start-time  (current-seconds)))
      (if (and src-db dest-db)
	  (if (file-exists? src-db)
	      (if (file-exists? lockfile)
		  (debug:print 0 *default-log-port* "Lock "lockfile" exists, skipping sync...")
		  (dbfile:with-simple-file-lock
		   lockfile
		   (lambda ()
		     (let loop ((last-changed (current-seconds))
				(last-update  0))
		       (let* ((changes (handle-exceptions
					   exn
					   (begin
					     (debug:print 0 *default-log-port* "Exception in sync: "(condition->list exn))
					     (delete-file lockfile)
					     (exit))
					 (thesync last-update)))
			      (now-time (current-seconds)))
			 (if (and sync-period sync-timeout) ;; 
			     (if (and (< (- now-time start-time) 600) ;; hard limit on how long we run for
				      (>  sync-timeout (- now-time last-changed)))
				 (begin
				   (if sync-period (thread-sleep! sync-period))
				   (loop (if (> changes 0) now-time last-changed) now-time)))))))))
	      (debug:print 0 *default-log-port* "No sync due to unreadble or non-existant source file"src-db))
	  (debug:print 0 *default-log-port* "Usage for -db2db; -to and -from must be specified"))
      (set! *didsomething* #t)))

(if (args:get-arg "-list-test-time")
     (let* ((toppath (launch:setup))) 
     (task:get-test-times)  
     (set! *didsomething* #t)))

(if (args:get-arg "-list-run-time")
     (let* ((toppath (launch:setup)))