;; Copyright 2006-2017, 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/>.
;;

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

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

(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 tcp tcp-server pathname-expand s11n)

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

(require-library mutils)

;; (use zmq)

(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 tdb))
(declare (uses mt))
(declare (uses api))
(declare (uses tasks)) ;; only used for debugging.
(declare (uses env))
(declare (uses diff-report))
(declare (uses ftail))
(import ftail)

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

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

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

;; usage logging, careful with this, it is not designed to deal with all real world challenges!
;;
(if (and *usage-log-file*
         (file-write-access? *usage-log-file*))
    (with-output-to-file
        *usage-log-file*
      (lambda ()
        (print
         (if *usage-use-seconds*
             (current-seconds)
             (time->string
              (seconds->local-time (current-seconds))
              "%Yww%V.%w %H:%M:%S"))
         " "
         (current-user-name) " "
         (current-directory) " "
         "\"" (string-intersperse (argv) " ") "\""))
      #:append))

;; Disabled help items
;;  -rollup                 : (currently disabled) fill run (set by :runname)  with latest test(s)
;;                            from prior runs with same keys
;;  -daemonize              : fork into background and disconnect from stdin/out

(define help (conc "
Megatest, documentation at http://www.kiatoa.com/fossils/megatest
  version " megatest-version "
  license GPL, Copyright Matt Welland 2006-2017
 
Usage: megatest [options]
  -h                      : this help
  -manual                 : show the Megatest user manual
  -version                : print megatest version (currently " megatest-version ")

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.
  -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
  -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
  -no-cache               : do not use the cached config files. 
  -one-pass               : launch as many tests as you can but do not wait for more to be ready
  -remove-keep N          : remove all but N most recent runs per target; use '-actions, -age, -precmd'
  -age <age>              : 120d,3h,20m to apply only to runs older than the 
                                 specified age. NB// M=month, m=minute
  -actions <action>       : print,remove-runs,archive to specify action to take
  -precmd                 : insert a wrapper command in front of the commands run

Selectors (e.g. use for -runtests, -remove-runs, -set-state-status, -list-runs etc.)
  -target key1/key2/...   : run for key1, key2, etc.
  -reqtarg key1/key2/...  : run for key1, key2, etc. but key1/key2 must be in runconfigs
  -testpatt patt1/patt2,patt3/...  : % is wildcard
  -runname                : required, name for this particular test run
  -state                  : Applies to runs, tests or steps depending on context
  -status                 : Applies to runs, tests or steps depending on context
  -modepatt key           : load testpatt from <key> in runconfigs instead of default TESTPATT if -testpatt and -tagexpr are not specified
  -tagexpr tag1,tag2%,..  : select tests with tags matching expression
  

Test helpers (for use inside tests)
  -step stepname
  -test-status            : set the state and status of a test (use :state and :status)
  -setlog logfname        : set the path/filename to the final log relative to the test
                            directory. may be used with -test-status
  -set-toplog logfname    : set the overall log for a suite of sub-tests
  -summarize-items        : for an itemized test create a summary html 
  -m comment              : insert a comment for this test

Test data capture
  -set-values             : update or set values in the testdata table
  :category               : set the category field (optional)
  :variable               : set the variable name (optional)
  :value                  : value measured (required)
  :expected               : value expected (required)
  :tol                    : |value-expect| <= tol (required, can be <, >, >=, <= or number)
  :units                  : name of the units for value, expected_value etc. (optional)
  -load-test-data         : read test specific data for storage in the test_data table
                            from standard in. Each line is comma delimited with four
                            fields category,variable,value,comment

Queries
  -list-runs patt         : list runs matching pattern \"patt\", % is the wildcard
  -show-keys              : show the keys used in this megatest setup
  -test-files targpatt    : get the most recent test path/file matching targpatt e.g. %/% or '*.log'
                            returns list sorted by age ascending, see examples below
  -test-paths             : get the test paths matching target, runname, item and test
                            patterns.
  -list-disks             : list the disks available for storing runs
  -list-targets           : list the targets in runconfigs.config
  -list-db-targets        : list the target combinations used in the db
  -show-config            : dump the internal representation of the megatest.config file
  -show-runconfig         : dump the internal representation of the runconfigs.config file
  -dumpmode MODE          : dump in MODE format instead of sexpr, MODE=json,ini,sexp etc. (add -debug 0,9 to see which file contributes each line)
  -show-cmdinfo           : dump the command info for a test (run in test environment)
  -section sectionName
  -var varName            : for config and runconfig lookup value for sectionName varName
  -since N                : get list of runs changed since time N (Unix seconds)
  -fields fieldspec       : fields to include in json dump; runs:id,runame+tests:testname+steps
  -sort fieldname         : in -list-runs sort tests by this field
  -testdata-csv [categorypatt/]varpatt  : dump testdata for given category

Misc 
  -start-dir path         : switch to this directory before running megatest
  -contour cname          : add a level of hierarcy to the linktree and run paths
  -area-tag tagname       : add a tag to an area while syncking to pgdb
  -rebuild-db             : bring the database schema up to date
  -cleanup-db             : remove any orphan records, vacuum the db
  -import-megatest.db     : push data from megatest.db to cache db files in /tmp/$USER
  -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
  -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
  -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 ...
  -config fname           : override the megatest.config file with fname
  -append-config fname    : append fname to the megatest.config file

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
                            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
  -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>

  		


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) " ") "
Version " megatest-version ", built from " megatest-fossil-hash ))

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

;; process args
(define remargs (args:get-args 
		 (argv)
		 (list  "-runtests"  ;; run a specific test
			"-config"    ;; override the config file name
			"-append-config"
			"-execute"   ;; run the command encoded in the base64 parameter
			"-step"
			"-target"
			"-reqtarg"
			":runname"
			"-runname"
			":state"  
			"-state"
			":status"
			"-status"
			"-list-runs"
                        "-testdata-csv"
			"-testpatt"
                        "--modepatt"
                        "-modepatt"
                        "-tagexpr"
			"-itempatt"
			"-setlog"
			"-set-toplog"
			"-runstep"
			"-logpro"
			"-m"
			"-rerun"
			"-days"
			"-rename-run"
			"-to"
			;; values and messages
			":category"
			":variable"
			":value"
			":expected"
			":tol"
			":units"
			;; misc
			"-start-dir"
                        "-run-patt"
                        "-target-patt"   
			"-contour"
                        "-area-tag"  
			"-server"
			"-transport"
			"-port"
			"-extract-ods"
			"-pathmod"
			"-env2file"
			"-envcap"
			"-envdelta"
			"-setvars"
			"-set-state-status"

                        ;; move runs stuff here
                        "-remove-keep"           
			"-set-run-status"
			"-age"
			"-archive"
			"-actions"
			"-precmd"
			
			"-debug" ;; for *verbosity* > 2
			"-create-test"
			"-override-timeout"
			"-test-files"  ;; -test-paths is for listing all
			"-load"        ;; load and exectute a scheme file
			"-section"
			"-var"
			"-dumpmode"
			"-run-id"
			"-ping"
			"-refdb2dat"
			"-o"
			"-log"
			"-since"
			"-fields"
			"-recover-test" ;; run-id,test-id - used internally to recover a test stuck in RUNNING state
			"-sort"
			"-target-db"
			"-source-db"
			"-prefix-target"

                        "-src-target"
                        "-src-runname"
                        "-diff-email"
			"-sync-to"			
			"-pgsync"
                        "-diff-html"
			)
 		 (list  "-h" "-help" "--help"
			"-manual"
			"-version"
		        "-force"
		        "-xterm"
		        "-showkeys"
		        "-show-keys"
		        "-test-status"
			"-set-values"
			"-load-test-data"
			"-summarize-items"
		        "-gui"
			"-daemonize"
			"-preclean"
			"-rerun-clean"
			"-rerun-all"
			"-clean-cache"
			"-no-cache"
			"-cache-db"
                        "-use-db-cache"
                        "-prepend-contour"
			;; misc
			"-repl"
			"-lock"
			"-unlock"
			"-list-servers"
			"-kill-servers"
                        "-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"
			;; misc queries
			"-list-disks"
			"-list-targets"
			"-list-db-targets"
			"-show-runconfig"
			"-show-config"
			"-show-cmdinfo"
			"-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
			"-remove-runs"
                        "-keep-records" ;; use with -remove-runs to remove only the run data
			"-rebuild-db"
			"-cleanup-db"
			"-rollup"
			"-update-meta"
			"-create-megatest-area"
			"-mark-incompletes"

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

                        "-diff-rep"
                        )
		 args:arg-hash
		 0))

;; Add args that use remargs here
;;
(if (and (not (null? remargs))
	 (not (or
	       (args:get-arg "-runstep")
	       (args:get-arg "-envcap")
	       (args:get-arg "-envdelta")
	       )
	      ))
    (debug:print-error 0 *default-log-port* "Unrecognised arguments: " (string-intersperse (if (list? remargs) remargs (argv))  " ")))

;; before doing anything else change to the start-dir if provided
;;

;; bracket open-output-file with code to make leading directory if it does not exist and handle exceptions
(define (open-logfile logpath)
  (condition-case
   (let* ((log-dir (or (pathname-directory logpath) ".")))
     (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))))

(define (is-port-in-use port-num)
 (let* ((ret #f))
     (let-values (((inp oup pid)
                (process "netstat" (list  "-tulpn" ))))
      (let loop ((inl (read-line inp)))
        (if (not (eof-object? inl))
            (begin
                (if (string-search (regexp (conc ":" port-num)) inl)
                 (begin
                 ;(print "Output: "  inl)
                  (set! ret  #t))
                 (loop (read-line inp)))))))
ret))

(define (start-nn-server portnum )
  (let ((rep (nn-socket 'rep)))
    (handle-exceptions
     exn
     (let ((emsg ((condition-property-accessor 'exn 'message) exn)))
       (print "ERROR: Failed to start server \"" emsg "\"")
       (exit 1))

     (nn-bind rep (conc "tcp://*:" portnum)))
    rep))

(define (get-free-port port-num)
  (let loop ((cur-port port-num))
    (if (not (is-port-in-use cur-port))
      cur-port
      (loop (+ 1 cur-port))
    )
  )  
)

(print "PORT: " (get-free-port 9000))

(defstruct host-load stamp cores cpuload adj-cpu-load load-alist) 
(define *host-loads* (make-hash-table))
;;(let ((p (make-host-load stamp: 1 cores: 4 cpuload: 42 adj-cpu-load: 42)))
;;  (hash-table-set! *host-loads* "plxcas102" p)
;;)
(if (args:get-arg "-server")
    ;;(repl)
    (handle-exceptions
        exn
        (print "ERROR-New: " ((condition-property-accessor 'exn 'message) exn))
	(let ((port (get-free-port 9000))
          (host (get-host-name)))
      (with-output-to-file (pathname-expand "~/.megatest/tquery")
        (lambda() (print host ":" port))
      )
      (print "Starting Nanomsg port - New - " port)
	  ((make-tcp-server (tcp-listen port) (lambda()
	    (let ((instr (read-line))) 
                  (write-line (conc "Instr: " instr) (current-error-port))
                  (case (string->symbol (car (string-split instr ":")))
                  ((cpuload)
                    (if (hash-table-ref/default *host-loads* (cadr (string-split instr ":")) #f)
                        (begin 
			                   (write-line "Found it in hash!" (current-error-port))
                               (let ((inl (number->string (host-load-cpuload (hash-table-ref/default *host-loads* (cadr (string-split instr ":")) #f)))))
                                 (write-line (conc "Sending Cached Value: " inl) ( current-error-port))
                                 (print inl)
                               )
                        )
                        (begin (hash-table-set! *host-loads* (cadr (string-split instr ":")) (make-host-load stamp: (current-seconds) cores: 4 cpuload: (car (common:get-cpu-load-original (cadr (string-split instr ":")))) adj-cpu-load: 11 load-alist: (common:get-normalized-cpu-load-original (cadr (string-split instr ":")))))
                               (let ((inl (number->string (host-load-cpuload (hash-table-ref/default *host-loads* (cadr (string-split instr ":")) #f)))))
                                 (write-line (conc "Sending Fresh Value: " inl) (current-error-port))
                                 (print inl)
                               )
                               ;;(print (host-load-cpuload (hash-table-ref/default *host-loads* (cadr (string-split instr ":")) #f)))
                               ;;(nn-send rep (host-load-cpuload (hash-table-ref/default *host-loads* (cadr (string-split instr ":")) #f)))
                        )
                    )
                  )
                  ((adj-cpuload)
                    (if (hash-table-ref/default *host-loads* (cadr (string-split instr ":")) #f)
                        (begin 
			               (write-line "Found it in hash!" (current-error-port))
                           (let ((inl (number->string (alist-ref 'adj-proc-load (host-load-load-alist (hash-table-ref/default *host-loads* (cadr (string-split instr ":")) #f))))))
                             (write-line (conc "Sending Cached Value: " inl) (current-error-port))
                             (print inl)
                           )
                        )
                        (begin (hash-table-set! *host-loads* (cadr (string-split instr ":")) (make-host-load stamp: (current-seconds) cores: 4 cpuload: (car (common:get-cpu-load-original (cadr (string-split instr ":")))) adj-cpu-load: 11 load-alist: (common:get-normalized-cpu-load-original (cadr (string-split instr ":")))))
                               (let ((inl (number->string (alist-ref 'adj-proc-load (host-load-load-alist (hash-table-ref/default *host-loads* (cadr (string-split instr ":")) #f))))))
                                 (write-line (conc "Sending Fresh Value: " inl) (current-error-port))
                                 (print inl)
				 (write-line inl (current-error-port))
                               )
                               ;;(print (host-load-cpuload (hash-table-ref/default *host-loads* (cadr (string-split instr ":")) #f)))
                               ;;(nn-send rep (host-load-cpuload (hash-table-ref/default *host-loads* (cadr (string-split instr ":")) #f)))
                        )))
                  ((adj-cpuload-full)
                    (if (hash-table-ref/default *host-loads* (cadr (string-split instr ":")) #f)
                        (begin 
			               (write-line "Found it in hash!" (current-error-port))
                           (let ((inl (host-load-load-alist (hash-table-ref/default *host-loads* (cadr (string-split instr ":")) #f))))
                             (write-line (conc "Sending Cached Value: " inl) (current-error-port))
                             (print inl)
                           )
                        )
                        (begin (hash-table-set! *host-loads* (cadr (string-split instr ":")) (make-host-load stamp: (current-seconds) cores: 4 cpuload: (car (common:get-cpu-load-original (cadr (string-split instr ":")))) adj-cpu-load: 11 load-alist: (with-output-to-string (lambda() (write (common:get-normalized-cpu-load-original (cadr (string-split instr ":"))))))))
			                   (write-line "Not in hash!" (current-error-port))
                               (let ((inl (host-load-load-alist (hash-table-ref/default *host-loads* (cadr (string-split instr ":")) #f))))
                                 (write-line (conc "Sending Fresh Value: " inl) (current-error-port))
                                 ;;(print (with-output-to-string (lambda() (write inl))))
                                 (print inl)
				                 (write-line inl (current-error-port))
                               )
                 )))
                  ((bob)
		            (print (alist-ref 'adj-proc-load (host-load-cpuload (hash-table-ref/default *host-loads* "plxcm5005" #f))))
                  )
                  ((whoami)
                    (print "tquery")
                  )
                   )
                   (for-each (lambda(l)
                        (if (> (current-seconds) (+ (host-load-stamp (hash-table-ref/default *host-loads* l #f)) 30))
                          (begin 
                         ;;   (print "Expired!") 
                          (hash-table-delete! *host-loads* l) )
                        )
                        ;;(print l (host-load-stamp (hash-table-ref/default *host-loads* l #f)))
                      )
                    (hash-table-keys *host-loads*)
                   )
          ))))
  	  )
	))

(if (or (args:get-arg "-h")
	(args:get-arg "-help")
	(args:get-arg "--help"))
    (begin
      (print help)
      (exit)))

(if (args:get-arg "-version")
    (begin
      (print (common:version-signature)) ;; (print megatest-version)
      (exit)))

