Megatest

   ods.scm runconfig.scm server.scm configf.scm \
   db.scm keys.scm margs.scm megatest-version.scm \
   process.scm runs.scm tasks.scm tests.scm genexample.scm \
   http-transport.scm filedb.scm tdb.scm \
   client.scm mt.scm \
   ezsteps.scm lock-queue.scm sdb.scm \
   rmt.scm api.scm subrun.scm \
   portlogger.scm archive.scm env.scm diff-report.scm cgisetup/models/pgdb.scm  redo-logpro.scm

# module source files
MSRCFILES = ftail.scm

# Eggs to install (straightforward ones)
EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \
dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \

	runconfig.o \
	runs.o \
	server.o \
	tasks.o \
	tdb.o \
	tests.o \
	subrun.o \
	ezsteps.o \
        redo-logpro.o

tcmt : $(TCMTOBJS) tcmt.scm
	csc $(CSCOPTS) $(TCMTOBJS) tcmt.scm -o tcmt

# install documentation to $(PREFIX)/docs
# DOES NOT REBUILD DOCS
#

    (length  (filter identity (map socket? (glob (conc "/proc/" pid "/fd/*")))))
  )
)


;; GLOBALS

;; job exit info
(defstruct launch:einf (pid #t)(exit-status #t)(exit-code #t)(rollup-status 0))

;; CONTEXTS
(defstruct cxt
  (taskdb #f)
  (cmutex (make-mutex)))
;; (define *contexts* (make-hash-table))
;; (define *context-mutex* (make-mutex))

;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
;;

;;  strftime('%m/%d/%Y %H:%M:%S','now','localtime')

(use srfi-1 posix regex srfi-69 directory-utils call-with-environment-variables)

(declare (unit ezsteps))
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
;; (declare (uses sdb))
;; (declare (uses filedb))

(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")



;;======================================================================
;; ezsteps
;;======================================================================

;; ezsteps were going to be coded as
;; stepname[,predstep1,predstep2 ...] [{VAR1=first,second,third}] command to execute
;;   BUT
;; now are
;; stepname {VAR=first,second,third ...} command ...
;; where the {VAR=first,second,third ...} is optional.

;; given an exit code and whether or not logpro was used calculate OK/BAD
;; return #t if we are ok, #f otherwise
(define (ezsteps:steprun-good? logpro exitcode)
  (or (eq? exitcode 0)
      (and logpro (eq? exitcode 2))))

(define (ezsteps:manage-steps run-id test-id item-path fullrunscript ezsteps subrun test-name tconfigreg exit-info m)
  ;; (let-values
  ;;  (((pid exit-status exit-code)
  ;;    (run-n-wait fullrunscript)))
  ;; (tests:test-set-status! test-id "RUNNING" "n/a" #f #f)
  ;; Since we should have a clean slate at this time there is no need to do 
  ;; any of the other stuff that tests:test-set-status! does. Let's just 
  ;; force RUNNING/n/a

  ;; (thread-sleep! 0.3)
  ;; (tests:test-force-state-status! run-id test-id "RUNNING" "n/a")
  (rmt:set-state-status-and-roll-up-items run-id test-name item-path "RUNNING" #f #f) 
  ;; (thread-sleep! 0.3) ;; NFS slowness has caused grief here

  ;; if there is a runscript do it first
  (if fullrunscript ;;; user controlled steps
      (let ((pid (process-run fullrunscript)))
	(rmt:test-set-top-process-pid run-id test-id pid)
	(let loop ((i 0))
	  (let-values
	   (((pid-val exit-status exit-code) (process-wait pid #t)))
	   (mutex-lock! m)
	   (launch:einf-pid-set!           exit-info  pid)         ;; (vector-set! exit-info 0 pid)
	   (launch:einf-exit-status-set!   exit-info  exit-status) ;; (vector-set! exit-info 1 exit-status)
	   (launch:einf-exit-code-set!     exit-info  exit-code)   ;; (vector-set! exit-info 2 exit-code)
	   (launch:einf-rollup-status-set! exit-info  exit-code)   ;; (vector-set! exit-info 3 exit-code)  ;; rollup status
	   (mutex-unlock! m)
	   (if (eq? pid-val 0)
	       (begin
		 (thread-sleep! 2)
		 (loop (+ i 1)))
	       )))))
  ;; then, if runscript ran ok (or did not get called)
  ;; do all the ezsteps (if any)
  (if (or ezsteps subrun)
      (let* ((test-run-dir (tests:get-test-path-from-environment))
             (testconfig ;; (read-config (conc work-area "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) ;; FIXME??? is allow-system ok here?
	      ;; NOTE: it is tempting to turn off force-create of testconfig but dynamic
	      ;;       ezstep names need a full re-eval here.
	      (tests:get-testconfig test-name item-path tconfigreg #t force-create: #t)) ;; 'return-procs)))
	     (ezstepslst (if (hash-table? testconfig)
			     (hash-table-ref/default testconfig "ezsteps" '())
			     #f)))
	(if testconfig
	    (hash-table-set! *testconfigs* test-name testconfig) ;; cached for lazy reads later ...
	    (begin
	      (launch:setup)
	      (debug:print 0 *default-log-port* "WARNING: no testconfig found for " test-name " in search path:\n  "
			   (string-intersperse (tests:get-tests-search-path *configdat*) "\n  "))))
	;; after all that, still no testconfig? Time to abort
	(if (not testconfig)
	    (begin
	      (debug:print-error 0 *default-log-port* "Failed to resolve megatest.config, runconfigs.config and testconfig issues. Giving up now")
	      (exit 1)))

	;; create a proc for the subrun if requested, save that proc in the ezsteps table as the last entry
	;; 1. get section [runarun]
	;; 2. unset MT_* vars
	;; 3. fix target
	;; 4. fix runname
	;; 5. fix testpatt or calculate it from contour
	;; 6. launch the run
	;; 7. roll up the run result and or roll up the logpro processed result
	(when (configf:lookup testconfig "subrun" "runwait") ;; we use runwait as the flag that a subrun is requested
            (subrun:initialize-toprun-test testconfig test-run-dir)
	    (let* ((mt-cmd (subrun:launch-cmd test-run-dir)))
              (debug:print-info 0 *default-log-port* "Subrun command is \"" mt-cmd "\"")
              (set! ezsteps #t) ;; set the needed flag
	      (set! ezstepslst
                    (append (or ezstepslst '())
                            (list (list "subrun" (conc "{subrun=true} " mt-cmd)))))))

	;; process the ezsteps
	(if ezsteps
	    (begin
	      (if (not (common:file-exists? ".ezsteps"))(create-directory ".ezsteps"))
	      ;; if ezsteps was defined then we are sure to have at least one step but check anyway
	      (if (not (> (length ezstepslst) 0))
		  (debug:print-error 0 *default-log-port* "ezsteps defined but ezstepslst is zero length")
		  (let loop ((ezstep (car ezstepslst))
			     (tal    (cdr ezstepslst))
			     (prevstep #f))
                    (debug:print-info 0 *default-log-port* "Processing ezstep \"" (string-intersperse ezstep " ") "\"")
		    ;; check exit-info (vector-ref exit-info 1)
		    (if (launch:einf-exit-status exit-info) ;; (vector-ref exit-info 1)
			(let ((logpro-used
                               (ezsteps:runstep ezstep run-id test-id
                                                exit-info: exit-info mutex: m is-last-step: (null? tal) testconfig: testconfig))
			      (stepname    (car ezstep)))
			  ;; if logpro-used read in the stepname.dat file
			  (if (and logpro-used (common:file-exists? (conc stepname ".dat")))
			      (launch:load-logpro-dat run-id test-id stepname))
			  (if (ezsteps:steprun-good? logpro-used (launch:einf-exit-code exit-info))
			      (if (not (null? tal))
				  (loop (car tal) (cdr tal) stepname))
			      (debug:print 0 *default-log-port* "WARNING: step " (car ezstep) " failed. Stopping")))
			(debug:print 0 *default-log-port* "WARNING: a prior step failed, stopping at " ezstep)))))))))

;;(rmt:get-test-info-by-id run-id test-id) -> testdat

(define (ezsteps:runstep ezstep run-id test-id #!key
                         (exit-info  (make-launch:einf pid: #t exit-status: #t exit-code: #t rollup-status: 0)) ;; pid exit-status exit-code (i.e. process was successfully run) rollup-status
                         (mutex (make-mutex))
                         (testconfig (tests:get-testconfig test-name item-path tconfigreg #t force-create: #t))
                         (ezsteplst      (hash-table-ref/default testconfig "ezsteps" '()))
                         (is-last-step   #f))
  (let* ((stepname       (if (list? ezsteplst) (car ezstep) ezstep))  ;; do stuff to run the step
	 (stepinfo       (if (list? ezsteplst)
                             (cadr ezstep)
                             (let loop ((tocheck ezsteplst))
                               (cond
                                ((null? tocheck) #f)
                                ((equal? (caar tocheck) ezstep)
                                 (cadar tocheck))
                                (else (loop (cdr tocheck))))))))
    (if stepinfo
        (let* (
	       ;; (let ((info (cadr ezstep)))
	       ;; 		   (if (proc? info) "" info)))
	       ;; (stepproc       (let ((info (cadr ezstep)))
	       ;; 		   (if (proc? info) info #f)))
	       (stepparts      (string-match (regexp "^(\\{([^\\}\\{]*)\\}\\s*|)(.*)$") stepinfo))
	       (stepparams     (list-ref stepparts 2)) ;; for future use, {VAR=1,2,3}, run step for each
	       (paramparts     (if (string? stepparams)
			           (map (lambda (x)(string-split x "=")) (string-split-fields "[^;]*=[^;]*" stepparams))
			           '()))
	       (subrun         (alist-ref "subrun" paramparts equal?))
	       (stepcmd        (list-ref stepparts 3))
	       (script         "") ; "#!/bin/bash\n") ;; yep, we depend on bin/bash FIXME!!!\
	       (logpro-file    (conc stepname ".logpro"))
	       (html-file      (conc stepname ".html"))
	       (dat-file       (conc stepname ".dat"))
	       (tconfig-logpro (configf:lookup testconfig "logpro" stepname))
	       (logpro-used    (common:file-exists? logpro-file)))

          (debug:print 0 *default-log-port* "stepparts: " stepparts ", stepparams: " stepparams
                       ", paramparts: " paramparts ", subrun: " subrun ", stepcmd: " stepcmd)
          
          (if (and tconfig-logpro
	           (not logpro-used)) ;; no logpro file found but have a defn in the testconfig
	      (begin
	        (with-output-to-file logpro-file
	          (lambda ()
	            (print ";; logpro file extracted from testconfig\n"
		           ";;")
	            (print tconfig-logpro)))
	        (set! logpro-used #t)))
          
          ;; NB// can safely assume we are in test-area directory
          (debug:print 4 *default-log-port* "ezsteps:\n stepname: " stepname " stepinfo: " stepinfo " stepparts: " stepparts
		       " stepparams: " stepparams " stepcmd: " stepcmd)
          
          ;; ;; first source the previous environment
          ;; (let ((prev-env (conc ".ezsteps/" prevstep (if (string-search (regexp "csh") 
          ;;      							 (get-environment-variable "SHELL")) ".csh" ".sh"))))
          ;;   (if (and prevstep (common:file-exists? prev-env))
          ;;       (set! script (conc script "source " prev-env))))
          
          ;; call the command using mt_ezstep
          ;; (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "x") " " stepcmd))
          
          (debug:print 4 *default-log-port* "script: " script)
          (rmt:teststep-set-status! run-id test-id stepname "start" "-" #f #f)
          ;; now launch the actual process
          (call-with-environment-variables 
           (list (cons "PATH" (conc (get-environment-variable "PATH") ":.")))
           (lambda () ;; (process-run "/bin/bash" "-c" "exec ls -l /tmp/foobar > /tmp/delme-more.log 2>&1")
             (let* ((cmd (conc stepcmd " > " stepname ".log 2>&1")) ;; >outfile 2>&1 
	            (pid #f))
	       (let ((proc (lambda ()
		             (set! pid (process-run "/bin/bash" (list "-c" cmd))))))
	         (if subrun
                     (begin
                       (debug:print-info 0 *default-log-port* "Running without MT_.* environment variables.")
                       (common:without-vars proc "^MT_.*"))
	             (proc)))
	       
               (with-output-to-file "Makefile.ezsteps"
                 (lambda ()
                   (print stepname ".log :")
                   (print "\t" cmd)
                   (if (common:file-exists? (conc stepname ".logpro"))
                       (print "\tlogpro " stepname ".logpro " stepname ".html < " stepname ".log"))
                   (print)
                   (print stepname " : " stepname ".log")
                   (print))
                 #:append)

	       (rmt:test-set-top-process-pid run-id test-id pid)
	       (let processloop ((i 0))
	         (let-values (((pid-val exit-status exit-code)(process-wait pid #t)))
		   (mutex-lock! mutex)
		   (launch:einf-pid-set!         exit-info pid)         ;; (vector-set! exit-info 0 pid)
		   (launch:einf-exit-status-set! exit-info exit-status) ;; (vector-set! exit-info 1 exit-status)
		   (launch:einf-exit-code-set!   exit-info exit-code)   ;; (vector-set! exit-info 2 exit-code)
		   (mutex-unlock! mutex)
		   (if (eq? pid-val 0)
		       (begin
			 (thread-sleep! 2)
			 (processloop (+ i 1))))
		   )))))
          (debug:print-info 0 *default-log-port* "step " stepname " completed with exit code " (launch:einf-exit-code exit-info)) ;; (vector-ref exit-info 2))
          ;; now run logpro if needed
          (if logpro-used
	      (let* ((logpro-exe (or (getenv "LOGPRO_EXE") "logpro"))
                     (pid        (process-run (conc "/bin/sh -c '"logpro-exe" "logpro-file " " (conc stepname ".html") " < " stepname ".log > /dev/null'"))))
	        (let processloop ((i 0))
	          (let-values (((pid-val exit-status exit-code)(process-wait pid #t)))
		    (mutex-lock! mutex)
		    ;; (make-launch:einf pid: pid exit-status: exit-status exit-code: exit-code)
		    (launch:einf-pid-set!         exit-info pid)         ;; (vector-set! exit-info 0 pid)
		    (launch:einf-exit-status-set! exit-info exit-status) ;; (vector-set! exit-info 1 exit-status)
		    (launch:einf-exit-code-set!   exit-info exit-code)   ;; (vector-set! exit-info 2 exit-code)
		    (mutex-unlock! mutex)
		    (if (eq? pid-val 0)
			(begin
			  (thread-sleep! 2)
			  (processloop (+ i 1)))))
	          (debug:print-info 0 *default-log-port* "logpro for step " stepname " exited with code " (launch:einf-exit-code exit-info))))) ;; (vector-ref exit-info 2)))))
          
          (let ((exinfo (launch:einf-exit-code exit-info)) ;; (vector-ref exit-info 2))
	        (logfna (if logpro-used (conc stepname ".html") ""))
	        (comment #f))
            (if logpro-used
	        (let ((datfile (conc stepname ".dat")))
	          ;; load the .dat file into the test_data table if it exists
	          (if (common:file-exists? datfile)
		      (set! comment (launch:load-logpro-dat run-id test-id stepname)))
	          (rmt:test-set-log! run-id test-id (conc stepname ".html"))))
            (rmt:teststep-set-status! run-id test-id stepname "end" exinfo comment logfna))
          ;; set the test final status
          (let* ((process-exit-status (launch:einf-exit-code exit-info)) ;; (vector-ref exit-info 2))
	         (this-step-status (cond
			            ((and (eq? process-exit-status 2) logpro-used) 'warn)   ;; logpro 2 = warnings
			            ((and (eq? process-exit-status 3) logpro-used) 'check)  ;; logpro 3 = check
			            ((and (eq? process-exit-status 4) logpro-used) 'waived) ;; logpro 4 = waived
			            ((and (eq? process-exit-status 5) logpro-used) 'abort)  ;; logpro 5 = abort
			            ((and (eq? process-exit-status 6) logpro-used) 'skip)   ;; logpro 6 = skip
			            ((eq? process-exit-status 0)                   'pass)   ;; logpro 0 = pass
			            (else 'fail)))
	         (overall-status   (cond
			            ((eq? (launch:einf-rollup-status exit-info) 2) 'warn) ;; rollup-status (vector-ref exit-info 3)
			            ((eq? (launch:einf-rollup-status exit-info) 0) 'pass) ;; (vector-ref exit-info 3)
			            (else 'fail)))
	         (next-status      (cond 
			            ((eq? overall-status 'pass) this-step-status)
			            ((eq? overall-status 'warn)
			             (if (eq? this-step-status 'fail) 'fail 'warn))
			            ((eq? overall-status 'abort) 'abort)
			            (else 'fail)))
	         (next-state       ;; "RUNNING") ;; WHY WAS THIS CHANGED TO NOT USE (null? tal) ??
	          (cond
	           (is-last-step ;; more to run?
	            "COMPLETED")
	           (else "RUNNING"))))
            (debug:print 4 *default-log-port* "Exit value received: " (launch:einf-exit-code exit-info) " logpro-used: " logpro-used 
		         " this-step-status: " this-step-status " overall-status: " overall-status 
		         " next-status: " next-status " rollup-status: "  (launch:einf-rollup-status exit-info)) ;; (vector-ref exit-info 3))
            (case next-status
	      ((warn)
	       (launch:einf-rollup-status-set! exit-info 2) ;; (vector-set! exit-info 3 2) ;; rollup-status
	       ;; NB// test-set-status! does rdb calls under the hood
	       (tests:test-set-status! run-id test-id next-state "WARN" 
				       (if (eq? this-step-status 'warn) "Logpro warning found" #f)
				       #f))
	      ((check)
	       (launch:einf-rollup-status-set! exit-info 3) ;; (vector-set! exit-info 3 3) ;; rollup-status
	       ;; NB// test-set-status! does rdb calls under the hood
	       (tests:test-set-status! run-id test-id next-state "CHECK" 
				       (if (eq? this-step-status 'check) "Logpro check found" #f)
				       #f))
	      ((waived)
	       (launch:einf-rollup-status-set! exit-info 4) ;; (vector-set! exit-info 3 3) ;; rollup-status
	       ;; NB// test-set-status! does rdb calls under the hood
	       (tests:test-set-status! run-id test-id next-state "WAIVED" 
				       (if (eq? this-step-status 'check) "Logpro waived found" #f)
				       #f))
	      ((abort)
	       (launch:einf-rollup-status-set! exit-info 5) ;; (vector-set! exit-info 3 4) ;; rollup-status
	       ;; NB// test-set-status! does rdb calls under the hood
	       (tests:test-set-status! run-id test-id next-state "ABORT" 
				       (if (eq? this-step-status 'abort) "Logpro abort found" #f)
				       #f))
	      ((skip)
	       (launch:einf-rollup-status-set! exit-info 6) ;; (vector-set! exit-info 3 4) ;; rollup-status
	       ;; NB// test-set-status! does rdb calls under the hood
	       (tests:test-set-status! run-id test-id next-state "SKIP" 
				       (if (eq? this-step-status 'skip) "Logpro skip found" #f)
				       #f))
	      ((pass)
	       (tests:test-set-status! run-id test-id next-state "PASS" #f #f))
	      (else ;; 'fail
	       (launch:einf-rollup-status-set! exit-info 1) ;; (vector-set! exit-info 3 1) ;; force fail, this used to be next-state but that doesn't make sense. should always be "COMPLETED" 
	       (tests:test-set-status! run-id test-id "COMPLETED" "FAIL" (conc "Failed at step " stepname) #f)
	       )))
          logpro-used)
        (begin
          (debug:print-error 0 *default-log-port* "ezstep named "ezstep" does not exist for testid="test-id)
          #f))))

(define (ezsteps:run-from testdat start-step-name-in run-one #!key (rerun-logpro-only #f) )
  ;; TODO: honor rerun-logpro-only
  (if rerun-logpro-only
      (BB> "someday soon...")
  (let* ((test-run-dir  ;; (filedb:get-path *fdb* 
	  (db:test-get-rundir testdat)) ;; )
	 (testconfig    (read-config (conc test-run-dir "/testconfig") #f #t environ-patt: "pre-launch-env-vars"))
	 (ezstepslst    (hash-table-ref/default testconfig "ezsteps" '()))
         (start-step-name (or start-step-name-in (if (null? ezsteplst) #f (car ezsteplst))))
	 (run-mutex     (make-mutex))
	 (rollup-status 0)
	 (exit-info     (vector #t #t #t))
	 (test-id       (db:test-get-id testdat))
	 (run-id        (db:test-get-run_id testdat))
	 (test-name     (db:test-get-testname testdat))
	 (kill-job      #f)) ;; for future use (on re-factoring with launch.scm code

						 #f))
			((pass)
			 (tests:test-set-status! run-id test-id "RUNNING" "PASS" #f #f))
			(else ;; 'fail
			 (set! rollup-status 1) ;; force fail
			 (tests:test-set-status! run-id test-id "RUNNING" "FAIL" (conc "Failed at step " stepname) #f)
			 ))))
		  (if (and (ezsteps:steprun-good? logpro-used (vector-ref exit-info 2))
			   (not (null? tal)))
		      (if (not run-one) ;; if we got here we completed the step, if run-one is true, stop
			  (loop (car tal) (cdr tal) stepname runflag))))
		(debug:print 4 *default-log-port* "WARNING: a prior step failed, stopping at " ezstep)))
	  
	  ;; Once done with step/steps update the test record
	  ;;

		  (if (not (equal? item-path ""))
                      (rmt:set-state-status-and-roll-up-items run-id test-name item-path new-state new-status #f))))
	    ;; for automated creation of the rollup html file this is a good place...
	    (if (not (equal? item-path ""))
	      (tests:summarize-items run-id test-id test-name #f)) ;; don't force - just update if no
	    )))
    (pop-directory)
    rollup-status)))

(define (ezsteps:spawn-run-from testdat start-step-name run-one)
  (thread-start! 
   (make-thread
    (lambda ()
      (ezsteps:run-from testdat start-step-name run-one))
    (conc "ezstep run single step " start-step-name " run-one="run-one)))
  )

(import (prefix sqlite3 sqlite3:))

(declare (unit launch))
(declare (uses subrun))
(declare (uses common))
(declare (uses configf))
(declare (uses db))
(declare (uses ezsteps)) ;; why does this break things?
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")


















;; if handed a string, process it, else look for MT_CMDINFO
(define (launch:get-cmdinfo-assoc-list #!key (encoded-cmd #f))
  (let ((enccmd (if encoded-cmd encoded-cmd (getenv "MT_CMDINFO"))))
    (if enccmd
	(common:read-encoded-string enccmd)
	'())))

;;                       0           1              2              3


;; return (conc status ": " comment) from the final section so that
;;   the comment can be set in the step record in launch.scm
;;
(define (launch:load-logpro-dat run-id test-id stepname)
  (let ((cname (conc stepname ".dat")))
    (if (common:file-exists? cname)

	  ;;  )
	  (cond
	   ((equal? status "PASS") "PASS") ;; skip the message part if status is pass
	   (status (conc (configf:lookup dat "final" "exit-status") ": " (if msg msg "no message")))
	   (else #f)))
	#f)))
























;; monitors a test. check for kill signal, watch cpu load and disk free































































































































































































































































(define (launch:monitor-job run-id test-id item-path fullrunscript ezsteps test-name tconfigreg exit-info m work-area runtlim misc-flags)
  (let* ((update-period (string->number (or (configf:lookup *configdat* "setup" "test-stats-update-period") "30")))
         (start-seconds (current-seconds))
	 (calc-minutes  (lambda ()
			  (inexact->exact 
			   (round 
			    (- 

	      (if (hash-table-ref/default misc-flags 'keep-going #f)  ;; keep originals for cpu-load and disk-free unless they change more than the allowed delta
		  (loop (calc-minutes)
                        (or new-cpu-load cpu-load)
                        (or new-disk-free disk-free)
                        (if do-sync (current-seconds) last-sync)))))))
    (tests:update-central-meta-info run-id test-id (get-cpu-load) (get-df (current-directory))(calc-minutes) #f #f))) ;; NOTE: Checking twice for keep-going is intentional

;; rerun one step
;; rerun one step and subsequent steps
;; rerun logpro for each step (extracting from tconfig if source is there), inheriting env

(define (launch:execute encoded-cmd #!key (ezsteps-logpro-redo #f))
  (let* ((cmdinfo    (common:read-encoded-string encoded-cmd))
	 (tconfigreg #f))
    (setenv "MT_CMDINFO" encoded-cmd)
    ;;(bb-check-path msg: "launch:execute incoming")
    (if (list? cmdinfo) ;; ((testpath /tmp/mrwellan/jazzmind/src/example_run/tests/sqlitespeed)
	;; (test-name sqlitespeed) (runscript runscript.rb) (db-host localhost) (run-id 1))
	(let* ((testpath  (assoc/default 'testpath  cmdinfo))  ;; testpath is the test spec area

	  (set! *toppath* top-path)
          (change-directory *toppath*) ;; temporarily switch to the run area home
	  (setenv "MT_TEST_RUN_DIR"  work-area)

	  (launch:setup) ;; should be properly in the run area home now
          
	  (set! tconfigreg (tests:get-all)) ;; mapping of testname => test source path
          ;; TODO in 2.0: capture stack dump in execute to set incomplete like below does for signals
	  (let ((sighand (lambda (signum)
			   ;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting
			   (if (eq? signum signal/stop)
			       (debug:print-error 0 *default-log-port* "attempt to STOP process. Exiting."))
			   (set! *time-to-exit* #t)
			   (print "Received signal " signum ", cleaning up before exit. Please wait...")
			   (let ((th1 (make-thread (lambda ()

		 (exit-info    (make-launch:einf pid: #t exit-status: #t exit-code: #t rollup-status: 0)) ;; pid exit-status exit-code (i.e. process was successfully run) rollup-status
		 (job-thread   #f)
		 ;; (keep-going   #t)
		 (misc-flags   (let ((ht (make-hash-table)))
				 (hash-table-set! ht 'keep-going #t)
				 ht))
		 (runit        (lambda ()
				 (ezsteps:manage-steps run-id test-id item-path fullrunscript ezsteps subrun test-name tconfigreg exit-info m)))
		 (monitorjob   (lambda ()
				 (launch:monitor-job  run-id test-id item-path fullrunscript ezsteps test-name tconfigreg exit-info m work-area runtlim misc-flags)))
		 (th1          (make-thread monitorjob "monitor job"))
		 (th2          (make-thread runit "run job")))
	    (set! job-thread th2)
	    (thread-start! th1)
	    (thread-start! th2)

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

                            Optionally use :state and :status, use -keep-records to remove only
                            the run data.
  -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
  -redo-logpro            : do not rerun tests, but reapply logpro rules (ez-step flavor tests only; runs all tests unless -testpatt specified)
  -lock                   : lock run specified by target and runname
  -unlock                 : unlock run specified by target and runname
  -set-run-status status  : sets status for run to status, requires -target and -runname
  -get-run-status         : gets status for run specified by target and runname
  -run-wait               : wait on run specified by target and runname
  -preclean               : remove the existing test directory before running the test
  -clean-cache            : remove the cached megatest.config and runconfigs.config files

			"-itempatt"
			"-setlog"
			"-set-toplog"
			"-runstep"
			"-logpro"
			"-m"
			"-rerun"

			"-days"
			"-rename-run"
			"-to"
			;; values and messages
			":category"
			":variable"
			":value"

			"-get-run-status"

			;; queries
			"-test-paths" ;; get path(s) to a test, ordered by youngest first

			"-runall"    ;; run all tests, respects -testpatt, defaults to %
			"-run"       ;; alias for -runall
                        "-redo-logpro"
			"-remove-runs"
                        "-keep-records" ;; use with -remove-runs to remove only the run data
			"-rebuild-db"
			"-cleanup-db"
			"-rollup"
			"-update-meta"
			"-create-megatest-area"

					    (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? "-run" "-runall" "-remove-runs" "-set-state-status" "-redo-logpro")
    (debug:print 0 *default-log-port* (string-intersperse (argv) " ")))

;; some switches imply homehost. Exit here if not on homehost
;;
(let ((homehost-required  (list "-cleanup-db" "-server")))
  (if (apply args:any? homehost-required)
      (if (not (common:on-homehost?))

	  (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)
            (BB> "before runs:operate-on")
	    (runs:operate-on  action
			      target
			      (common:args-get-runname)  ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
			      (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
			      state: (common:args-get-state)
			      status: (common:args-get-status)
			      new-state-status: (args:get-arg "-set-state-status")

(if (args:get-arg "-set-state-status")
    (general-run-call 
     "-set-state-status"
     "set state and status"
     (lambda (target runname keys keyvals)
       (operate-on 'set-state-status))))

(when (args:get-arg "-redo-logpro")
    (BB> "redo-logpro request from command line detected")
    (general-run-call 
     "-redo-logpro"
     "rerun logpro in ezsteps"
     (lambda (target runname keys keyvals)
       (operate-on 'redo-logpro))))

(if (or (args:get-arg "-set-run-status")
	(args:get-arg "-get-run-status"))
    (general-run-call
     "-set-run-status"
     "set run status"
     (lambda (target runname keys keyvals)

          (for-each (lambda(table-row)
                      (print (string-join (map ->string table-row) ",")))

                    
                            table-rows))))
  (set! *didsomething* #t)
  (set! *time-to-exit* #t))





;; NOTE: list-runs and list-db-targets operate on local db!!!
;;
;; IDEA: megatest list -runname blah% ...
;;

;;  Copyright 2006-2018, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
;;

(declare (unit redo-logpro))
(declare (uses common))
(declare (uses rmt))
(declare (uses ezsteps))         
(include "common_records.scm")
(use matchable)
(use fmt)
(use ducttape-lib)
(define css "")

(define (redo-logpro:redo-logpro run-id test-id testdat)
  ;; TODO:    populate testdat from testid, start-step-name (from first step)
  ;; TODO:    (ezsteps:run-from testdat start-step-name #f rerun-logpro-only: #t))

  
  (BB> "redo-logpro:redo-logpro called with run-id="run-id" test-id="test-id" testdat="testdat)
  (ezsteps:run-from testdat #f #f rerun-logpro-only: #t)
  (print "redo-logpro Unimplemented")
  #f)

(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
(declare (uses tests))
(declare (uses server))
(declare (uses mt))
(declare (uses archive))
;;(declare (uses redo-logpro))
;; (declare (uses filedb))

(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")

;; action:
;;    'remove-runs
;;    'set-state-status
;;
;; NB// should pass in keys?
;;
(define (runs:operate-on action target runnamepatt testpatt #!key (state #f)(status #f)(new-state-status #f)(mode #f)(options '()))
  (BB> "in runs:operate-on with action >"action"<")
  (common:clear-caches) ;; clear all caches
  (let* ((db           #f)
	 ;; (tdbdat       (tasks:open-db))
	 (keys         (rmt:get-keys))
	 (rundat       (mt:get-runs-by-patt keys runnamepatt target))
	 (header       (vector-ref rundat 0))
	 (runs         (vector-ref rundat 1))
	 (states       (if state  (string-split state  ",") '()))
	 (statuses     (if status (string-split status ",") '()))
	 (state-status (if (string? new-state-status) (string-split new-state-status ",") '(#f #f)))
	 (rp-mutex     (make-mutex))
	 (bup-mutex    (make-mutex))
         (keep-records (args:get-arg "-keep-records"))) ;; used in conjunction with -remove-runs to keep the records, TODO: consolidate this with "mode".

    (let* ((write-access-actions '(remove-runs set-state-status archive run-wait redo-logpro))
           (dbfile             (conc  *toppath* "/megatest.db"))
           (readonly-mode      (not (file-write-access? dbfile))))
      (when (and readonly-mode
                 (member action write-access-actions))
        (debug:print-error 0 *default-log-port* "megatest.db is readonly.  Cannot proceed with action ["action"] in which write-access isrequired .")
        (exit 1)))
    

		    ;; (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10))
		    ;; seek and kill in flight -runtests with % as testpatt here
		    ;; (if (equal? testpatt "%")
		    (tasks:kill-runner target run-name testpatt)
		    
		    ;; (debug:print 0 *default-log-port* "not attempting to kill any run launcher processes as testpatt is " testpatt))
		    (debug:print 1 *default-log-port* "Removing tests for run: " runkey " " (db:get-value-by-header run header "runname")))
                   ((redo-logpro)
                    (BB> "redo-logpro operate-on hook 1")
                    (debug:print 1 *default-log-port* "Re-applying new logpro rules without rerun for tests for run: " runkey " " (db:get-value-by-header run header "runname")))
		   ((set-state-status)
		    ;; (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10))
		    (debug:print 1 *default-log-port* "Modifying state and staus for tests for run: " runkey " " (db:get-value-by-header run header "runname")))
		   ((print-run)
		    (debug:print 1 *default-log-port* "Printing info for run " runkey ", run=" run ", tests=" tests ", header=" header)
		    action)
		   ((run-wait)

                                  (has-subrun    (and (subrun:subrun-test-initialized? run-dir)
                                                      (not (subrun:subrun-removed? run-dir))))
				  (test-state    (db:test-get-state new-test-dat))
				  (test-fulln    (db:test-get-fullname new-test-dat))
				  (uname         (db:test-get-uname    new-test-dat))
				  (toplevel-with-children (and (db:test-get-is-toplevel test)
							       (> (rmt:test-toplevel-num-items run-id test-name) 0))))
                             (BB> "arrived here 2")
			     (case action
			       ((remove-runs)
				;; if the test is a toplevel-with-children issue an error and do not remove
				(cond
                                 (toplevel-with-children
                                  (debug:print 0 *default-log-port* "WARNING: skipping removal of " test-fulln " with run-id " run-id " as it has sub tests")
                                  (hash-table-set! toplevel-retries test-fulln (+ (hash-table-ref/default toplevel-retries test-fulln 0) 1))

						(loop (car tal)(cdr tal))))))
				       )
				      ) ; end case rem-status
                                    ) ; end let
                                  ); end cond has-subrun

                                 (else
                                  (BB> "arrived 1")
                                  ;; BB - TODO - consider backgrounding to threads to delete tests (work below) 
                                  (debug:print-info 0 *default-log-port* "test: " test-name " itest-state: " test-state)
                                  (if (member test-state (list "RUNNING" "LAUNCHED" "REMOTEHOSTSTART" "KILLREQ"))
                                      (begin
                                        (if (not (hash-table-ref/default test-retry-time test-fulln #f))
                                            (begin
                                              ;; want to set to REMOVING BUT CANNOT do it here?

                                            (loop new-test-dat tal)
                                            (loop (car tal)(append tal (list new-test-dat)))))
                                      (begin
                                        (runs:remove-test-directory new-test-dat mode) ;; 'remove-all)
                                        (if (not (null? tal))
                                            (loop (car tal)(cdr tal)))))))
				(rmt:update-run-stats run-id (rmt:get-raw-run-stats run-id)))
                               ((redo-logpro)
                                (BB> "redo-logpro operate-on hook 2")
                                (redo-logpro:redo-logpro run-id test-id new-test-dat)
                                (debug:print-error 0 "redo-logpro unimplemented")
                                (if (not (null? tal))
				    (loop (car tal)(cdr tal)))
                                )
			       ((set-state-status)
                                (let* ((new-state (car state-status))
                                       (new-status (cadr state-status))
                                       (test-id (db:test-get-id test))
                                       (test-run-dir (db:test-get-rundir new-test-dat))
                                       (has-subrun (and (subrun:subrun-test-initialized? test-run-dir)
                                                      (not (subrun:subrun-removed? test-run-dir)))))