Megatest

;; (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 processmod))
(declare (uses processmod.import))
(declare (uses configfmod))
(declare (uses configfmod.import))

(declare (uses runs))
(declare (uses launch))
(declare (uses server))
(declare (uses tests))
(declare (uses genexample))
;; (declare (uses daemon))

(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 apimod))
(declare (uses apimod.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
	processmod
	configfmod
	dbfile
	portlogger
	tcp-transportmod
	rmtmod
	apimod
        )

(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")

  -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)
  -remove-dbs all         : remove Megatest DBs before importing sexpr. (Use only with -import-sexpr)
  -regen-testfiles        : regenerate scripts and logpro files from testconfig, run in test context
  
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
  -refdb2dat refdb        : convert refdb to sexp or to format specified by s-dumpmode

			"-pathmod"
			"-env2file"
			"-envcap"
			"-envdelta"
			"-setvars"
			"-set-state-status"
			"-import-sexpr"
                        "-remove-dbs" ;; to be used only with -import-sexpr to remove megatest dbs first.
			"-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"

                        "-run-wait"      ;; wait on a run to complete (i.e. no RUNNING)
			"-one-pass"      ;;
			"-local"         ;; run some commands using local db access
			"-generate-html"
			"-generate-html-structure" 
			"-list-run-time"
                        "-list-test-time"
			"-regen-testfiles"
			
			;; misc queries
			"-list-disks"
			"-list-targets"
			"-list-db-targets"
			"-show-runconfig"
			"-show-config"

    (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: megatest -server starting on " (get-host-name) " for " dbfname " using tcp method with timeout of "timeout)
	   (tt-server-timeout-param timeout)
	   (api:queue-processor)
	   (thread-start! (make-thread api:print-db-stats "print-db-stats"))
	   (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)))

  )
)




(if (args:get-arg "-kill-servers")
  
  (let* ((tl (launch:setup)) ;; need this to initialize *toppath*
        (servdir (tt:get-servinfo-dir *toppath*))
        (servfiles (glob (conc servdir "/*:*.db")))
        (fmtstr  "~10a~22a~10a~25a~25a~8a\n")
        (dbfiles (if (file-exists? (conc *toppath* "/.mtdb/main.db")) (append (glob (conc *toppath* "/.mtdb/main.db")) (glob (conc *toppath* "/.mtdb/?.db"))(glob (conc *toppath* "/.mtdb/??.db"))) '()))
        (ttdat (make-tt areapath: *toppath*))
     )
     (format #t fmtstr "DB" "host:port" "PID" "age" "last mod" "state")
     (for-each
        (lambda (dbfile)
          (let* (
            (dbfname (conc (pathname-file dbfile) ".db"))

                ) 
              )
              sfiles
            )
          )
       )
       dbfiles
     )
     ;; remove this db, because otherwise metadata contains records for old servers, and this causes a problem with db:no-sync-get-lock-with-id.
     (if (file-exists? (conc *toppath* "/.mtdb/no-sync.db"))
       (delete-file (conc *toppath* "/.mtdb/no-sync.db"))
     )
     (set! *didsomething* #t)
     (exit)  
  )
)

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

	   (let* ((db       #f)
		  ;; DO NOT run remote
		  (paths    (tests:test-get-paths-matching keys target (args:get-arg "-test-files"))))
	     (for-each (lambda (path)
			 (print path))
		       paths))))))

;;======================================================================
;; Utils for test areas
;;======================================================================

(if (args:get-arg "-regen-testfiles")
    (if (getenv "MT_TEST_RUN_DIR")
	(begin
	  (launch:setup)
	  (change-directory (getenv "MT_TEST_RUN_DIR"))
	  (let* ((testname (getenv "MT_TEST_NAME"))
		 (itempath (getenv "MT_ITEMPATH")))
	    (launch:extract-scripts-logpro (getenv "MT_TEST_RUN_DIR") testname itempath #f))
	  (set! *didsomething* #t))
	(debug:print 0 *default-log-port* "ERROR: Must run -regen-testfiles in a test environment (i.e. test xterm from dashboard)")))
		 	  
;;======================================================================
;; Archive tests
;;======================================================================
;; Archive tests matching target, runname, and testpatt
(if (equal? (args:get-arg "-archive") "replicate-db")
    (begin
          ;; check if source
          ;; check if megatest.db exist
         (launch:setup)
         (if (not (args:get-arg "-source"))
             (begin 
             (debug:print-info 1 *default-log-port* "Missing required argument -source <archive path>")
             (exit 1)))
         (if (common:file-exists? (conc  *toppath* "/megatest.db"))
             (begin  
               (debug:print-info 1 *default-log-port* "File " (conc  *toppath* "/megatest.db") " already exists. Please remove it before trying to replicate db")
               (exit 1)))
         (if (and (common:make-tmpdir-name *toppath* "") (> (length (directory   (common:make-tmpdir-name *toppath* "") #f)) 0))
           (begin
           (debug:print-info 1 *default-log-port* (common:make-tmpdir-name *toppath* "") " not empty. Please remove it before trying to replicate db")
           (exit 1)))    
          ;; check if timestamp 
          (let* ((source (args:get-arg "-source"))
                (src     (if (not (equal? (substring source 0 1) "/"))
                             (conc (current-directory) "/" source)
                             source))
                (ts (if (args:get-arg "-time-stamp")   (args:get-arg "-time-stamp") "latest")))

    (begin
      (if (not (launch:setup))
	  (begin
	    (debug:print 0 *default-log-port* "Failed to setup, exiting") 
	    (exit 1)))
      ;; keep this one local
      ;; (open-run-close patch-db #f)
      (let ((dbstructs (db:setup)))
        (common:cleanup-db dbstructs full: #t))
      (set! *didsomething* #t)))

(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)))
        (common:cleanup-db dbstructs))
      (set! *didsomething* #t)))

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

	(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)
                          #f))) ;; make-dbr:dbstruct path: toppath local: (args:get-arg "-local")) #f)))
      (if *toppath*
	  (cond
	   ((getenv "MT_RUNSCRIPT")
	    ;; How to run megatest scripts
	    ;;
	    ;; #!/bin/bash

;; ;; ;; redo me        (list "uname" "rundir" "final_logf" "comment"))
;; ;; ;; redo me       (set! *didsomething* #t)))

(if (args:get-arg "-import-megatest.db")
    (begin
      (launch:setup)
      (db:multi-db-sync 
       (db:setup)
       'killservers
       'dejunk
       'adj-testids
       'old2new
       )
      (set! *didsomething* #t)))

(if (args:get-arg "-import-sexpr")
 (let*(
   (toppath (launch:setup))
   (tmppath (common:make-tmpdir-name toppath "")))
   (if (file-exists? (conc toppath "/.mtdb")) 
     (if (args:get-arg "-remove-dbs")
       (let* ((dbfiles (conc toppath "/.mtdb/* " tmppath "/*")))
        (debug:print 0 *default-log-port* "Removing db files: " dbfiles)
        (system (conc "rm -rvf " dbfiles))
       )
       (begin
         (debug:print 0 *default-log-port* "ERROR: Cannot import sexpr with an existing DB present.")
         (debug:print 0 *default-log-port* "Add '-remove-dbs all'  to remove the current Megatest DBs.")
         (set! *didsomething* #t)
         (exit)
       )
     )
     (debug:print 0 *default-log-port* "Did not find " (conc toppath "/.mtdb"))
   )
   (db: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))
	   (tmpdbpth (dbr:dbstruct-tmppath dbstruct))
	   (lockfile (conc tmpdbpth ".lock"))
	   (locked   (common:simple-file-lock lockfile)) 
	   (res      (if locked
			 (db:multi-db-sync 
			  dbstruct
			  'new2old)
			 #f)))
      (if res
	  (begin
	    (common:simple-file-release-lock lockfile)
	    (debug:print 0 *default-log-port* "Synced " res " records to megatest.db"))
	  (debug:print 0 *default-log-port* "Skipping sync, there is a sync in progress."))
      (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"...")
			  (debug:print-info 0 *default-log-port* "PID = " (current-process-id))
			  (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 2 *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))
           (synclock-mod-time (if (file-exists? lockfile)
             (handle-exceptions
		 exn
	       #f
	       (file-modification-time synclock-file))
	     #f))
            (age (if synclock-mod-time (- (current-seconds) synclock-mod-time) 1000))
           )
      (if (and src-db dest-db)
	  (if (file-exists? src-db)
	      (if (and (file-exists? lockfile) (< age 20))
		    (debug:print 0 *default-log-port* "Lock "lockfile" exists, skipping sync...")
                 (begin
                  (if (file-exists? lockfile)
                    (begin
                    (debug:print 0 *default-log-port* "Deleting old lock file " lockfile)
                    (delete-file lockfile)
                    )
                  )
		  (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* "Releasing lock file " lockfile)
                   )
               )
	      (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)))