Megatest

ARCHSTR=$(shell if [[ -e /usr/bin/sw_vers ]]; then /usr/bin/sw_vers -productVersion; else lsb_release -sr; fi)
# ARCHSTR=$(shell bash -c "echo \$$MACHTYPE")

PNGFILES = $(shell cd docs/manual;ls *png)

mtest: megatest.scm $(MOFILES) megatest-fossil-hash.scm
	csc $(CSCOPTS) $(MOFILES) megatest.scm -o mtest

mtserve: mtserve.scm $(MOFILES) megatest-fossil-hash.scm
	csc $(CSCOPTS) $(MOFILES) mtserve.scm -o mtserve

#  $(MOIMPFILES) removed

showmtesthash:
	@echo $(MTESTHASH)

dboard : dashboard.scm $(MOFILES) $(GMOFILES) megatest-fossil-hash.scm

                (null? toplevels))
           #f
           #t)))))

(define (db:get-status-from-final-status-file run-dir)
  (let ((infile (conc run-dir "/.final-status")))
    ;; first verify we are able to write the output file
    (if (and (file-exists? infile)
	     (not (file-readable? infile)))
        (begin 
	  (debug:print 0 *default-log-port* "ERROR: cannot read " infile)
          (debug:print 0 *default-log-port* "ERROR: run-dir is " run-dir)
          #f)

        (with-input-from-file infile read-lines))))


;;  select end_time-now from
;;      (select testname,item_path,event_time+run_duration as
;;                          end_time,strftime('%s','now') as now from tests where state in
;;      ('RUNNING','REMOTEHOSTSTART','LAUNCHED'));

(define (db:find-and-mark-incomplete dbstruct run-id ovr-deadtime)

;; 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/>.
;;

;; (declare (uses dbi))
(declare (uses pkts))
;; (declare (uses stml2))
;; (declare (uses cookie))
;; (declare (uses csv-xml))
;; (declare (uses hostinfo))

(declare (uses adjutant))
;; (declare (uses archivemod))
(declare (uses apimod))
;; (declare (uses autoload))
;; (declare (uses bigmod))
(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses dbmod))
(declare (uses debugprint))
;; (declare (uses ducttape-lib))
;; (declare (uses ezstepsmod))
(declare (uses launchmod))
(declare (uses mtargs))
(declare (uses mtver))
;; (declare (uses mutils))
(declare (uses processmod))
(declare (uses rmtmod))
;; (declare (uses runsmod))
;; (declare (uses servermod))
;; (declare (uses testsmod))
(declare (uses dbmgrmod))

;; needed for configf scripts, scheme etc.
;; (declare (uses apimod.import))
;; (declare (uses debugprint.import))
;; (declare (uses mtargs.import))
;; (declare (uses commonmod.import))
;; (declare (uses configfmod.import))
;; (declare (uses bigmod.import))
;; (declare (uses dbmod.import))
;; (declare (uses rmtmod.import))
;; (declare (uses servermod.import))
;; (declare (uses launchmod.import))

;; (include "call-with-environment-variables/call-with-environment-variables.scm")

(module mtserve
	*

  (import scheme

;;	  chicken.base
;;	  chicken.bitwise
;;	  chicken.condition
;;	  ;; chicken.csi
;;	  chicken.eval
;;	  chicken.file
;;	  chicken.file.posix
;;	  chicken.format
;;	  chicken.io
;;	  chicken.irregex
;;	  chicken.pathname
;;	  chicken.port
;;	  chicken.pretty-print
;;	  chicken.process
;;	  chicken.process-context
;;	  chicken.process-context.posix
;;	  chicken.process.signal
;;	  chicken.random
;;	  chicken.repl
;;	  chicken.sort
;;	  chicken.string
;;	  chicken.tcp
;;	  chicken.time
;;	  chicken.time.posix
;;	  
;;	  (prefix base64 base64:)
;;	  (prefix sqlite3 sqlite3:)
;;	  (prefix sxml-modifications sxml-)
;;	  address-info
;;	  csv-abnf
;;	  directory-utils
;;	  fmt
;;	  format
;;	  http-client
;;	  intarweb
;;	  json
;;	  linenoise
;;	  matchable
;;	  md5
;;	  message-digest
;;	  queues
;;	  regex
;;	  regex-case
;;	  s11n
;;	  sparse-vectors
;;	  spiffy
;;	  spiffy-directory-listing
;;	  spiffy-request-vars
;;	  sql-de-lite
;;	  stack
;;	  sxml-modifications
;;	  sxml-serializer
;;	  sxml-transforms
;;	  system-information
;;	  typed-records
;;	  uri-common
;;	  z3
;;	  
;;	  srfi-1
;;	  srfi-4
;;	  srfi-18
;;	  srfi-13
;;	  srfi-98
;;	  srfi-69
;;
;;	  ;; local modules
;;	  autoload
;;	  adjutant
;;	  csv-xml
;;	  ;; hostinfo
;;	  mtver
;;	  mutils
;;	  cookie
;;	  csv-xml
;;	  ducttape-lib
;;	  (prefix mtargs args:)
;;	  pkts
;;	  stml2
;;	  (prefix dbi dbi:)
;;
;;	  apimod
;;	  archivemod
;;	  bigmod
;;	  commonmod
;;	  configfmod
;;	  dbmod
;;	  debugprint
;;	  ezstepsmod
;;	  launchmod
;;	  processmod
;;	  rmtmod
;;	  runsmod
;;	  servermod
;;	  tasksmod
;;	  testsmod
;;	  dbmgrmod
;;	  
;;	  ulex
	  )

;;   ;; ulex parameters
;;   (work-method 'direct)
;;   (return-method 'direct)
  
  ;; ulex parameters
  ;; (work-method   'mailbox)
  ;; (return-method 'mailbox)

;; (my-with-lock common:with-simple-file-lock)
;;   
;; ;; fake out readline usage of toplevel-command
;; (define (toplevel-command . a) #f)
;; (define *didsomething* #f)  
;; (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 "test_records.scm")
;; 
;; ;; (include "common.scm")
;; (include "db.scm")
;; ;; (include "server.scm")
;; (include "tests.scm")
;; (include "genexample.scm")
;; (include "tdb.scm")
;; (include "env.scm")
;; (include "diff-report.scm")
;; (include "ods.scm")
;; 

  (define (main)
    (let ((tl        (launch:setup))
 	  (dbname    (args:get-arg "-db"))) 
      (rmt:server-launch dbname)
      #;(set! *didsomething* #t)))

  
(thread-join!
 (thread-start!
  (make-thread main)))

)

;; (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
;; 
;; ;;======================================================================
;; ;; Test commands (i.e. for use inside tests)
;; ;;======================================================================
;; 
;; (define (megatest:step step state status logfile msg)
;;   (if (not (get-environment-variable "MT_CMDINFO"))
;;       (begin
;;      	(debug:print-error 0 *default-log-port* "MT_CMDINFO env var not set, -step must be called *inside* a megatest invoked environment!")
;;      	(exit 5))
;;       (let* ((cmdinfo   (common:read-encoded-string (get-environment-variable "MT_CMDINFO")))
;;      	     (transport (assoc/default 'transport cmdinfo))
;;      	     (testpath  (assoc/default 'testpath  cmdinfo))
;;      	     (test-name (assoc/default 'test-name cmdinfo))
;;      	     (runscript (assoc/default 'runscript cmdinfo))
;;      	     (db-host   (assoc/default 'db-host   cmdinfo))
;;      	     (run-id    (assoc/default 'run-id    cmdinfo))
;;      	     (test-id   (assoc/default 'test-id   cmdinfo))
;;      	     (itemdat   (assoc/default 'itemdat   cmdinfo))
;;      	     (work-area (assoc/default 'work-area cmdinfo))
;;      	     (db        #f))
;;      	(change-directory testpath)
;;      	(if (not (launch:setup))
;;      	    (begin
;;      	      (debug:print 0 *default-log-port* "Failed to setup, exiting")
;;      	      (exit 1)))
;;      	(if (and state status)
;;      	    (let ((comment (launch:load-logpro-dat run-id test-id step)))
;;      	      ;; (rmt:test-set-log! run-id test-id (conc stepname ".html"))))
;;      	      (rmt:teststep-set-status! run-id test-id step state status (or comment msg) logfile))
;;      	    (begin
;;      	      (debug:print-error 0 *default-log-port* "You must specify :state and :status with every call to -step")
;;      	      (exit 6))))))
;; 
;; ;;======================================================================
;; ;; full run
;; ;;======================================================================
;; 
;; (define (handle-run-requests target runname keys keyvals need-clean)	 
;;   (if (or (args:get-arg "-kill-rerun") (args:get-arg "-rerun-clean")) ;; first set states/statuses correct
;;       ;; For rerun-clean do we or do we not support the testpatt?
;;       (let ((states   (or (configf:lookup *configdat* "validvalues" "cleanrerun-states")
;;      			  "KILLREQ,KILLED,UNKNOWN,INCOMPLETE,STUCK,NOT_STARTED"))
;;      	    (statuses (or (configf:lookup *configdat* "validvalues" "cleanrerun-statuses")
;;      			  "FAIL,INCOMPLETE,ABORT,CHECK,DEAD,PREQ_FAIL,PREQ_DISCARDED")))
;;      	(hash-table-set! args:arg-hash "-preclean" #t)
;;      	(runs:operate-on 'set-state-status
;;      			 target
;;      			 (common:args-get-runname)  ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
;;      			 ;; "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
;;      			 (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
;;      			 state:  states
;;      			 ;; status: statuses
;;      			 new-state-status: "NOT_STARTED,n/a")
;;      	(runs:clean-cache target runname *toppath*)
;;      	(runs:operate-on 'set-state-status
;;      			 target
;;      			 (common:args-get-runname)  ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
;;      			 ;; "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
;;      			 (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
;;      			 ;; state:  states
;;      			 status: statuses
;;      			 new-state-status: "NOT_STARTED,n/a")))
;;   ;; RERUN ALL
;;   (if (args:get-arg "-rerun-all") ;; first set states/statuses correct
;;       (let* ((rconfig (full-runconfigs-read)))
;;      	(hash-table-set! args:arg-hash "-preclean" #t)
;;      	(runs:operate-on 'set-state-status
;;      			 target
;;      			 (common:args-get-runname)  ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
;;      			 (common:args-get-testpatt rconfig) ;; (args:get-arg "-testpatt")
;;      			 state:  #f
;;      			 ;; status: statuses
;;      			 new-state-status: "NOT_STARTED,n/a")
;;      	(runs:clean-cache target runname *toppath*)
;;      	(runs:operate-on 'set-state-status
;;      			 target
;;      			 (common:args-get-runname)  ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
;;      			 (common:args-get-testpatt rconfig) ;; (args:get-arg "-testpatt")
;;      			 ;; state:  states
;;      			 status: #f
;;      			 new-state-status: "NOT_STARTED,n/a")))
;;   (let* ((config-reruns      (let ((x (configf:lookup *configdat* "setup" "reruns")))
;;      			       (if x (string->number x) #f)))
;;      	 (rerun-cnt (if config-reruns
;;      			config-reruns
;;      			1)))
;;     
;;     (runs:run-tests target
;;      		    runname
;;      		    #f ;; (common:args-get-testpatt #f)
;;      		    ;; (or (args:get-arg "-testpatt")
;;      		    ;;     "%")
;;      		    (bdat-user *bdat*)
;;      		    args:arg-hash
;;      		    run-count: rerun-cnt)))
;; 
;; ;; csv processing record
;; (define (make-refdb:csv)
;;   (vector 
;;    (make-sparse-array)
;;    (make-hash-table)
;;    (make-hash-table)
;;    0
;;    0))
;; (define-inline (refdb:csv-get-svec     vec)    (vector-ref  vec 0))
;; (define-inline (refdb:csv-get-rows     vec)    (vector-ref  vec 1))
;; (define-inline (refdb:csv-get-cols     vec)    (vector-ref  vec 2))
;; (define-inline (refdb:csv-get-maxrow   vec)    (vector-ref  vec 3))
;; (define-inline (refdb:csv-get-maxcol   vec)    (vector-ref  vec 4))
;; (define-inline (refdb:csv-set-svec!    vec val)(vector-set! vec 0 val))
;; (define-inline (refdb:csv-set-rows!    vec val)(vector-set! vec 1 val))
;; (define-inline (refdb:csv-set-cols!    vec val)(vector-set! vec 2 val))
;; (define-inline (refdb:csv-set-maxrow!  vec val)(vector-set! vec 3 val))
;; (define-inline (refdb:csv-set-maxcol!  vec val)(vector-set! vec 4 val))
;; 
;; (define (get-dat results sheetname)
;;   (or (hash-table-ref/default results sheetname #f)
;;       (let ((tmp-vec  (make-refdb:csv)))
;;      	(hash-table-set! results sheetname tmp-vec)
;;      	tmp-vec)))
;; 
;; ;; bracket open-output-file with code to make leading directory if it does not exist and handle exceptions
;; (define (open-logfile logpath-in)
;;   (condition-case
;;    (let* ((log-dir (or (pathname-directory logpath-in) "."))
;;      	  (fname   (pathname-strip-directory logpath-in))
;;      	  (logpath (if (> (string-length fname) 250)
;;      		       (let ((newlogf (conc log-dir "/" (common:get-signature fname) ".log")))
;;      			 (debug:print 0 *default-log-port* "WARNING: log file " logpath-in " path too long, converted to " newlogf)
;;      			 newlogf)
;;      		       logpath-in)))
;;      (if (not (directory-exists? log-dir))
;; 	 (system (conc "mkdir -p " log-dir)))
;;      (open-output-file logpath))
;;    (exn ()
;; 	(debug:print-error 0 *default-log-port* "Could not open log file for write: "logpath-in)
;; 	(set! *didsomething* #t)
;; 	(exit 1))))
;; 
;; ;; 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. Use -kill-wait to override the 10 second
;;                             per test wait after kill delay (e.g. -kill-wait 0). 
;;   -kill-runs              : kill existing run(s) (all incomplete tests killed)
;;   -kill-rerun             : kill an existing run (all incomplete tests killed and run is rerun)
;;   -set-state-status X,Y   : set state to X and status to Y, requires controls per -remove-runs
;;   -rerun FAIL,WARN...     : force re-run for tests with specificed status(s)
;;   -rerun-clean            : set all tests not COMPLETED+PASS,WARN,WAIVED to NOT_STARTED,n/a
;;                             and then run the specified testpatt with -preclean
;;   -rerun-all              : set all tests to NOT_STARTED,n/a and run with -preclean
;;   -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>[,...] : actions to take; print,remove-runs,archive,kill-runs
;;   -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 syncing to pgdb
;;   -run-tag tagname        : add a tag to a run while syncing 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
;;   -adjutant C,M           : start the server/adjutant with allocated cores C and Mem M (Gig), 
;;                             use 0,0 to auto use full machine
;;   -transport http|rpc     : use http or rpc for transport (default is http) 
;;   -log logfile            : send stdout and stderr to logfile
;;   -autolog logfilebase    : appends pid and host to logfilebase for 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 ...
;;   -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
;; 
;; 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, get, replicate-db (use 
;;                             -dest to set destination), -include path1,path2... to get or save specific files
;;   -generate-html          : create a simple html dashboard for browsing your runs
;;   -generate-html-structure  : create a top level html veiw to list targets/runs and a Run view within each run directory.  
;;   -list-run-time          : list time requered to complete runs. It supports following switches
;;                             -run-patt <patt> -target-patt <patt> -dumpmode <csv,json,plain-text>
;;   -list-test-time	  : list time requered to complete each test in a run. It following following arguments
;;                             -runname <patt> -target <patt> -dumpmode <csv,json,plain-text>
;;   -syscheck               : do some very basic checks; write access and space in tmp, home, runs, links and 
;;                             is $DISPLAY valid 
;;   -list-waivers           : dump waivers for specified target, runname, testpatt to stdout
;; 
;; 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 ))
;;      
;; (define (main)
;;   (make-and-init-bigdata)
;; 
;; ;; 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-writable? *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))
;; 
;;      ;;  -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"
;;      			"-dest"
;; 			"-source" 
;; 			"-time-stamp" 
;;      			;; values and messages
;;      			":category"
;;      			":variable"
;;      			":value"
;;      			":expected"
;;      			":tol"
;;      			":units"
;;      
;;      			;; misc
;;      			"-start-dir"
;; 			"-run-patt"
;; 			"-target-patt"   
;;      			"-contour"
;; 			"-area-tag"  
;; 			"-area"  
;;      			"-run-tag"
;;      			"-server"
;; 			"-db"            ;; file name for setting up a server
;;      			"-adjutant"
;;      			"-transport"
;;      			"-port"
;;      			"-extract-ods"
;;      			"-pathmod"
;;      			"-env2file"
;;      			"-envcap"
;;      			"-envdelta"
;;      			"-setvars"
;;      			"-set-state-status"
;; 			
;; 			;; move runs stuff here
;; 			"-remove-keep"           
;;      			"-set-run-status"
;;      			"-age"
;;      
;;      			;; archive 
;;      			"-archive"
;;      			"-actions"
;;      			"-precmd"
;;      			"-include"
;;      			"-exclude-rx"
;;      			"-exclude-rx-from"
;;      			
;;      			"-debug" ;; for *verbosity* > 2
;;      			"-debug-noprop"
;;      			"-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"
;; 			"-autolog"
;; 			"-sync-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"
;;      			"-kill-wait"    ;; wait this long before removing test (default is 10 sec)
;; 			"-diff-html"
;;      
;;      			;; wizards, area capture, setup new ...
;;      			"-extract-skeleton"
;;      			)
;;       		 (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"
;;      			"-cp-eventtime-to-publishtime"
;;                              "-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"
;;      			"-list-waivers"
;;      
;;      			;; 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"
;;                              "-kill-runs"
;;                              "-kill-rerun"
;;                              "-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"
;; 			"-sync-brute-force"
;;      			"-logging"
;;      			"-v" ;; verbose 2, more than normal (normal is 1)
;;      			"-q" ;; quiet 0, errors/warnings only
;;      
;;                              "-diff-rep"
;;      
;;      			"-syscheck"
;;      			"-obfuscate"
;;      			;; junk placeholder
;;      			;; "-:p"
;;      			
;;                              )
;;      		 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
;;      ;;
;;      (if (args:get-arg "-start-dir")
;;          (if (common:file-exists? (args:get-arg "-start-dir"))
;;              (let ((fullpath (common:real-path (args:get-arg "-start-dir"))))
;;                (set-environment-variable! "PWD" fullpath)
;;                (change-directory fullpath))
;;      	(begin
;;      	  (debug:print-error 0 *default-log-port* "non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.")
;;      	  (exit 1))))
;;      
;;      ;; immediately set MT_TARGET if -reqtarg or -target are available
;;      ;;
;;      (let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target"))))
;;        (if targ (set-environment-variable! "MT_TARGET" targ)))
;;      
;;      ;; The watchdog is to keep an eye on things like db sync etc.
;;      ;;
;; ;; (init-watchdog)
;;   
;; ;;      (define (debug:debug-mode n)
;; ;;        (cond
;; ;;         ((and (number? *verbosity*)   ;; number number
;; ;;      	 (number? n))
;; ;;          (<= n *verbosity*))
;; ;;         ((and (list? *verbosity*)     ;; list   number
;; ;;      	 (number? n))
;; ;;          (member n *verbosity*))
;; ;;         ((and (list? *verbosity*)     ;; list   list
;; ;;      	 (list? n))
;; ;;          (not (null? (lset-intersection! eq? *verbosity* n))))
;; ;;         ((and (number? *verbosity*)
;; ;;      	 (list? n))
;; ;;          (member *verbosity* n))))
;; 
;;      ;; 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
;; 	     (args:get-arg "-autolog"))
;;          (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")
;; 			 (args:get-arg "-autolog") ;; autolog provides the basename .../logs/something- for the logfile
;; 			 (launch:setup)))   ;; run launch:setup if -server, ensure we do NOT run launch:setup if -log specified
;;      	       (logf (or (args:get-arg "-log") ;; use -log unless we are a server, then craft a logfile name
;; 			 (conc tl (current-process-id)"-"(get-host-name)".log")
;;      			 (conc tl "/logs/server-" (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")
;;      	(args:get-arg "-help")
;;      	(args:get-arg "--help"))
;;          (begin
;;            (print help)
;;            (exit)))
;;      
;;      (if (args:get-arg "-manual")
;;          (let* ((htmlviewercmd (or (configf:lookup *configdat* "setup" "htmlviewercmd")
;;      			      (common:which '("firefox" "arora"))))
;;      	   (install-home  (common:get-install-area))
;;      	   (manual-html   (conc install-home "/share/docs/megatest_manual.html")))
;;            (if (and install-home
;;      	       (common:file-exists? manual-html))
;;      	  (system (conc "(" htmlviewercmd " " manual-html " ) &"))
;;      	  (system (conc "(" htmlviewercmd " http://www.kiatoa.com/cgi-bin/fossils/megatest/doc/tip/docs/manual/megatest_manual.html ) &")))
;;            (exit)))
;;      
;;      (if (args:get-arg "-version")
;;          (begin
;;            (print (common:version-signature)) ;; (print megatest-version)
;;            (exit)))
;;      
;;      ;; Overall exit handling setup immediately
;;      ;;
;;      (if (or (args:get-arg "-process-reap"))
;;              ;; (args:get-arg "-runtests")
;;      	;; (args:get-arg "-execute")
;;      	;; (args:get-arg "-remove-runs")
;;      	;; (args:get-arg "-runstep"))
;;          (let ((original-exit (exit-handler)))
;;            (exit-handler (lambda (#!optional (exit-code 0))
;;      		      (printf "Preparing to exit with exit code ~A ...\n" exit-code)
;;      		      (for-each
;;      		       
;;      		       (lambda (pid)
;;      			 (handle-exceptions
;;      			     exn
;;      			   (begin
;;      			     (printf "process reap failed. exn=~A\n" exn)
;;      			     #t)
;;      			  (let-values (((pid-val exit-status exit-code) (process-wait pid #t)))
;;      				      (if (or (eq? pid-val pid)
;;      					      (eq? pid-val 0))
;;      					  (begin
;;      					    (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) " ")))
;;      
;;      ;; some switches imply homehost. Exit here if not on homehost
;;      ;;
;;      #;(let ((homehost-required  (list "-cleanup-db" "-server")))
;;        (if (apply args:any-defined? homehost-required)
;;            (if (not (common:on-homehost?))
;;      	  (for-each
;;      	   (lambda (switch)
;;      	     (if (args:get-arg switch)
;;      		 (begin
;;      		   (debug:print 0 *default-log-port* "ERROR: you must be on the homehost to run with " switch
;;      				", you can move homehost by removing the .homehost file but this will disrupt any runs in progress.")
;;      		   (exit 1))))
;;      	   homehost-required))))
;;      
;;      ;;======================================================================
;;      ;; Misc setup stuff
;;      ;;======================================================================
;;      
;;      (debug:setup)
;;      
;;      (if (args:get-arg "-logging")(set! *logging* #t))
;;      
;;      ;;(if (debug:debug-mode 3) ;; we are obviously debugging
;;      ;;    (set! open-run-close open-run-close-no-exception-handling))
;;      
;;      (if (args:get-arg "-itempatt")
;;          (let ((newval (conc (args:get-arg "-testpatt") "/" (args:get-arg "-itempatt"))))
;;            (debug:print 0 *default-log-port* "WARNING: -itempatt has been deprecated, please use -testpatt testpatt/itempatt method, new testpatt is "newval)
;;            (hash-table-set! args:arg-hash "-testpatt" newval)
;;            (hash-table-delete! args:arg-hash "-itempatt")))
;;      
;;      (if (args:get-arg "-runtests")
;;          (debug:print 0 *default-log-port* "WARNING: \"-runtests\" is deprecated. Use \"-run\" with \"-testpatt\" instead"))
;; 
;;      ;; (debug:print 0 *default-log-port* "on-exit disabled. Please re-enable")
;;      (on-exit std-exit-procedure)
;;      
;;      ;;======================================================================
;;      ;; Misc general calls
;;      ;;======================================================================
;; 
;; ;; TODO: Restore this functionality
;; 
;;      #; (if (and (args:get-arg "-cache-db")
;;               (args:get-arg "-source-db"))
;;          (let* ((temp-dir (or (args:get-arg "-target-db") (create-directory (conc "/tmp/" (get-environment-variable "USER") "/" (string-translate (current-directory) "/" "_")))))
;;                 (target-db (conc temp-dir "/cached.db"))
;;                 (source-db (args:get-arg "-source-db")))        
;;            (db:cache-for-read-only source-db target-db)
;;            (set! *didsomething* #t)))
;;      
;;      ;; handle a clean-cache request as early as possible
;;      ;;
;;      (if (args:get-arg "-clean-cache")
;;          (let ((toppath  (launch:setup)))
;;            (set! *didsomething* #t) ;; suppress the help output.
;;            (runs:clean-cache (common:args-get-target)
;;      			(args:get-arg "-runname")
;;      			toppath)))
;;      	  
;;      (if (args:get-arg "-env2file")
;;          (begin
;;            (save-environment-as-files (args:get-arg "-env2file"))
;;            (set! *didsomething* #t)))
;;      
;;      (if (args:get-arg "-list-disks")
;;          (let ((toppath (launch:setup)))
;;            (print 
;;             (string-intersperse 
;;      	(map (lambda (x)
;;      	       (string-intersperse 
;;      		x
;;      		" => "))
;;      	     (common:get-disks *configdat*))
;;      	"\n"))
;;            (set! *didsomething* #t)))
;;      
;;      
;;   (if (args:get-arg "-refdb2dat")
;;          (let* ((input-db (args:get-arg "-refdb2dat"))
;;      	   (out-file (args:get-arg "-o"))
;;      	   (out-fmt  (or (args:get-arg "-dumpmode") "scheme"))
;;      	   (out-port (if (and out-file 
;;      			      (not (member out-fmt '("sqlite3" "csv"))))
;;      			 (open-output-file out-file)
;;      			 (current-output-port)))
;;      	   (res-data (configf:read-refdb input-db))
;;      	   (data     (car res-data))
;;      	   (msg      (cadr res-data)))
;;            (if (not data)
;;      	  (debug:print 0 *default-log-port* "Bad input? data=" data) ;; some error occurred
;;      	  (with-output-to-port out-port
;;      	    (lambda ()
;;      	      (case (string->symbol out-fmt)
;;      		((scheme)(pp data))
;;      		((perl)
;;      		 ;; (print "%hash = (")
;;      		 ;;        key1 => 'value1',
;;      		 ;;        key2 => 'value2',
;;      		 ;;        key3 => 'value3',
;;      		 ;; );
;;      		 (configf:map-all-hier-alist 
;;      		  data 
;;      		  (lambda (sheetname sectionname varname val)
;;      		    (print "$data{\"" sheetname "\"}{\"" sectionname "\"}{\"" varname "\"} = \"" val "\";"))))
;;      		((python ruby)
;;      		 (print "data={}")
;;      		 (configf:map-all-hier-alist
;;      		  data
;;      		  (lambda (sheetname sectionname varname val)
;;      		    (print "data[\"" sheetname "\"][\"" sectionname "\"][\"" varname "\"] = \"" val "\""))
;;      		  initproc1:
;;      		  (lambda (sheetname)
;;      		    (print "data[\"" sheetname "\"] = {}"))
;;      		  initproc2:
;;      		  (lambda (sheetname sectionname)
;;      		    (print "data[\"" sheetname "\"][\"" sectionname "\"] = {}"))))
;;      		((csv)
;;      		 (let* ((results  (make-hash-table)) ;; (make-sparse-array)))
;;      			(row-cols (make-hash-table))) ;; hash of hashes where section => ht { row-<name> => num or col-<name> => num
;;      		   ;; (print "data=")
;;      		   ;; (pp data)
;;      		   (configf:map-all-hier-alist
;;      		    data
;;      		    (lambda (sheetname sectionname varname val)
;;      		      ;; (print "sheetname: " sheetname ", sectionname: " sectionname ", varname: " varname ", val: " val)
;;      		      (let* ((dat      (get-dat results sheetname))
;;      			     (vec      (refdb:csv-get-svec dat))
;;      			     (rownames (refdb:csv-get-rows dat))
;;      			     (colnames (refdb:csv-get-cols dat))
;;      			     (currrown (hash-table-ref/default rownames varname #f))
;;      			     (currcoln (hash-table-ref/default colnames sectionname #f))
;;      			     (rown     (or currrown 
;;      					   (let* ((lastn   (refdb:csv-get-maxrow dat))
;;      						  (newrown (+ lastn 1)))
;;      					     (refdb:csv-set-maxrow! dat newrown)
;;      					     newrown)))
;;      			     (coln     (or currcoln 
;;      					   (let* ((lastn   (refdb:csv-get-maxcol dat))
;;      						  (newcoln (+ lastn 1)))
;;      					     (refdb:csv-set-maxcol! dat newcoln)
;;      					     newcoln))))
;;      			(if (not (sparse-array-ref vec 0 coln)) ;; (eq? rown 0)
;;      			    (begin
;;      			      (sparse-array-set! vec 0 coln sectionname)
;;      			      ;; (print "sparse-array-ref " 0 "," coln "=" (sparse-array-ref vec 0 coln))
;;      			      ))
;;      			(if (not (sparse-array-ref vec rown 0)) ;; (eq? coln 0)
;;      			    (begin
;;      			      (sparse-array-set! vec rown 0 varname)
;;      			      ;; (print "sparse-array-ref " rown "," 0 "=" (sparse-array-ref vec rown 0))
;;      			      ))
;;      			(if (not currrown)(hash-table-set! rownames varname rown))
;;      			(if (not currcoln)(hash-table-set! colnames sectionname coln))
;;      			;; (print "dat=" dat ", rown=" rown ", coln=" coln)
;;      			(sparse-array-set! vec rown coln val)
;;      			;; (print "sparse-array-ref " rown "," coln "=" (sparse-array-ref vec rown coln))
;;      			)))
;;      		   (for-each
;;      		    (lambda (sheetname)
;;      		      (let* ((sheetdat (get-dat results sheetname))
;;      			     (svec     (refdb:csv-get-svec sheetdat))
;;      			     (maxrow   (refdb:csv-get-maxrow sheetdat))
;;      			     (maxcol   (refdb:csv-get-maxcol sheetdat))
;;      			     (fname    (if out-file 
;;      					   (string-substitute "%s" sheetname out-file) ;; "/foo/bar/%s.csv")
;;      					   (conc sheetname ".csv"))))
;;      			(with-output-to-file fname
;;      			  (lambda ()
;;      			    ;; (print "Sheetname: " sheetname)
;;      			    (let loop ((row       0)
;;      				       (col       0)
;;      				       (curr-row '())
;;      				       (result   '()))
;;      			      (let* ((val (sparse-array-ref svec row col))
;;      				     (disp-val (if val
;;      						   (conc "\"" val "\"")
;;      						   "")))
;;      				(if (> col 0)(display ","))
;;      				(display disp-val)
;;      				(cond
;;      				 ((> row maxrow)(display "\n") result)
;;      				 ((>= col maxcol)
;;      				  (display "\n")
;;      				  (loop (+ row 1) 0 '() (append result (list curr-row))))
;;      				 (else
;;      				  (loop row (+ col 1) (append curr-row (list val)) result)))))))))
;;      		    (hash-table-keys results))))
;;      		((sqlite3)
;;      		 (let* ((db-file   (or out-file (pathname-file input-db)))
;;      			(db-exists (common:file-exists? db-file))
;;      			(db        (sqlite3:open-database db-file)))
;;      		   (if (not db-exists)(sqlite3:execute db "CREATE TABLE data (sheet,section,var,val);"))
;;      		   (configf:map-all-hier-alist
;;      		    data
;;      		    (lambda (sheetname sectionname varname val)
;;      		      (sqlite3:execute db
;;      				       "INSERT OR REPLACE INTO data (sheet,section,var,val) VALUES (?,?,?,?);"
;;      				       sheetname sectionname varname val)))
;;      		   (sqlite3:finalize! db)))
;;      		(else
;;      		 (pp data))))))
;;            (if out-file (close-output-port out-port))
;;            (exit) ;; yes, bending the rules here - need to exit since this is a utility
;;            ))
;; 
;;   ;; disabled for now
;;   
;;      #;(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")))
;;            (server-ready? (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
;;      
;;      (let ((envcap (args:get-arg "-envcap")))
;;        (if envcap
;;            (let* ((db      (env:open-db (if (null? remargs) "envdat.db" (car remargs)))))
;;      	(env:save-env-vars db envcap)
;;      	(env:close-database db)
;;      	(set! *didsomething* #t))))
;;      
;;      ;; delta "language" will eventually be res=a+b-c but for now it is just res=a-b 
;;      ;;
;;      (let ((envdelta (args:get-arg "-envdelta")))
;;        (if envdelta
;;            (let ((match (string-split envdelta "-")));; (string-match "([a-z0-9_]+)=([a-z0-9_\\-,]+)" envdelta)))
;;      	(if (not (null? match))
;;      	    (let* ((db        (env:open-db (if (null? remargs) "envdat.db" (car remargs))))
;;      		   ;; (resctx    (cadr match))
;;      		   ;; (equn      (caddr match))
;;      		   (parts     match) ;; (string-split equn "-"))
;;      		   (minuend   (car parts))
;;      		   (subtraend (cadr parts))
;;      		   (added     (env:get-added   db minuend subtraend))
;;      		   (removed   (env:get-removed db minuend subtraend))
;;      		   (changed   (env:get-changed db minuend subtraend)))
;;      	      ;; (pp (hash-table->alist added))
;;      	      ;; (pp (hash-table->alist removed))
;;      	      ;; (pp (hash-table->alist changed))
;;      	      (if (args:get-arg "-o")
;;      		  (with-output-to-file
;;      		      (args:get-arg "-o")
;;      		    (lambda ()
;;      		      (env:print added removed changed)))
;;      		  (env:print added removed changed))
;;      	      (env:close-database db)
;;      	      (set! *didsomething* #t))
;;      	    (debug:print-error 0 *default-log-port* "Parameter to -envdelta should be new=start-end")))))
;;      
;;      ;;======================================================================
;;      ;; 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")
;; 	 (if  (not (args:get-arg "-db"))
;; 	      (debug:print 0 *default-log-port* "ERROR: -db required to start server")
;; 	      (let ((tl        (launch:setup))
;; 		    (dbname    (args:get-arg "-db"))) ;; transport-type (string->symbol (or (args:get-arg "-transport") "http"))))
;; 		(rmt:server-launch dbname)
;; 		(set! *didsomething* #t))))
;; 	 
;;      ;; The adjutant is a bit different, it does NOT run (launch:setup) as it is not necessarily tied to
;;      ;; a specific Megatest area. Detail are being hashed out and this may change.
;;      ;;
;;      (if (args:get-arg "-adjutant")
;;          (begin
;;            (adjutant-run)
;;            (set! *didsomething* #t)))
;;      
;;      (if (or (args:get-arg "-list-servers")
;;              (args:get-arg "-kill-servers"))
;;          (let ((tl (launch:setup)))
;;            (if tl ;; all roads from here exit
;;      	  (let* ((servers (rmt:get-servers-info *toppath*))
;;      		 (fmtstr  "~8a~22a~20a~20a~8a\n"))
;; 	    ;; id INTEGER PRIMARY KEY,
;; 	    ;; host TEXT,
;; 	    ;; port INTEGER,
;; 	    ;; servkey TEXT,
;; 	    ;; pid TEXT,
;; 	    ;; ipaddr TEXT,
;; 	    ;; apath TEXT,
;; 	    ;; dbname TEXT,
;; 	    ;; event_time 
;;      	    (format #t fmtstr "pid" "Interface:port" "State" "dbname" "apath")
;;      	    (format #t fmtstr "===" "==============" "=====" "======" "=====")
;;      	    (for-each ;;  ( mod-time host port start-time pid )
;;      	     (lambda (server)
;; 	       (match-let
;; 		(((id host port servkey pid ipaddr apath dbname event_time) server))
;;      		(format #t
;;      			fmtstr
;;      			pid
;;      			(conc host":"port)
;;      			(if (server-ready? host port servkey) "Running" "Dead")
;;      			dbname ;; (seconds->hr-min-sec mod)
;;      			apath
;; 			)
;;      		 (if (args:get-arg "-kill-servers")
;;      		     (begin
;;      		       (debug:print-info 0 *default-log-port* "Attempting to kill server with pid " pid " !!needs completion!!")
;;      		       #;(server:kill server)))))
;;      	     servers)
;;      	    ;; (debug:print-info 1 *default-log-port* "Done with listservers")
;;      	    (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?
;;      ;;======================================================================
;;      
;;      (if (args:get-arg "-list-targets")
;;          (if (launch:setup)
;;              (let* ((rconfdat (configf:read-config (conc *toppath* "/runconfigs.config") #f #f))
;; 		    (targets  (common:get-runconfig-targets rconfdat)))
;;                ;; (debug:print 1 *default-log-port* "Found "(length targets) " targets")
;;                (case (string->symbol (or (args:get-arg "-dumpmode") "alist"))
;;                  ((alist)
;;                   (for-each (lambda (x)
;;                               ;; (print "[" x "]"))
;;                               (print x))
;;                             targets))
;;                  ((json)
;;                   (json-write targets))
;;                  (else
;;                   (debug:print-error 0 *default-log-port* "dump output format " (args:get-arg "-dumpmode") " not supported for -list-targets")))
;;                (set! *didsomething* #t))))
;; 
;; 
;;      (if (args:get-arg "-show-runconfig")
;;          (let ((tl (launch:setup)))
;;            (push-directory *toppath*)
;;            (let ((data (full-runconfigs-read)))
;;      	;; keep this one local
;;      	(cond
;;      	 ((and (args:get-arg "-section")
;;      	       (args:get-arg "-var"))
;;      	  (let ((val (or (configf:lookup data (args:get-arg "-section")(args:get-arg "-var"))
;;      			 (configf:lookup data "default" (args:get-arg "-var")))))
;;      	    (if val (print val))))
;;      	 ((or (not (args:get-arg "-dumpmode"))
;;                    (string=? (args:get-arg "-dumpmode") "ini"))
;;      	  (configf:config->ini data))
;;      	 ((string=? (args:get-arg "-dumpmode") "sexp")
;;      	  (pp (hash-table->alist data)))
;;      	 ((string=? (args:get-arg "-dumpmode") "json")
;;      	  (json-write data))
;;      	 (else
;;      	  (debug:print-error 0 *default-log-port* "-dumpmode of " (args:get-arg "-dumpmode") " not recognised")))
;;      	(set! *didsomething* #t))
;;            (pop-directory)))
;;      
;;      (if (args:get-arg "-show-config")
;;          (let ((tl   (launch:setup))
;;      	  (data *configdat*)) ;; (configf:read-config "megatest.config" #f #t)))
;;            (push-directory *toppath*)
;;            ;; keep this one local
;;            (cond 
;;             ((and (args:get-arg "-section")
;;      	     (args:get-arg "-var"))
;;      	(let ((val (configf:lookup data (args:get-arg "-section")(args:get-arg "-var"))))
;;      	  (if val (print val))))
;;      
;;             ;; print just a section if only -section
;;      
;;             ((equal? (args:get-arg "-dumpmode") "sexp")
;;      	(pp (hash-table->alist data)))
;;             ((equal? (args:get-arg "-dumpmode") "json")
;;      	(json-write data))
;;             ((or (not (args:get-arg "-dumpmode"))
;;      	    (string=? (args:get-arg "-dumpmode") "ini"))
;;      	(configf:config->ini data))
;;             (else
;;      	(debug:print-error 0 *default-log-port* "-dumpmode of " (args:get-arg "-dumpmode") " not recognised")))
;;            (set! *didsomething* #t)
;;            (pop-directory)
;;            (bdat-time-to-exit-set! *bdat* #t)))
;;      
;;      (if (args:get-arg "-show-cmdinfo")
;;          (if (or (args:get-arg ":value")(get-environment-variable "MT_CMDINFO"))
;;      	(let ((data (common:read-encoded-string (or (args:get-arg ":value")(get-environment-variable "MT_CMDINFO")))))
;;      	  (if (equal? (args:get-arg "-dumpmode") "json")
;;      	      (json-write data)
;;      	      (pp data))
;;      	  (set! *didsomething* #t))
;;      	(debug:print-info 0 *default-log-port* "environment variable MT_CMDINFO is not set")))
;;      
;;      ;;======================================================================
;;      ;; Remove old run(s)
;;      ;;======================================================================
;;      
;;      ;; since several actions can be specified on the command line the removal
;;      ;; is done first
;;      (define (operate-on action #!key (mode #f)(target-in #f)(runname-in #f)(keys-in #f)(keyvals-in #f)) ;; #f is "use default"
;;        (let* ((runrec (runs:runrec-make-record))
;;      	 (target (or target-in   (common:args-get-target))) ;; eventually get rid of the call to common:args-get-target
;;      	 (runname (or runname-in
;;      		      (args:get-arg "-runname"))) ;; eventually get rid of the get-arg calls
;;      	 (testpatt (or (args:get-arg "-testpatt")
;;      		       (and (eq? action 'archive) ;; if it is an archive command fallback to MT_TEST_NAME and MT_ITEMPATH
;;      			    (common:get-full-test-name))
;;      		       (and (eq? action 'kill-runs)
;;      			    "%/%") ;; I'm just guessing that this is correct :(
;;      		       (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")))
;;      		       ))) ;;
;;          (cond
;;           ((not target)
;;            (debug:print-error 0 *default-log-port* "Missing required parameter for "
;;      			 action ", you must specify -target or -reqtarg")
;;            (exit 1))
;;           ((not runname)
;;            (debug:print-error 0 *default-log-port* "Missing required parameter for "
;;      			 action ", you must specify the run name pattern with -runname patt")
;;            (exit 2))
;;           ((not testpatt)
;;            (debug:print-error 0 *default-log-port* "Missing required parameter for "
;;      			 action ", you must specify the test pattern with -testpatt")
;;            (exit 3))
;;           (else
;;            (if (not (car *configinfo*))
;;      	  (begin
;;      	    (debug:print-error 0 *default-log-port* "Attempted " action "on test(s) but run area config file not found")
;;      	    (exit 1))
;;      	  ;; put test parameters into convenient variables
;;      	  (begin
;;      	    ;; check for correct version, exit with message if not correct
;; 
;; 	    ;; TODO: restore this functionality
;; 	    
;; 	    ;; (common:exit-on-version-changed)
;; 	    
;;      	    (runs:operate-on  action
;;      			      target
;;      			      runname
;;      			      testpatt
;;      			      state:  (common:args-get-state)
;;      			      status: (common:args-get-status)
;;      			      new-state-status: (args:get-arg "-set-state-status")
;;                                    mode: mode)))
;;            (set! *didsomething* #t)))))
;;      
;;      (if (args:get-arg "-kill-runs")
;;          (general-run-call 
;;           "-kill-runs"
;;           "kill runs"
;;           (lambda (target runname keys keyvals)
;;             (operate-on 'kill-runs mode: #f)
;;             )))
;;      
;;      (if (args:get-arg "-kill-rerun")
;;          (let* ((target-patt (common:args-get-target))
;;                 (runname-patt (args:get-arg "-runname")))
;;            (cond ((not target-patt)
;;                   (debug:print-error 0 *default-log-port* "Missing target, must specify target for -kill-rerun with -target <target name>")
;;                   (exit 1))
;;                  ((not runname-patt)
;;                   (debug:print-error 0 *default-log-port* "Missing runname, must specify runname for -kill-rerun with -runname <run name>")
;;                   (exit 1))
;;                  ((string-search "[ ,%]" target-patt)
;;                   (debug:print-error 0 *default-log-port* "Invalid target ["target-patt"], must specify exact target (no wildcards) for -kill-rerun with -target <target name>")
;;                   (exit 1))
;;                  ((string-search "[ ,%]" runname-patt)
;;                   (debug:print-error 0 *default-log-port* "Invalid runname ["runname-patt"], must specify exact runname (no wildcards) for -kill-rerun with -runname <runname name>")
;;                   (exit 1))
;;                  (else
;;                   (general-run-call 
;;                    "-kill-runs"
;;                    "kill runs"
;;                    (lambda (target runname keys keyvals)
;;                      (operate-on 'kill-runs mode: #f)
;;                      ))
;;            
;;                   (thread-sleep! 15))
;;                  ;; fall thru and let "-run" loop fire
;;                  )))
;;      
;;      
;;      (if (args:get-arg "-remove-runs")
;;          (general-run-call 
;;           "-remove-runs"
;;           "remove runs"
;;           (lambda (target runname keys keyvals)
;;             (operate-on 'remove-runs mode: (if (args:get-arg "-keep-records")
;;                                                'remove-data-only
;;                                                'remove-all)))))
;;      
;;      (if (args:get-arg "-remove-keep")
;;          (general-run-call 
;;           "-remove-keep"
;;           "remove keep"
;;           (lambda (target runname keys keyvals)
;;             (let ((actions (map string->symbol
;;                                 (string-split
;;      			    (or (args:get-arg "-actions")
;;      				"print")
;;      			    ",")))) ;; default to printing the output
;;               (runs:remove-all-but-last-n-runs-per-target target runname
;;      						     (string->number (args:get-arg "-remove-keep"))
;;      						     actions: actions)))))
;;      
;;      (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))))
;;      
;;      (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)
;;             (let* ((runsdat  (rmt:get-runs-by-patt keys runname 
;;      					(common:args-get-target)
;;      					#f #f #f #f))
;;      	      (header   (vector-ref runsdat 0))
;;      	      (rows     (vector-ref runsdat 1)))
;;      	 (if (null? rows)
;;      	     (begin
;;      	       (debug:print-info 0 *default-log-port* "No matching run found.")
;;      	       (exit 1))
;;      	     (let* ((row      (car (vector-ref runsdat 1)))
;;      		    (run-id   (db:get-value-by-header row header "id")))
;;      	       (if (args:get-arg "-set-run-status")
;;      		   (rmt:set-run-status run-id (args:get-arg "-set-run-status") msg: (args:get-arg "-m"))
;;      		   (print (rmt:get-run-status run-id))
;;      		   )))))))
;;      
;;      ;;======================================================================
;;      ;; Query runs
;;      ;;======================================================================
;;      
;;      ;; -fields runs:id,target,runname,comment+tests:id,testname,item_path+steps
;;      ;;
;;      ;; csi> (extract-fields-constraints "runs:id,target,runname,comment+tests:id,testname,item_path+steps")
;;      ;;         => (("runs" "id" "target" "runname" "comment") ("tests" "id" "testname" "item_path") ("steps"))
;;      ;;
;;      ;;   NOTE: remember that the cdr will be the list you expect (cdr ("runs" "id" "target" "runname" "comment")) => ("id" "target" "runname" "comment")
;;      ;;         and so alist-ref will yield what you expect
;;      ;;
;;      (define (extract-fields-constraints fields-spec)
;;        (map (lambda (table-spec) ;; runs:id,target,runname
;;      	 (let ((dat (string-split table-spec ":"))) ;; ("runs" "id,target,runname")
;;      	   (if (> (length dat) 1)
;;      	       (cons (car dat)(string-split (cadr dat) ",")) ;; "id,target,runname"
;;      	       dat)))
;;             (string-split fields-spec "+")))
;;      
;;      (define (get-value-by-fieldname datavec test-field-index fieldname)
;;        (let ((indx (hash-table-ref/default test-field-index fieldname #f)))
;;          (if indx
;;      	(if (>= indx (vector-length datavec))
;;      	    #f ;; index too high, should raise an error I suppose
;;      	    (vector-ref datavec indx))
;;      	#f)))
;;      
;;      
;;      
;;      
;;      
;;      (when (args:get-arg "-testdata-csv")
;;        (if (launch:setup)
;;            (let* ((keys        (rmt:get-keys)) ;; (db:get-keys dbstruct))
;;                   (runpatt     (or (args:get-arg "-runname") "%"))
;;                   (testpatt    (common:args-get-testpatt #f))
;;                   (datapatt    (args:get-arg "-testdata-csv"))
;;                   (match-data  (string-match "^([^/]+)/(.*)" (args:get-arg "-testdata-csv")))
;;                   (categorypatt (if match-data (list-ref match-data 1) "%"))
;;                   (setvarpatt  (if match-data
;;                                    (list-ref match-data 2)
;;                                    (args:get-arg "-testdata-csv")))
;;                   (runsdat     (rmt:get-runs-by-patt keys (or runpatt "%") 
;;                                                      (common:args-get-target) #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0))
;;                   (header      (db:get-header runsdat))
;;                   (access-mode (db:get-access-mode))
;;                   (testpatt    (common:args-get-testpatt #f))
;;                   (fields-spec (if (args:get-arg "-fields")
;;                                    (extract-fields-constraints (args:get-arg "-fields"))
;;                                    (list (cons "runs" (append keys (list "id" "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count")))
;;                                          (cons "tests"  db:test-record-fields) ;; "id" "testname" "test_path")
;;                                          (list "steps" "id" "stepname"))))
;;                   (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))) 
;;                   (test-field-index (make-hash-table))
;;                   (runs (db:get-rows runsdat))
;;                   )
;;              (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))
;;                          (hash-table-set! test-field-index hed idx)
;;                          (if (not (null? tal))(loop (car tal)(cdr tal)(+ idx 1))))
;;                        (begin
;;                          (debug:print-error 0 *default-log-port* "Invalid test fields specified: " (string-intersperse invalid-tests-spec ", "))
;;                          (exit)))))
;;              (let* ((table-header (string-split "target,run,test,itempath,category,var,value,comment" ","))
;;                     (table-rows
;;                      (apply append (map  
;;                                     (lambda (run)
;;                                       (let* ((target (string-intersperse (map (lambda (x)
;;      							 (db:get-value-by-header run header x))
;;      						       keys) "/"))
;;                                              (statuses (string-split (or (args:get-arg "-status") "") ","))
;;                                              (run-id  (db:get-value-by-header run header "id"))
;;                                              (runname (db:get-value-by-header run header "runname")) 
;;                                              (states  (string-split (or (args:get-arg "-state") "") ","))
;;                                              (tests   (if tests-spec
;;                                                           (rmt:get-tests-for-run run-id testpatt states statuses #f #f #f 'testname 'asc ;; (db:get-tests-for-run dbstruct run-id testpatt '() '() #f #f #f 'testname 'asc 
;;                                                                              ;; use qryvals if test-spec provided
;;                                                                              (if tests-spec
;;                                                                                  (string-intersperse adj-tests-spec ",")
;;                                                                                  ;; db:test-record-fields
;;                                                                                  #f)
;;                                                                              #f
;;                                                                              'normal)
;;                                                           '())))
;;                                         (apply append
;;                                                (map
;;                                                 (lambda (test)
;;                                                   (let* (
;;                                                          (test-id      (if (member "id"           tests-spec)(get-value-by-fieldname test test-field-index "id"          ) #f)) ;; (db:test-get-id         test))
;;                                                          (testname     (if (member "testname"     tests-spec)(get-value-by-fieldname test test-field-index "testname"    ) #f)) ;; (db:test-get-testname   test))
;;                                                          (itempath     (if (member "item_path"    tests-spec)(get-value-by-fieldname test test-field-index "item_path"   ) #f)) ;; (db:test-get-item-path  test))
;;                                                          (fullname     (conc testname
;;                                                                              (if (equal? itempath "")
;;                                                                                  "" 
;;                                                                                  (conc "/" itempath ))))
;;                                                          (testdat-raw (map vector->list (rmt:read-test-data-varpatt run-id test-id categorypatt setvarpatt)))
;;                                                          (testdat (filter
;;                                                                    (lambda (x)
;;                                                                      (not (equal? "logpro"
;;                                                                                   (list-ref x 10))))
;;                                                                    testdat-raw)))
;;                                                     (map 
;;                                                      (lambda (item)
;;                                                        (receive (id test_id category
;;                                                                     variable value expected
;;                                                                     tol units comment status type)
;;                                                            (apply values item)
;;                                                          (list target runname testname itempath category variable value comment)))
;;                                                      testdat)))
;;                                                 tests))))
;;                                     runs))))
;;                (print (string-join table-header ","))
;;                (for-each (lambda(table-row)
;;                            (print (string-join (map ->string table-row) ",")))
;;      
;;                          
;;                                  table-rows))))
;;        (set! *didsomething* #t)
;;        (bdat-time-to-exit-set! *bdat* #t))
;;      
;;      
;;      
;;      ;; 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* (;; (dbstruct    (make-dbr:dbstruct path: *toppath* local: (args:get-arg "-local")))
;;      	       (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 '()))
;;      	;; (runsdat     (rmt:get-runs-by-patt keys (or runpatt "%") (common:args-get-target) ;; (db:get-runs-by-patt dbstruct keys (or runpatt "%") (common:args-get-target)
;;      	;; 		           	 #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0))
;;      	       (runsdat     (rmt:get-runs-by-patt keys (or runpatt "%") 
;;                                                        (common:args-get-target) #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0))
;;      	       (runstmp     (db:get-rows runsdat))
;;      	       (header      (db:get-header runsdat))
;;      	       ;; this is "-since" support. This looks at last mod times of <run-id>.db files
;;      	       ;; and collects those modified since the -since time.
;;      	       (runs        runstmp)
;;                              ;; (if (and (not (null? runstmp))
;;      			;;        (args:get-arg "-since"))
;;      			;;   (let ((changed-ids (db:get-changed-run-ids (string->number (args:get-arg "-since")))))
;;      			;;     (let loop ((hed (car runstmp))
;;      			;;   	     (tal (cdr runstmp))
;;      			;;   	     (res '()))
;;      			;;       (let ((new-res (if (member (db:get-value-by-header hed header "id") changed-ids)
;;      			;;   		       (cons hed res)
;;      			;;   		       res)))
;;      			;;         (if (null? tal)
;;      			;;   	  (reverse new-res)
;;      			;;   	  (loop (car tal)(cdr tal) new-res)))))
;;      			;;   runstmp))
;;      	       (db-targets  (args:get-arg "-list-db-targets"))
;;      	       (seen        (make-hash-table))
;;      	       (dmode       (let ((d (args:get-arg "-dumpmode"))) ;; json, sexpr
;;      			      (if d (string->symbol d) #f)))
;;      	       (data        (make-hash-table))
;;      	       (fields-spec (if (args:get-arg "-fields")
;;      				(extract-fields-constraints (args:get-arg "-fields"))
;;      				(list (cons "runs" (append keys (list "id" "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count")))
;;      				      (cons "tests"  db:test-record-fields) ;; "id" "testname" "test_path")
;;      				      (list "steps" "id" "stepname"))))
;;      	       (runs-spec   (let ((r (alist-ref "runs"  fields-spec equal?))) ;; the check is now unnecessary
;;      			      (if (and r (not (null? r))) r (list "id" ))))
;;      	       (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 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))
;;      		      (hash-table-set! test-field-index hed idx)
;;      		      (if (not (null? tal))(loop (car tal)(cdr tal)(+ idx 1))))
;;      		    (begin
;;      		      (debug:print-error 0 *default-log-port* "Invalid test fields specified: " (string-intersperse invalid-tests-spec ", "))
;;      		      (exit)))))
;;      	  ;; Each run
;;      	  (for-each 
;;      	   (lambda (run)
;;      	     (let ((targetstr (string-intersperse (map (lambda (x)
;;      							 (db:get-value-by-header run header x))
;;      						       keys) "/")))
;;      	       (if db-targets
;;      		   (if (not (hash-table-ref/default seen targetstr #f))
;;      		       (begin
;;      			 (hash-table-set! seen targetstr #t)
;;      			 ;; (print "[" targetstr "]"))))
;;      			 (if (not dmode)
;;      			     (print targetstr)
;;      			     (hash-table-set! data "targets" (cons targetstr (hash-table-ref/default data "targets" '())))
;;      			     )))
;;      		   (let* ((run-id  (db:get-value-by-header run header "id"))
;;      			  (runname (db:get-value-by-header run header "runname")) 
;;      			  (states  (string-split (or (args:get-arg "-state") "") ","))
;;      			  (statuses (string-split (or (args:get-arg "-status") "") ","))
;;      			  (tests   (if tests-spec
;;      				       (rmt:get-tests-for-run run-id testpatt states statuses #f #f #f 'testname 'asc ;; (db:get-tests-for-run dbstruct run-id testpatt '() '() #f #f #f 'testname 'asc 
;;      							     ;; use qryvals if test-spec provided
;;      							     (if tests-spec
;;      								 (string-intersperse adj-tests-spec ",")
;;      								 ;; db:test-record-fields
;;      								 #f)
;;      							     #f
;;      							     'normal)
;;      				       '())))
;;      		     (case dmode
;;      		       ((json ods sexpr)
;;      			(if runs-spec
;;      			    (for-each 
;;      			     (lambda (field-name)
;;      			       (mutils:hierhash-set! data (conc (db:get-value-by-header run header field-name)) targetstr runname "meta" field-name))
;;      			     runs-spec)))
;;      			;; (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"    )
;;      		       (else
;;      			(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)))))
;;      		       
;;      		     (for-each 
;;      		      (lambda (test)
;;      		      	(handle-exceptions
;;      			 exn
;;      			 (begin
;;      			   (debug:print-error 0 *default-log-port* "Bad data in test record? " test)
;;      			   (debug:print-error 5 *default-log-port* "exn=" (condition->list exn))
;;      			   (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
;;      			   (print-call-chain (current-error-port)))
;;      			 (let* ((test-id      (if (member "id"           tests-spec)(get-value-by-fieldname test test-field-index "id"          ) #f)) ;; (db:test-get-id         test))
;;      				(testname     (if (member "testname"     tests-spec)(get-value-by-fieldname test test-field-index "testname"    ) #f)) ;; (db:test-get-testname   test))
;;      				(itempath     (if (member "item_path"    tests-spec)(get-value-by-fieldname test test-field-index "item_path"   ) #f)) ;; (db:test-get-item-path  test))
;;      				(comment      (if (member "comment"      tests-spec)(get-value-by-fieldname test test-field-index "comment"     ) #f)) ;; (db:test-get-comment    test))
;;      				(tstate       (if (member "state"        tests-spec)(get-value-by-fieldname test test-field-index "state"       ) #f)) ;; (db:test-get-state      test))
;;      				(tstatus      (if (member "status"       tests-spec)(get-value-by-fieldname test test-field-index "status"      ) #f)) ;; (db:test-get-status     test))
;;      				(event-time   (if (member "event_time"   tests-spec)(get-value-by-fieldname test test-field-index "event_time"  ) #f)) ;; (db:test-get-event_time test))
;;      				(rundir       (if (member "rundir"       tests-spec)(get-value-by-fieldname test test-field-index "rundir"      ) #f)) ;; (db:test-get-rundir     test))
;;      				(final_logf   (if (member "final_logf"   tests-spec)(get-value-by-fieldname test test-field-index "final_logf"  ) #f)) ;; (db:test-get-final_logf test))
;;      				(run_duration (if (member "run_duration" tests-spec)(get-value-by-fieldname test test-field-index "run_duration") #f)) ;; (db:test-get-run_duration test))
;;      				(fullname     (conc testname
;;      						    (if (equal? itempath "")
;;      							"" 
;;      							(conc "(" itempath ")")))))
;;      			   (case dmode
;;      			     ((json ods sexpr)
;;      			      (if tests-spec
;;      				  (for-each
;;      				   (lambda (field-name)
;;      				     (mutils:hierhash-set! data  (get-value-by-fieldname test test-field-index field-name) targetstr runname "data" (conc test-id) field-name))
;;      				   tests-spec)))
;;      			     ;; ;; (mutils:hierhash-set! data  fullname   targetstr runname "data" (conc test-id) "tname"     )
;;      			     ;;  (mutils:hierhash-set! data  testname   targetstr runname "data" (conc test-id) "testname"  )
;;      			     ;;  (mutils:hierhash-set! data  itempath   targetstr runname "data" (conc test-id) "itempath"  )
;;      			     ;;  (mutils:hierhash-set! data  comment    targetstr runname "data" (conc test-id) "comment"   )
;;      			     ;;  (mutils:hierhash-set! data  tstate     targetstr runname "data" (conc test-id) "state"     )
;;      			     ;;  (mutils:hierhash-set! data  tstatus    targetstr runname "data" (conc test-id) "status"    )
;;      			     ;;  (mutils:hierhash-set! data  rundir     targetstr runname "data" (conc test-id) "rundir"    )
;;      			     ;;  (mutils:hierhash-set! data  final_logf targetstr runname "data" (conc test-id) "final_logf")
;;      			     ;;  (mutils:hierhash-set! data  run_duration targetstr runname "data" (conc test-id) "run_duration")
;;      			     ;;  (mutils:hierhash-set! data  event-time targetstr runname "data" (conc test-id) "event_time")
;;      			     ;;  ;; add last entry twice - seems to be a bug in hierhash?
;;      			     ;;  (mutils:hierhash-set! data  event-time targetstr runname "data" (conc test-id) "event_time")
;;      			     ;;  )
;;      			     (else
;;      			      (if (and tstate tstatus event-time)
;;      				  (format #t
;;      					  "  Test: ~25a State: ~15a Status: ~15a Runtime: ~5@as Time: ~22a Host: ~10a\n"
;;      					  (if fullname fullname "")
;;      					  (if tstate   tstate   "")
;;      					  (if tstatus  tstatus  "")
;;      					  (get-value-by-fieldname test test-field-index "run_duration");;(if test     (db:test-get-run_duration test) "")
;;      					  (if event-time event-time "")
;;      					  (get-value-by-fieldname test test-field-index "host")) ;;(if test (db:test-get-host test)) "")
;;      				  (print "  Test: " fullname
;;      					 (if tstate  (conc " State: "  tstate)  "")
;;      					 (if tstatus (conc " Status: " tstatus) "")
;;      					 (if (get-value-by-fieldname test test-field-index "run_duration")
;;      					     (conc " Runtime: " (get-value-by-fieldname test test-field-index "run_duration"))
;;      					     "")
;;      					 (if event-time (conc " Time: " event-time) "")
;;      					 (if (get-value-by-fieldname test test-field-index "host")
;;      					     (conc " Host: " (get-value-by-fieldname test test-field-index "host"))
;;      					     "")))
;;      			      (if (not (or (equal? (get-value-by-fieldname test test-field-index "status") "PASS")
;;      					   (equal? (get-value-by-fieldname test test-field-index "status") "WARN")
;;      					   (equal? (get-value-by-fieldname test test-field-index "state")  "NOT_STARTED")))
;;      				  (begin
;;      				    (print   (if (get-value-by-fieldname test test-field-index "cpuload")
;;      						 (conc "         cpuload:  "   (get-value-by-fieldname test test-field-index "cpuload"))
;;      						 "") ;; (db:test-get-cpuload test)
;;      					     (if (get-value-by-fieldname test test-field-index "diskfree")
;;      						 (conc "\n         diskfree: " (get-value-by-fieldname test test-field-index "diskfree")) ;; (db:test-get-diskfree test)
;;      						 "")
;;      					     (if (get-value-by-fieldname test test-field-index "uname")
;;      						 (conc "\n         uname:    " (get-value-by-fieldname test test-field-index "uname")) ;; (db:test-get-uname test)
;;      						 "")
;;      					     (if (get-value-by-fieldname test test-field-index "rundir")
;;      						 (conc "\n         rundir:   " (get-value-by-fieldname test test-field-index "rundir")) ;; (db:test-get-rundir test)
;;      						 "")
;;      ;;					     "\n         rundir:   " (get-value-by-fieldname test test-field-index "") ;; (sdb:qry 'getstr ;; (filedb:get-path *fdb* 
;;      ;; 					     (db:test-get-rundir test) ;; )
;;      					     )
;;      				    ;; Each test
;;      				    ;; DO NOT remote run
;;      				    (let ((steps (rmt:get-steps-for-test run-id (db:test-get-id test)))) ;; (db:get-steps-for-test dbstruct run-id (db:test-get-id test))))
;;      				      (for-each 
;;      				       (lambda (step)
;;      					 (format #t 
;;      						 "    Step: ~20a State: ~10a Status: ~10a Time ~22a\n"
;;      						 (tdb:step-get-stepname step)
;;      						 (tdb:step-get-state step)
;;      						 (tdb:step-get-status step)
;;      						 (tdb:step-get-event_time step)))
;;      				       steps)))))))))
;;      		      (if (args:get-arg "-sort")
;;      			  (sort tests
;;      				(lambda (a-test b-test)
;;      				  (let* ((key    (args:get-arg "-sort"))
;;      					 (first  (get-value-by-fieldname a-test test-field-index key))
;;      					 (second (get-value-by-fieldname b-test test-field-index key)))
;;      				    ((cond 
;;      				      ((and (number? first)(number? second)) <)
;;      				      ((and (string? first)(string? second)) string<=?)
;;      				      (else equal?))
;;      				     first second))))
;;      			  tests))))))
;;      	   runs)
;;      	  (case dmode
;;      	    ((json)  (json-write data))
;;      	    ((sexpr) (pp (common:to-alist data))))
;;      	  (let* ((metadat-fields (delete-duplicates
;;      				  (append keys '( "runname" "time" "owner" "pass_count" "fail_count" "state" "status" "comment" "id"))))
;;      		 (run-fields    '(
;;      				  "testname"
;;      				  "item_path"
;;      				  "state"
;;      				  "status"
;;      				  "comment"
;;      				  "event_time"
;;      				  "host"
;;      				  "run_id"
;;      				  "run_duration"
;;      				  "attemptnum"
;;      				  "id"
;;      				  "archived"
;;      				  "diskfree"
;;      				  "cpuload"
;;      				  "final_logf"
;;      				  "shortdir"
;;      				  "rundir"
;;      				  "uname"
;;      				  )
;;      				)
;;      		 (newdat          (common:to-alist data))
;;      		 (allrundat       (if (null? newdat)
;;      				      '()
;;      				      (car (map cdr newdat)))) ;; (car (map cdr (car (map cdr newdat)))))
;;      		 (runs            (append
;;      				   (list "runs" ;; sheetname
;;      					 metadat-fields)
;;      				   (map (lambda (run)
;;      					  ;; (print "run: " run)
;;      					  (let* ((runname (car run))
;;      						 (rundat  (cdr run))
;;      						 (metadat (let ((tmp (assoc "meta" rundat)))
;;      							    (if tmp (cdr tmp) #f))))
;;      					    ;; (print "runname: " runname "\n\nrundat: " )(pp rundat)(print "\n\nmetadat: ")(pp metadat)
;;      					    (if metadat
;;      						(map (lambda (field)
;;      						       (let ((tmp (assoc field metadat)))
;;      							 (if tmp (cdr tmp) "")))
;;      						     metadat-fields)
;;      						(begin
;;      						  (debug:print 0 *default-log-port* "WARNING: meta data for run " runname " not found")
;;      						  '()))))
;;      					allrundat)))
;;      		 ;; '( ( "target" ( "runname" ( "data" ( "runid" ( "id . "37" ) ( ... ))))
;;      		 (run-pages      (map (lambda (targdat)
;;      					(let* ((target  (car targdat))
;;      					       (runsdat (cdr targdat)))
;;      					  (if runsdat
;;      					      (map (lambda (rundat)
;;      						     (let* ((runname  (car rundat))
;;      							    (rundat   (cdr rundat))
;;      							    (testsdat (let ((tmp (assoc "data" rundat)))
;;      									(if tmp (cdr tmp) #f))))
;;      						       (if testsdat
;;      							   (let ((tests (map (lambda (test)
;;      									       (let* ((test-id  (car test))
;;      										      (test-dat (cdr test)))
;;      										 (map (lambda (field)
;;      											(let ((tmp (assoc field test-dat)))
;;      											  (if tmp (cdr tmp) "")))
;;      										      run-fields)))
;;      									     testsdat)))
;;      							     ;; (print "Target: " target "/" runname " tests:")
;;      							     ;; (pp tests)
;;      							     (cons (conc target "/" runname)
;;      								   (cons (list (conc target "/" runname))
;;      									 (cons '()
;;      									       (cons run-fields tests)))))
;;      							   (begin
;;      							     (debug:print 4 *default-log-port* "WARNING: run " target "/" runname " appears to have no data")
;;      							     ;; (pp rundat)
;;      							     '()))))
;;      						   runsdat)
;;      					      '())))
;;      				      newdat)) ;; we use newdat to get target
;;      		 (sheets         (filter (lambda (x)
;;      					   (not (null? x)))
;;      					 (cons runs (map car run-pages)))))
;;      	    ;; (print "allrundat:")
;;      	    ;; (pp allrundat)
;;      	    ;; (print "runs:")
;;      	    ;; (pp runs)
;;      	    ;(print "sheets: ")
;;      	    ;; (pp sheets)
;;      	    (if (eq? dmode 'ods)
;;      		(let* ((tempdir    (conc "/tmp/" (current-user-name) "/" (pseudo-random-integer 10000) "_" (current-process-id)))
;;      		       (outputfile (or (args:get-arg "-o") "out.ods"))
;;      		       (ouf        (if (string-match (regexp "^[/~]+.*") outputfile) ;; full path?
;;      				       outputfile
;;      				       (begin
;;      					 (debug:print 0 *default-log-port* "WARNING: path given, " outputfile " is relative, prefixing with current directory")
;;      					 (conc (current-directory) "/" outputfile)))))
;;      		  (create-directory tempdir #t)
;;      		  (ods:list->ods tempdir ouf sheets))))
;;      	  ;; (system (conc "rm -rf " tempdir))
;;      	  (set! *didsomething* #t)
;; 	  (bdat-time-to-exit-set! *bdat* #t)
;; 	  ) ;; end if true branch (end of a let)
;; 	) ;; end if
;;          ) ;; end if -list-runs
;; 
;;      ;; list-waivers
;;      (if (and (args:get-arg "-list-waivers")
;;      	 (launch:setup))
;;          (let* ((runpatt     (or (args:get-arg "-runname") "%"))
;;      	   (testpatt    (common:args-get-testpatt #f))
;;      	   (keys        (rmt:get-keys)) 
;;      	   (runsdat     (rmt:get-runs-by-patt
;;      			 keys runpatt 
;;      			 (common:args-get-target) #f #f
;;      			 '("id" "runname" "state" "status" "owner" "event_time" "comment") 0))
;;      	   (runs        (db:get-rows runsdat))
;;      	   (header      (db:get-header runsdat))
;;      	   (results     (make-hash-table))  ;; [target] ( (testname/itempath . "comment") ... )
;;      	   (addtest     (lambda (target testname itempath comment)
;;      			  (hash-table-set! results target (cons (cons (conc testname "/" itempath) comment)
;;      								(hash-table-ref/default results target '())))))
;;      	   (last-target #f))
;;            (for-each
;;             (lambda (run)
;;      	 (let* ((run-id  (db:get-value-by-header run header "id"))
;;      		(target  (rmt:get-target run-id))
;;      		(runname (db:get-value-by-header run header "runname")) 
;;      		(tests   (rmt:get-tests-for-run
;;      			  run-id testpatt '("COMPLETED") '("WAIVED") #f #f #f 'testname 'asc							     ;; use qryvals if test-spec provided
;;      			  #f #f #f)))
;;      	   (if (not (equal? target last-target))
;;      	       (print "[" target "]"))
;;      	   (set! last-target target)
;;      	   (print "# " runname)
;;      	   (for-each
;;      	    (lambda (testdat)
;;      	      (let* ((testfullname (conc (db:test-get-testname testdat)
;;      					 (if (equal? "" (db:test-get-item-path testdat))
;;      					     ""
;;      					     (conc "/" (db:test-get-item-path testdat)))
;;      					 )))
;;      	      (print testfullname " " (db:test-get-comment testdat))))
;;      	    tests)))
;;             runs)
;;            (set! *didsomething* #t)))
;;            
;;      
;;      ;; get lock in db for full run for this directory
;;      ;; for all tests with deps
;;      ;;   walk tree of tests to find head tasks
;;      ;;   add head tasks to task queue
;;      ;;   add dependant tasks to task queue 
;;      ;;   add remaining tasks to task queue
;;      ;; for each task in task queue
;;      ;;   if have adequate resources
;;      ;;     launch task
;;      ;;   else
;;      ;;     put task in deferred queue
;;      ;; if still ok to run tasks
;;      ;;   process deferred tasks per above steps
;;      
;;      ;; run all tests are are Not COMPLETED and PASS or CHECK
;;      (if (or (args:get-arg "-runall")
;;      	(args:get-arg "-run")
;;      	(args:get-arg "-rerun-clean")
;;      	(args:get-arg "-rerun-all")
;;      	(args:get-arg "-runtests")
;;              (args:get-arg "-kill-rerun"))
;;          (let ((need-clean (or (args:get-arg "-rerun-clean")
;;                                (args:get-arg "-rerun-all")))
;;      	  (orig-cmdline (string-intersperse (argv) " ")))
;;            (general-run-call 
;;             "-runall"
;;             "run all tests"
;;             (lambda (target runname keys keyvals)
;;      	 (if (or (string-search "%" target)
;;      		 (string-search "%" runname)) ;; we are being asked to re-run multiple runs
;;      	     (let* ((run-specs (rmt:simple-get-runs runname #f #f target #f))) ;; list of simple-run records
;;      	       (debug:print-info 0 *default-log-port* "Pattern supplied for target or runname with "
;;      				 (length run-specs) " matches round. Running each in turn.")
;;      	       (if (null? run-specs)
;;      		   (debug:print 0 *default-log-port* "WARNING: No runs match target " target " and runname " runname))
;;      	       (for-each (lambda (spec) 
;;      			   (let* ((precmd     (if (args:get-arg "-precmd")(conc (args:get-arg "-precmd") " ") ""))
;;      				  (newcmdline (conc
;;      					       precmd
;;      					       (string-substitute
;;      						(conc "target " target)
;;      						(conc "target " (simple-run-target spec))
;;      						(string-substitute
;;      						 (conc "runname " runname)
;;      						 (conc "runname " (simple-run-runname spec))
;;      						 orig-cmdline)))))
;;      			     (debug:print 0 *default-log-port* "ORIG: " orig-cmdline)
;;      			     (debug:print 0 *default-log-port* "NEW:  " newcmdline)
;;      			     (system newcmdline)))
;;      			 run-specs))
;;      	     (handle-run-requests target runname keys keyvals need-clean))))))
;;      
;;      ;;======================================================================
;;      ;; run one test
;;      ;;======================================================================
;;      
;;      ;; 1. find the config file
;;      ;; 2. change to the test directory
;;      ;; 3. update the db with "test started" status, set running host
;;      ;; 4. process launch the test
;;      ;;    - monitor the process, update stats in the db every 2^n minutes
;;      ;; 5. as the test proceeds internally it calls megatest as each step is
;;      ;;    started and completed
;;      ;;    - step started, timestamp
;;      ;;    - step completed, exit status, timestamp
;;      ;; 6. test phone home
;;      ;;    - if test run time > allowed run time then kill job
;;      ;;    - if cannot access db > allowed disconnect time then kill job
;;      
;;      ;; == duplicated == (if (or (args:get-arg "-run")(args:get-arg "-runtests"))
;;      ;; == duplicated ==   (general-run-call 
;;      ;; == duplicated ==    "-runtests" 
;;      ;; == duplicated ==    "run a test" 
;;      ;; == duplicated ==    (lambda (target runname keys keyvals)
;;      ;; == duplicated ==      ;;
;;      ;; == duplicated ==      ;; May or may not implement it this way ...
;;      ;; == duplicated ==      ;;
;;      ;; == duplicated ==      ;; Insert this run into the tasks queue
;;      ;; == duplicated ==      ;; (open-run-close tasks:add tasks:open-db 
;;      ;; == duplicated ==      ;;    	     "runtests" 
;;      ;; == duplicated ==      ;;    	     user
;;      ;; == duplicated ==      ;;    	     target
;;      ;; == duplicated ==      ;;    	     runname
;;      ;; == duplicated ==      ;;    	     (args:get-arg "-runtests")
;;      ;; == duplicated ==      ;;    	     #f))))
;;      ;; == duplicated ==      (runs:run-tests target
;;      ;; == duplicated == 		     runname
;;      ;; == duplicated == 		     (common:args-get-testpatt #f) ;; (args:get-arg "-runtests")
;;      ;; == duplicated == 		     user
;;      ;; == duplicated == 		     args:arg-hash))))
;;      
;;      ;;======================================================================
;;      ;; Rollup into a run
;;      ;;======================================================================
;;      
;;      ;; (if (args:get-arg "-rollup")
;;      ;;     (general-run-call 
;;      ;;      "-rollup" 
;;      ;;      "rollup tests" 
;;      ;;      (lambda (target runname keys keyvals)
;;      ;;        (runs:rollup-run keys
;;      ;; 			keyvals
;;      ;; 			(or (args:get-arg "-runname")(args:get-arg ":runname") )
;;      ;; 			user))))
;;      
;;      ;;======================================================================
;;      ;; Lock or unlock a run
;;      ;;======================================================================
;;      
;;      (if (or (args:get-arg "-lock")(args:get-arg "-unlock"))
;;          (general-run-call 
;;           (if (args:get-arg "-lock") "-lock" "-unlock")
;;           "lock/unlock tests" 
;;           (lambda (target runname keys keyvals)
;;             (runs:handle-locking 
;;      		  target
;;      		  keys
;;      		  (or (args:get-arg "-runname")(args:get-arg ":runname") )
;;      		  (args:get-arg "-lock")
;;      		  (args:get-arg "-unlock")
;;      		  (bdat-user *bdat*)))))
;;      
;;      ;;======================================================================
;;      ;; Get paths to tests
;;      ;;======================================================================
;;      ;; Get test paths matching target, runname, and testpatt
;;      (if (or (args:get-arg "-test-files")(args:get-arg "-test-paths"))
;;          ;; if we are in a test use the MT_CMDINFO data
;;          (if (get-environment-variable "MT_CMDINFO")
;;      	(let* ((startingdir (current-directory))
;;      	       (cmdinfo   (common:read-encoded-string (get-environment-variable "MT_CMDINFO")))
;;      	       (transport (assoc/default 'transport cmdinfo))
;;      	       (testpath  (assoc/default 'testpath  cmdinfo))
;;      	       (test-name (assoc/default 'test-name cmdinfo))
;;      	       (runscript (assoc/default 'runscript cmdinfo))
;;      	       (db-host   (assoc/default 'db-host   cmdinfo))
;;      	       (run-id    (assoc/default 'run-id    cmdinfo))
;;      	       (itemdat   (assoc/default 'itemdat   cmdinfo))
;;      	       (state     (args:get-arg ":state"))
;;      	       (status    (args:get-arg ":status"))
;;      	       ;;(target    (args:get-arg "-target"))
;;      	       (target    (common:args-get-target))
;;      	       (toppath   (assoc/default 'toppath   cmdinfo)))
;;      	  (change-directory toppath)
;;      	  (if (not target)
;;      	      (begin
;;      		(debug:print-error 0 *default-log-port* "-target is required.")
;;      		(exit 1)))
;;      	  (if (not (launch:setup))
;;      	      (begin
;;      		(debug:print 0 *default-log-port* "Failed to setup, giving up on -test-paths or -test-files, exiting")
;;      		(exit 1)))
;;      	  (let* ((keys     (rmt:get-keys))
;;      		 ;; db:test-get-paths must not be run remote
;;      		 (paths    (tests:test-get-paths-matching keys target (args:get-arg "-test-files"))))
;;      	    (set! *didsomething* #t)
;;      	    (for-each (lambda (path)
;;      			(if (common:file-exists? path)
;;      			(print path)))	
;;      		      paths)))
;;      	;; else do a general-run-call
;;      	(general-run-call 
;;      	 "-test-files"
;;      	 "Get paths to test"
;;      	 (lambda (target runname keys keyvals)
;;      	   (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))))))
;;      
;;      ;;======================================================================
;;      ;; 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:get-db-tmp-area) (> (length (directory   (common:get-db-tmp-area) #f)) 0))
;;                 (begin
;;                 (debug:print-info 1 *default-log-port* (common:get-db-tmp-area) " 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")))
;;                    (if  (common:directory-exists? src)
;;                        (begin 
;;                        (archive:restore-db src ts)
;;                  (set! *didsomething* #t))
;;             (begin
;;               (debug:print-error 1 *default-log-port* "Path " source " not found")
;;               (exit 1))))))   
;;          ;; else do a general-run-call
;;         (if (and (args:get-arg "-archive") (not (equal? (args:get-arg "-archive") "replicate-db"))) 
;;          (begin
;;            ;; for the archive get we need to preserve the starting dir as part of the target path
;;            (if (and (args:get-arg "-dest")
;;      	       (not (equal? (substring (args:get-arg "-dest") 0 1) "/")))
;;      	  (let ((newpath  (conc (current-directory) "/" (args:get-arg "-dest"))))
;;      	    (debug:print-info 1 *default-log-port* "Preserving original path to destination, was " (args:get-arg "-dest") ", now " newpath)
;;      	    (hash-table-set! args:arg-hash "-dest" newpath)))
;;            (general-run-call 
;;             "-archive"
;;             "Archive"
;;             (lambda (target runname keys keyvals)
;;      	 (operate-on 'archive target-in: target runname-in: runname )))))
;;      
;;      ;;======================================================================
;;      ;; Extract a spreadsheet from the runs database
;;      ;;======================================================================
;; 
;; ;; TODO: Reenable this functionality
;; 
;;      #;(if (args:get-arg "-extract-ods")
;;          (general-run-call
;;           "-extract-ods"
;;           "Make ods spreadsheet"
;;           (lambda (target runname keys keyvals)
;;             (let ((dbstruct   (make-dbr:dbstruct path: *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)
;;      	 (set! *didsomething* #t)))))
;;      
;;      ;;======================================================================
;;      ;; execute the test
;;      ;;    - gets called on remote host
;;      ;;    - receives info from the -execute param
;;      ;;    - passes info to steps via MT_CMDINFO env var (future is to use a dot file)
;;      ;;    - gathers host info and 
;;      ;;======================================================================
;;      
;;      (if (args:get-arg "-execute")
;;          (begin
;;            (launch:execute (args:get-arg "-execute"))
;;            (set! *didsomething* #t)))
;;      
;;      ;;======================================================================
;;      ;; recover from a test where the managing mtest was killed but the underlying
;;      ;; process might still be salvageable
;;      ;;======================================================================
;;      
;;      (if (args:get-arg "-recover-test")
;;          (let* ((params (string-split (args:get-arg "-recover-test") ",")))
;;            (if (> (length params) 1) ;; run-id and test-id
;;      	  (let ((run-id (string->number (car params)))
;;      		(test-id (string->number (cadr params))))
;;      	    (if (and run-id test-id)
;;      		(begin
;;      		  (launch:recover-test run-id test-id)
;;      		  (set! *didsomething* #t))
;;      		(begin
;;      		  (debug:print-error 0 *default-log-port* "bad run-id or test-id, must be integers")
;;      		  (exit 1)))))))
;;      
;;   (if (args:get-arg "-step")
;;       (begin
;;            (thread-sleep! 1.5)
;;            (megatest:step 
;;             (args:get-arg "-step")
;;             (or (args:get-arg "-state")(args:get-arg ":state"))
;;             (or (args:get-arg "-status")(args:get-arg ":status"))
;;             (args:get-arg "-setlog")
;;             (args:get-arg "-m"))
;;            ;; (if db (sqlite3:finalize! db))
;;            (set! *didsomething* #t)
;;            (thread-sleep! 1.5)))
;;          
;;      (if (or (args:get-arg "-setlog")       ;; since setting up is so costly lets piggyback on -test-status
;;      	;;     (not (args:get-arg "-step")))  ;; -setlog may have been processed already in the "-step" previous
;;      	;;     NEW POLICY - -setlog sets test overall log on every call.
;;      	(args:get-arg "-set-toplog")
;;      	(args:get-arg "-test-status")
;;      	(args:get-arg "-set-values")
;;      	(args:get-arg "-load-test-data")
;;      	(args:get-arg "-runstep")
;;      	(args:get-arg "-summarize-items"))
;;          (if (not (get-environment-variable "MT_CMDINFO"))
;;      	(begin
;;      	  (debug:print-error 0 *default-log-port* "MT_CMDINFO env var not set, commands -test-status, -runstep and -setlog must be called *inside* a megatest environment!")
;;      	  (exit 5))
;;      	(let* ((startingdir (current-directory))
;;      	       (cmdinfo   (common:read-encoded-string (get-environment-variable "MT_CMDINFO")))
;;      	       (transport (assoc/default 'transport cmdinfo))
;;      	       (testpath  (assoc/default 'testpath  cmdinfo))
;;      	       (test-name (assoc/default 'test-name cmdinfo))
;;      	       (runscript (assoc/default 'runscript cmdinfo))
;;      	       (db-host   (assoc/default 'db-host   cmdinfo))
;;      	       (run-id    (assoc/default 'run-id    cmdinfo))
;;      	       (test-id   (assoc/default 'test-id   cmdinfo))
;;      	       (itemdat   (assoc/default 'itemdat   cmdinfo))
;;      	       (work-area (assoc/default 'work-area cmdinfo))
;;      	       (db        #f) ;; (open-db))
;;      	       (state     (args:get-arg ":state"))
;;      	       (status    (args:get-arg ":status"))
;;      	       (stepname  (args:get-arg "-step")))
;;      	  (if (not (launch:setup))
;;      	      (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
;;      	  ;; (client:setup)
;;      
;;      	  (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")))
;;      		(rmt:test-set-log! run-id test-id logfname)))
;;      	  (if (args:get-arg "-set-toplog")
;;      	      ;; DO NOT run remote
;;      	      (tests:test-set-toplog! run-id test-name (args:get-arg "-set-toplog")))
;;      	  (if (args:get-arg "-summarize-items")
;;      	      ;; DO NOT run remote
;;      	      (tests:summarize-items run-id test-id test-name #t)) ;; do force here
;;      	  (if (args:get-arg "-runstep")
;;      	      (if (null? remargs)
;;      		  (begin
;;      		    (debug:print-error 0 *default-log-port* "nothing specified to run!")
;;      		    (if db (sqlite3:finalize! db))
;;      		    (exit 6))
;;      		  (let* ((stepname   (args:get-arg "-runstep"))
;;      			 (logprofile (args:get-arg "-logpro"))
;;      			 (logfile    (conc stepname ".log"))
;;      			 (cmd        (if (null? remargs) #f (car remargs)))
;;      			 (params     (if cmd (cdr remargs) '()))
;;      			 (exitstat   #f)
;;      			 (shell      (let ((sh (get-environment-variable "SHELL") ))
;;      				       (if sh 
;;      					   (last (string-split sh "/"))
;;      					   "bash")))
;;      			 (redir      (case (string->symbol shell)
;;      				       ((tcsh csh ksh)    ">&")
;;      				       ((zsh bash sh ash) "2>&1 >")
;;      				       (else ">&")))
;;      			 (fullcmd    (conc "(" (string-intersperse 
;;      						(cons cmd params) " ")
;;      					   ") " redir " " logfile)))
;;      		    ;; mark the start of the test
;;      		    (rmt:teststep-set-status! run-id test-id stepname "start" "n/a" (args:get-arg "-m") logfile)
;;      		    ;; run the test step
;;      		    (debug:print-info 2 *default-log-port* "Running \"" fullcmd "\" in directory \"" startingdir)
;;      		    (change-directory startingdir)
;;      		    (set! exitstat (system fullcmd))
;;      		    (set! *globalexitstatus* exitstat)
;;      		    ;; (change-directory testpath)
;;      		    ;; run logpro if applicable ;; (process-run "ls" (list "/foo" "2>&1" "blah.log"))
;;      		    (if logprofile
;;      			(let* ((htmllogfile (conc stepname ".html"))
;;      			       (oldexitstat exitstat)
;;      			       (cmd         (string-intersperse (list "logpro" logprofile htmllogfile "<" logfile ">" (conc stepname "_logpro.log")) " ")))
;;      			  (debug:print-info 2 *default-log-port* "running \"" cmd "\"")
;;      			  (change-directory startingdir)
;;      			  (set! exitstat (system cmd))
;;      			  (set! *globalexitstatus* exitstat) ;; no necessary
;;      			  (change-directory testpath)
;;      			  (rmt:test-set-log! run-id test-id htmllogfile)))
;;      		    (let ((msg (args:get-arg "-m")))
;;      		      (rmt:teststep-set-status! run-id test-id stepname "end" exitstat msg logfile))
;;      		    )))
;;      	  (if (or (args:get-arg "-test-status")
;;      		  (args:get-arg "-set-values"))
;;      	      (let ((newstatus (cond
;;      				((number? status)       (if (equal? status 0) "PASS" "FAIL"))
;;      				((and (string? status)
;;      				      (string->number status))(if (equal? (string->number status) 0) "PASS" "FAIL"))
;;      				(else status)))
;;      		    ;; transfer relevant keys into a hash to be passed to test-set-status!
;;      		    ;; could use an assoc list I guess. 
;;      		    (otherdata (let ((res (make-hash-table)))
;;      				 (for-each (lambda (key)
;;      					     (if (args:get-arg key)
;;      						 (hash-table-set! res key (args:get-arg key))))
;;      					   (list ":value" ":tol" ":expected" ":first_err" ":first_warn" ":units" ":category" ":variable"))
;;      				 res)))
;;      		(if (and (args:get-arg "-test-status")
;;      			 (or (not state)
;;      			     (not status)))
;;      		    (begin
;;      		      (debug:print-error 0 *default-log-port* "You must specify :state and :status with every call to -test-status\n" help)
;;      		      (if (sqlite3:database? db)(sqlite3:finalize! db))
;;      		      (exit 6)))
;;      		(let* ((msg    (args:get-arg "-m"))
;;      		       (numoth (length (hash-table-keys otherdata))))
;;      		  ;; Convert to rpc inside the tests:test-set-status! call, not here
;;      		  (tests:test-set-status! run-id test-id state newstatus msg otherdata work-area: work-area))))
;;      	  (if (sqlite3:database? db)(sqlite3:finalize! db))
;;      	  (set! *didsomething* #t))))
;;      
;;      ;;======================================================================
;;      ;; Various helper commands can go below here
;;      ;;======================================================================
;;      
;;      (if (or (args:get-arg "-showkeys")
;;              (args:get-arg "-show-keys"))
;;          (let ((db #f)
;;      	  (keys #f))
;;            (if (not (launch:setup))
;;      	  (begin
;;      	    (debug:print 0 *default-log-port* "Failed to setup, exiting")
;;      	    (exit 1)))
;;            (set! keys (rmt:get-keys)) ;;  db))
;;            (debug:print 1 *default-log-port* "Keys: " (string-intersperse keys ", "))
;;            (if (sqlite3:database? db)(sqlite3:finalize! db))
;;            (set! *didsomething* #t)))
;;      
;;      (if (args:get-arg "-gui")
;;          (begin
;;            (debug:print 0 *default-log-port* "Look at the dashboard for now")
;;            ;; (megatest-gui)
;;            (set! *didsomething* #t)))
;;      
;;      (if (args:get-arg "-create-megatest-area")
;;          (begin
;;            (genexample:mk-megatest.config)
;;            (set! *didsomething* #t)))
;;      
;;      (if (args:get-arg "-create-test")
;;          (let ((testname (args:get-arg "-create-test")))
;;            (genexample:mk-megatest-test testname)
;;            (set! *didsomething* #t)))
;;      
;;      ;;======================================================================
;;      ;; Update the database schema, clean up the db
;;      ;;======================================================================
;; 
;; ;; TODO: Restore this functionality
;; 
;;       #;(if (args:get-arg "-rebuild-db")
;;          (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 ((dbstruct (db:setup #f areapath: *toppath*)))
;;              (common:cleanup-db dbstruct 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)))
;;            (let ((dbstruct (db:setup #f areapath: *toppath*)))
;;              (common:cleanup-db dbstruct))
;;            (set! *didsomething* #t)))
;;      
;;      (if (args:get-arg "-mark-incompletes")
;;          (begin
;;            (if (not (launch:setup))
;;      	  (begin
;;      	    (debug:print 0 *default-log-port* "Failed to setup, exiting")
;;      	    (exit 1)))
;;            (runs:find-and-mark-incomplete-and-check-end-of-run #f)
;;            (set! *didsomething* #t)))
;;      
;;      ;;======================================================================
;;      ;; Update the tests meta data from the testconfig files
;;      ;;======================================================================
;;      
;;      (if (args:get-arg "-update-meta")
;;          (begin
;;            (if (not (launch:setup))
;;      	  (begin
;;      	    (debug:print 0 *default-log-port* "Failed to setup, exiting") 
;;      	    (exit 1)))
;;            (runs:update-all-test_meta #f)
;;            (set! *didsomething* #t)))
;;      
;;      ;;======================================================================
;;      ;; Start a repl
;;      ;;======================================================================
;;      
;;      ;; fakeout readline
;;      ;; (include "readline-fix.scm")
;;      
;;      
;;      (when (args:get-arg "-diff-rep")
;;        (when (and
;;               (not (args:get-arg "-diff-html"))
;;               (not (args:get-arg "-diff-email")))
;;          (debug:print 0 *default-log-port* "Must specify -diff-html or -diff-email with -diff-rep")
;;          (set! *didsomething* 1)
;;          (exit 1))
;;        
;;        (let* ((toppath (launch:setup)))
;;          (do-diff-report
;;           (args:get-arg "-src-target")
;;           (args:get-arg "-src-runname")
;;           (args:get-arg "-target")
;;           (args:get-arg "-runname")
;;           (args:get-arg "-diff-html")
;;           (args:get-arg "-diff-email"))
;;          (set! *didsomething* #t)
;;          (exit 0)))
;;      
;;      (if (or (get-environment-variable "MT_RUNSCRIPT")
;;      	(args:get-arg "-repl")
;;      	(args:get-arg "-load"))
;;          (let* ((toppath (launch:setup)))
;; 		
;;      	        ;; (dbstruct (if (and toppath
;; 		;; 	      #;(common:on-homehost?))
;; 		;; 	 (db:setup #f) ;; sets up main.db
;; 		;; 	 #f))) ;; make-dbr:dbstruct path: toppath local: (args:get-arg "-local")) #f)))
;; 	   (if *toppath*
;; 	       (cond
;; 		((get-environment-variable "MT_RUNSCRIPT")
;; 		 ;; How to run megatest scripts
;; 		 ;;
;; 		 ;; #!/bin/bash
;; 		 ;;
;; 		 ;; export MT_RUNSCRIPT=yes
;; 		 ;; megatest << EOF
;; 		 ;; (print "Hello world")
;; 		 ;; (exit)
;; 		 ;; EOF
;; 		 
;; 		 (repl))
;; 		(else
;; 		 (begin
;; 		   ;; (set! *db* dbstruct)
;; 		   ;; (import extras) ;; might not be needed
;; 		   ;; (import chicken.csi)
;; 		   ;; (import readline)
;; 		   #;(import apropos
;; 			   archivemod
;; 			   commonmod
;; 			   configfmod
;; 			   dbmod
;; 			   debugprint
;; 			   ezstepsmod
;; 			   launchmod
;; 			   processmod
;; 			   rmtmod
;; 			   runsmod
;; 			   servermod
;; 			   tasksmod
;; 			   testsmod)
;; 		   
;; 		   (set-history-length! 300)
;; 		   (load-history-from-file ".megatest_history")
;; 		   (current-input-port (make-linenoise-port))
;; 		   ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ...
;; 		   
;; 		   ;; (if *use-new-readline*
;; 		   ;; 	  (begin
;; 		   ;; 	    (install-history-file (get-environment-variable "HOME") ".megatest_history") ;;  [homedir] [filename] [nlines])
;; 		   ;; 	    (current-input-port (make-readline-port "megatest> ")))
;; 		   ;; 	  (begin
;; 		   ;; 	    (gnu-history-install-file-manager
;; 		   ;; 	     (string-append
;; 		   ;; 	      (or (get-environment-variable "HOME") ".") "/.megatest_history"))
;; 		   ;; 	    (current-input-port (make-gnu-readline-port "megatest> "))))
;; 		   (if (args:get-arg "-repl")
;; 		       (repl)
;; 		       (load (args:get-arg "-load")))
;; 		   ;; (db:close-all dbstruct) <= taken care of by on-exit call
;; 		   )
;; 		 (exit)))
;; 	       (set! *didsomething* #t))))
;;      
;;      ;;======================================================================
;;      ;; Wait on a run to complete
;;      ;;======================================================================
;;      
;;      (if (and (args:get-arg "-run-wait")
;;      	 (not (or (args:get-arg "-run")
;;      		  (args:get-arg "-runtests")))) ;; run-wait is built into runtests now
;;          (begin
;;            (if (not (launch:setup))
;;      	  (begin
;;      	    (debug:print 0 *default-log-port* "Failed to setup, exiting") 
;;      	    (exit 1)))
;;            (operate-on 'run-wait)
;;            (set! *didsomething* #t)))
;;      
;;      ;; ;; ;; redo me ;; Not converted to use dbstruct yet
;;      ;; ;; ;; redo me ;;
;;      ;; ;; ;; redo me (if (args:get-arg "-convert-to-norm")
;;      ;; ;; ;; redo me     (let* ((toppath (setup-for-run))
;;      ;; ;; ;; redo me 	   (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t))))
;;      ;; ;; ;; redo me       (for-each 
;;      ;; ;; ;; redo me        (lambda (field)
;;      ;; ;; ;; redo me 	 (let ((dat '()))
;;      ;; ;; ;; redo me 	   (debug:print-info 0 *default-log-port* "Getting data for field " field)
;;      ;; ;; ;; redo me 	   (sqlite3:for-each-row
;;      ;; ;; ;; redo me 	    (lambda (id val)
;;      ;; ;; ;; redo me 	      (set! dat (cons (list id val) dat)))
;;      ;; ;; ;; redo me 	    (db:get-db db run-id)
;;      ;; ;; ;; redo me 	    (conc "SELECT id," field " FROM tests;"))
;;      ;; ;; ;; redo me 	   (debug:print-info 0 *default-log-port* "found " (length dat) " items for field " field)
;;      ;; ;; ;; redo me 	   (let ((qry (sqlite3:prepare db (conc "UPDATE tests SET " field "=? WHERE id=?;"))))
;;      ;; ;; ;; redo me 	     (for-each
;;      ;; ;; ;; redo me 	      (lambda (item)
;;      ;; ;; ;; redo me 		(let ((newval ;; (sdb:qry 'getid 
;;      ;; ;; ;; redo me 		       (cadr item))) ;; )
;;      ;; ;; ;; redo me 		  (if (not (equal? newval (cadr item)))
;;      ;; ;; ;; redo me 		      (debug:print-info 0 *default-log-port* "Converting " (cadr item) " to " newval " for test #" (car item)))
;;      ;; ;; ;; redo me 		  (sqlite3:execute qry newval (car item))))
;;      ;; ;; ;; redo me 	      dat)
;;      ;; ;; ;; redo me 	     (sqlite3:finalize! qry))))
;;      ;; ;; ;; redo me        (db:close-all dbstruct)
;;      ;; ;; ;; redo me        (list "uname" "rundir" "final_logf" "comment"))
;;      ;; ;; ;; redo me       (set! *didsomething* #t)))
;; 
;; ;; TODO: restore this functionality
;; 
;;      #;(if (args:get-arg "-import-megatest.db")
;;          (begin
;;            (db:multi-db-sync 
;;             (db:setup #f)
;;             'killservers
;;             'dejunk
;;             'adj-testids
;;             'old2new
;;             ;; 'new2old
;;             )
;;            (set! *didsomething* #t)))
;;      
;;      #;(when (args:get-arg "-sync-brute-force")
;;        ((server:get-bruteforce-syncer (db:setup #t) persist-until-sync: #t))
;;        (set! *didsomething* #t))
;;      
;;      #;(if (args:get-arg "-sync-to-megatest.db")
;;          (let* ((dbstruct (db:setup #f))
;;      	   (tmpdbpth (cdr (dbr:dbstruct-tmpdb 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)
;;      	    (print "Synced " res " records to megatest.db"))
;;      	  (print "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)))
;;      
;;      (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))) 
;;           (task:get-run-times)  
;;           (set! *didsomething* #t)))
;;           
;;      (if (args:get-arg "-generate-html")
;;          (let* ((toppath (launch:setup)))
;;            (if (tests:create-html-tree #f)
;;                (debug:print-info 0 *default-log-port* "HTML output created in " toppath "/lt/page0.html")
;;                (debug:print 0 *default-log-port* "Failed to create HTML output in " toppath "/lt/runs-index.html"))
;;            (set! *didsomething* #t)))
;;      
;;      (if (args:get-arg "-generate-html-structure")
;;          (let* ((toppath (launch:setup)))
;;            ;(if (tests:create-html-tree #f)
;;       				(if (tests:create-html-summary #f)
;;                (debug:print-info 0 *default-log-port* "HTML output created in " toppath "/lt/targets.html")
;;                (debug:print 0 *default-log-port* "Failed to create HTML output in " toppath "/lt/runs-index.html"))
;;            (set! *didsomething* #t)))
;;      
;;      (if (args:get-arg "-syscheck")
;;          (begin
;;            (mutils:syscheck common:raw-get-remote-host-load
;;      		       server:get-best-guess-address
;;      		       configf:read-config)
;;            (set! *didsomething* #t)))
;;      
;;      (if (args:get-arg "-extract-skeleton")
;;          (let* ((toppath (launch:setup)))
;;            (genexample:extract-skeleton-area (args:get-arg "-extract-skeleton"))
;;            (set! *didsomething* #t)))
;;      
;;      ;;======================================================================
;;      ;; Exit and clean up
;;      ;;======================================================================
;;      
;;      (if (not *didsomething*)
;;          (debug:print 0 *default-log-port* help)
;;          (bdat-time-to-exit-set! *bdat* #t)
;;          )
;;      ;;(debug:print-info 13 *default-log-port* "thread-join! watchdog")
;;      
;;      ;; join the watchdog thread if it has been thread-start!ed  (it may not have been started in the case of a server that never enters running state)
;;      ;;   (symbols returned by thread-state: created ready running blocked suspended sleeping terminated dead)
;;      ;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage
;;      #;(let* ((watchdog (bdat-watchdog *bdat*)))
;;        (if (thread? watchdog)
;; 	   (case (thread-state watchdog)
;; 	     ((ready running blocked sleeping terminated dead)
;; 	      (thread-join! watchdog)))))
;;      
;;      (bdat-time-to-exit-set! *bdat* #t)
;;      
;;      (if (not (eq? *globalexitstatus* 0))
;;          (if (or (args:get-arg "-run")(args:get-arg "-runtests")(args:get-arg "-runall"))
;;              (begin
;; 	       (debug:print 0 *default-log-port* "NOTE: Subprocesses with non-zero exit code detected: " *globalexitstatus*)
;; 	       (exit 0))
;;              (case *globalexitstatus*
;; 	       ((0)(exit 0))
;; 	       ((1)(exit 1))
;; 	       ((2)(exit 2))
;; 	       (else (exit 3)))))
;;      )
;; 
;; ;; (import megatest-main commonmod)
;; ;; (import srfi-18)

;;======================================================================
;; Copyright 2022, 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 dbmgrmod))

(declare (uses ulex))
(declare (uses apimod))
(declare (uses pkts))
(declare (uses commonmod))
(declare (uses dbmod))
(declare (uses mtargs))
(declare (uses portloggermod))
(declare (uses debugprint))

(module dbmgrmod
    *

(import scheme
	chicken.base
	chicken.condition
	chicken.file
	chicken.format
	chicken.port
	chicken.process
	chicken.process-context
	chicken.process-context.posix
	chicken.sort
	chicken.string
	chicken.time
	
	(prefix sqlite3 sqlite3:)
	matchable
	md5
	message-digest
	regex
	s11n
	srfi-1
	srfi-18
	srfi-69
	system-information
	typed-records
	
	pkts
	ulex

	commonmod
	apimod
	dbmod
	debugprint
	(prefix mtargs args:)
	portloggermod
	)

;; Configurations for server
;; (tcp-buffer-size 2048)
;; (max-connections 2048) 

;; info about me as a listener and my connections to db servers
;; stored (for now) in *db-serv-info*
;;
(defstruct servdat
  (host #f)
  (port #f)
  (uuid #f)
  (dbfile #f)
  (uconn   #f) ;; this is the listener for this process
  (mode    #f)
  (status 'starting)
  (trynum 0) ;; count the number of ports we've tried
  (conns  (make-hash-table)) ;; apath/dbname => conndat
  ) 

(define *db-serv-info* #f)

(define (servdat->url sdat)
  (conc (servdat-host sdat)":"(servdat-port sdat)))

;; db servers contact info
;;
(defstruct conndat
  (apath    #f)
  (dbname   #f)
  (fullname #f)
  (hostport #f)
  (ipaddr   #f)
  (port     #f)
  (srvpkt   #f)
  (srvkey   #f)
  (lastmsg  0)
  (expires  0))

(define *srvpktspec*
  `((server (host    . h)
	    (port    . p)
	    (servkey . k)
	    (pid     . i)
	    (ipaddr  . a)
	    (dbpath  . d))))

;;======================================================================
;;  S U P P O R T   F U N C T I O N S
;;======================================================================

;; set up the api proc, seems like there should be a better place for this?
;;
;; IS THIS NEEDED ANYMORE? TODO - REMOVE IF POSSIBLE
;;
;; (define api-proc (make-parameter conc))
;; (api-proc api:execute-requests)

;; do we have a connection to apath dbname and
;; is it not expired? then return it
;;
;; else setup a connection
;;
;; if that fails, return '(#f "some reason") ;; NB// convert to raising an exception
;;
(define (rmt:get-conn remdat apath dbname)
  (let* ((fullname (db:dbname->path apath dbname)))
    (hash-table-ref/default (servdat-conns remdat) fullname #f)))

(define (rmt:drop-conn remdat apath dbname)
  (let* ((fullname (db:dbname->path apath dbname)))
    (hash-table-delete! (servdat-conns remdat) fullname)))
  
(define (rmt:find-main-server uconn apath dbname)
  (let* ((pktsdir     (get-pkts-dir apath))
	 (all-srvpkts (get-all-server-pkts pktsdir *srvpktspec*))
	 (viable-srvs (get-viable-servers all-srvpkts dbname)))
    (get-the-server uconn apath viable-srvs)))


(define *connstart-mutex* (make-mutex))
(define *last-main-start* 0)

;; looks for a connection to main, returns if have and not exired
;; creates new otherwise
;; 
;; connections for other servers happens by requesting from main
;;
;; TODO: This is unnecessarily re-creating the record in the hash table
;;
(define (rmt:open-main-connection remdat apath)
  (let* ((fullpath (db:dbname->path apath ".db/main.db"))
	 (conns    (servdat-conns remdat))
	 (conn     (rmt:get-conn remdat apath ".db/main.db")) ;; (hash-table-ref/default conns fullpath #f)) ;; TODO - create call for this
	 (myconn   (servdat-uconn remdat)))
    (cond
     ((not myconn)
      (servdat-uconn-set! remdat (make-udat))
      (rmt:open-main-connection remdat apath))
     ((and conn                                             ;; conn is NOT a socket, just saying ...
	   (< (current-seconds) (conndat-expires conn)))
      #t) ;; we are current and good to go - we'll deal elsewhere with a server that was killed or died 
     ((and conn
	   (>= (current-seconds)(conndat-expires conn)))
      (debug:print-info 0 *default-log-port* "connection to "fullpath" server expired. Reconnecting.")
      (rmt:drop-conn remdat apath ".db/main.db") ;;
      (rmt:open-main-connection remdat apath))
     (else
      ;; Below we will find or create and connect to main
      (debug:print-info 0 *default-log-port* "rmt:open-main-connection - starting from scratch")
      (let* ((dbname         (db:run-id->dbname #f))
	     (the-srv        (rmt:find-main-server myconn apath dbname))
	     (start-main-srv (lambda () ;; call IF there is no the-srv found
			       (mutex-lock! *connstart-mutex*)
			       (if (> (- (current-seconds) *last-main-start*) 5) ;; at least four seconds since last attempt to start main server
				   (begin
				     (api:run-server-process apath dbname)
				     (set! *last-main-start* (current-seconds))
				     (thread-sleep! 1))
				   (thread-sleep! 0.25))
			       (mutex-unlock! *connstart-mutex*)
			       (rmt:open-main-connection remdat apath) ;; TODO: Add limit to number of tries
			       )))
	(if (not the-srv) ;; have server, try connecting to it
	    (start-main-srv)
	    (let* ((srv-addr (server-address the-srv)) ;; need serv
		   (ipaddr   (alist-ref 'ipaddr  the-srv))
		   (port     (alist-ref 'port    the-srv))
		   (srvkey   (alist-ref 'servkey the-srv))
		   (fullpath (db:dbname->path apath dbname))
		   
		   (new-the-srv (make-conndat
				 apath:   apath
				 dbname:  dbname
				 fullname: fullpath
				 hostport: srv-addr
				 ;; socket: (open-nn-connection srv-addr)  - TODO - open ulex connection?
				 ipaddr: ipaddr
				 port: port
				 srvpkt: the-srv
				 srvkey: srvkey ;; generated by rmt:get-signature on the server side
				 lastmsg: (current-seconds)
				 expires: (+ (current-seconds)
					     (server:expiration-timeout)
					     -2) ;; this needs to be gathered during the ping
				 )))
	      (hash-table-set! conns fullpath new-the-srv)))
	#t)))))

;; NB// sinfo is a servdat struct
;;
(define (rmt:general-open-connection sinfo apath dbname #!key (num-tries 5))
  (assert (not (equal? dbname ".db/main.db")) "ERROR: general-open-connection should never be called with main as the db")
  (let* ((mdbname  ".db/main.db") ;; (db:run-id->dbname #f)) TODO: put this back to the lookup when stable
	 (fullname (db:dbname->path apath dbname))
	 (conns    (servdat-conns sinfo))
	 (mconn    (rmt:get-conn sinfo apath ".db/main.db"))
	 (dconn    (rmt:get-conn sinfo apath dbname)))
    #;(if (and mconn
	     (not (debug:print-logger)))
	(begin
	  (debug:print-info 0 *default-log-port* "Turning on logging to main, look in logs dir for main log.")
	  (debug:print-logger rmt:log-to-main)))
    (cond
     ((and mconn
	   dconn
	   (< (current-seconds)(conndat-expires dconn)))
      #t) ;; good to go
     ((not mconn) ;; no channel open to main? open it...
      (rmt:open-main-connection sinfo apath)
      (rmt:general-open-connection sinfo apath dbname num-tries: (- num-tries 1)))
     ((not dconn)                 ;; no channel open to dbname?     
      (let* ((res (rmt:send-receive-real sinfo apath mdbname 'get-server `(,apath ,dbname))))
	(case res
	  ((server-started)
	   (if (> num-tries 0)
	       (begin
		 (thread-sleep! 2)
		 (rmt:general-open-connection sinfo apath dbname num-tries: (- num-tries 1)))
	       (begin
		 (debug:print-error 0 *default-log-port* "Failed to start servers needed or open channel to "apath", "dbname)
		 (exit 1))))
	  (else
	   (if (list? res) ;; server has been registered and the info was returned. pass it on.
	       (begin ;;  ("192.168.0.9" 53817
		      ;;  "5e34239f48e8973b3813221e54701a01" "24310"
		      ;;  "192.168.0.9"
		      ;;  "/home/matt/data/megatest/tests/simplerun"
		 ;;  ".db/1.db")
		 (match
		  res
		  ((host port servkey pid ipaddr apath dbname)
		   (debug:print-info 0 *default-log-port* "got "res)
		   (hash-table-set! conns
				    fullname
				    (make-conndat
				     apath: apath
				     dbname: dbname
				     hostport: (conc host":"port)
				     ;; socket: (open-nn-connection (conc host":"port)) ;; TODO - open ulex connection?
				     ipaddr: ipaddr
				     port: port
				     srvkey: servkey
				     lastmsg: (current-seconds)
				     expires: (+ (current-seconds)
						 (server:expiration-timeout)
						 -2))))
		  (else
		   (debug:print-info 0 *default-log-port* "return data from starting server did not match host port servkey pid ipaddr apath dbname " res)))
		 res)
	       (begin
		 (debug:print-info 0 *default-log-port* "Unexpected result: " res)
		 res)))))))
    #t))

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

;; FOR DEBUGGING SET TO #t
;; (define *localmode* #t)
(define *localmode* #f)
(define *dbstruct* (make-dbr:dbstruct))

;; Defaults to current area
;;
(define (rmt:send-receive-attempted-consolidation cmd rid params #!key (attemptnum 1)(area-dat #f))
  (let* ((apath      *toppath*)
	 (sinfo      *db-serv-info*)
	 (dbname     (db:run-id->dbname rid)))
    (if (not *db-serv-info*)
	(begin
	  (set! *db-serv-info* (make-servdat))
	  (set! sinfo *db-serv-info*)))
    (rmt:open-main-connection sinfo apath)
    (if rid (rmt:general-open-connection sinfo apath dbname))
    ;; (if (not (member cmd '(log-to-main)))
    ;;     (debug:print-info 0 *default-log-port* "rmt:send-receive "cmd" params="params))
    (let* ((cdat (rmt:get-conn sinfo apath dbname)))
      (assert cdat "FATAL: rmt:send-receive-real called without the needed channels opened")
      (let* ((uconn    (servdat-uconn sinfo)) ;; get the interface to ulex
	     ;; then send-receive using the ulex layer to host-port stored in cdat
	     (res      (send-receive uconn (conndat-hostport cdat) cmd params)))
	(conndat-expires-set! cdat (+ (current-seconds)
				      (server:expiration-timeout)
				      -2)) ;; two second margin for network time misalignments etc.
	res))))

; Defaults to current area
;;
(define (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f))
  (let* ((apath      *toppath*)
         (sinfo      *db-serv-info*)
         (dbname     (db:run-id->dbname rid)))
    (if (not *db-serv-info*) ;; confirm this is really needed
	(begin
	  (set! *db-serv-info* (make-servdat))
	  (set! sinfo *db-serv-info*)))
    (rmt:open-main-connection sinfo apath)
    (if rid (rmt:general-open-connection sinfo apath dbname))
    #;(if (not (member cmd '(log-to-main)))
    (debug:print-info 0 *default-log-port* "rmt:send-receive "cmd" params="params))
    (rmt:send-receive-real sinfo apath dbname cmd params)))

;; db is at apath/.db/dbname, rid is an intermediary solution and will be removed
;; sometime in the future
;;
(define (rmt:send-receive-real sinfo apath dbname cmd params)
  (let* ((cdat (rmt:get-conn sinfo apath dbname)))
    (assert cdat "FATAL: rmt:send-receive-real called without the needed channels opened")
    (let* ((uconn    (servdat-uconn sinfo)) ;; get the interface to ulex
           ;; then send-receive using the ulex layer to host-port stored in cdat
           (res      (send-receive uconn (conndat-hostport cdat) cmd params)))
      ;; since we accessed the server we can bump the expires time up
      (conndat-expires-set! cdat (+ (current-seconds)
                                    (server:expiration-timeout)
                                    -2)) ;; two second margin for network time misalignments etc.
      res)))

;
;; db is at apath/.db/dbname, rid is an intermediary solution and will be removed
;; sometime in the future.
;;
;; Purpose - call the main.db server and request a server be started
;; for the given area path and dbname
;;

(define (rmt:print-db-stats)
  (let ((fmtstr "~40a~7-d~9-d~20,2-f")) ;; "~20,2-f"
    (debug:print 18 *default-log-port* "DB Stats, "(seconds->year-week/day-time (current-seconds))"\n=====================")
    (debug:print 18 *default-log-port* (format #f "~40a~8a~10a~10a" "Cmd" "Count" "TotTime" "Avg"))
    (for-each (lambda (cmd)
		(let ((cmd-dat (hash-table-ref *db-stats* cmd)))
		  (debug:print 18 *default-log-port* (format #f fmtstr cmd (vector-ref cmd-dat 0) (vector-ref cmd-dat 1) (/ (vector-ref cmd-dat 1)(vector-ref cmd-dat 0))))))
	      (sort (hash-table-keys *db-stats*)
		    (lambda (a b)
		      (> (vector-ref (hash-table-ref *db-stats* a) 0)
			 (vector-ref (hash-table-ref *db-stats* b) 0)))))))

(define (rmt:get-max-query-average run-id)
  (mutex-lock! *db-stats-mutex*)
  (let* ((runkey (conc "run-id=" run-id " "))
	 (cmds   (filter (lambda (x)
			   (substring-index runkey x))
			 (hash-table-keys *db-stats*)))
	 (res    (if (null? cmds)
		     (cons 'none 0)
		     (let loop ((cmd (car cmds))
				(tal (cdr cmds))
				(max-cmd (car cmds))
				(res 0))
		       (let* ((cmd-dat (hash-table-ref *db-stats* cmd))
			      (tot     (vector-ref cmd-dat 0))
			      (curravg (/ (vector-ref cmd-dat 1) (vector-ref cmd-dat 0))) ;; count is never zero by construction
			      (currmax (max res curravg))
			      (newmax-cmd (if (> curravg res) cmd max-cmd)))
			 (if (null? tal)
			     (if (> tot 10)
				 (cons newmax-cmd currmax)
				 (cons 'none 0))
			     (loop (car tal)(cdr tal) newmax-cmd currmax)))))))
    (mutex-unlock! *db-stats-mutex*)
    res))

;; host and port are used to ensure we are remove proper records
(define (rmt:server-shutdown host port)
  (let ((dbfile   (servdat-dbfile *db-serv-info*)))
    (debug:print-info 0 *default-log-port* "dbfile is "dbfile)
    (if dbfile
	(let* ((am-server  (args:get-arg "-server"))
	       (dbfile     (args:get-arg "-db"))
	       (apath      *toppath*)
	       #;(sinfo     *remotedat*)) ;; foundation for future fix
	  (if *dbstruct-db*
	      (let* ((dbdat      (db:get-dbdat *dbstruct-db* apath dbfile))
		     (db         (dbr:dbdat-db dbdat))
		     (inmem      (dbr:dbdat-db dbdat))   ;; WRONG
		     )
		;; do a final sync here
		(debug:print-info 0 *default-log-port* "Doing final sync for "apath" "dbfile" at "(current-seconds))
		(db:sync-inmem->disk *dbstruct-db* apath dbfile force-sync: #t)
		;; let's finalize here
		(debug:print-info 0 *default-log-port* "Finalizing db and inmem")
		(if (sqlite3:database? db)
		    (sqlite3:finalize! db)
		    (debug:print-info 0 *default-log-port* "in rmt:server-shutdown, db is not a database, not finalizing..."))
		(if (sqlite3:database? inmem)
		    (sqlite3:finalize! inmem)
		    (debug:print-info 0 *default-log-port* "in rmt:server-shutdown, inmem is not a database, not finalizing..."))
		(debug:print-info 0 *default-log-port* "Finalizing db and inmem complete"))
	      (debug:print-info 0 *default-log-port* "Db was never opened, no cleanup to do."))
	  (if (not am-server)
	      (debug:print-info 0 *default-log-port* "I am not a server, should NOT get here!")
	      (if (string-match ".*/main.db$" dbfile)
		  (let ((pkt-file (conc (get-pkts-dir *toppath*)
					"/" (servdat-uuid *db-serv-info*)
					".pkt")))
		    (debug:print-info 0 *default-log-port* "removing pkt "pkt-file)
		    (delete-file* pkt-file)
		    (debug:print-info 0 *default-log-port* "Releasing lock (if any) for "dbfile ", host "host", port "port)
		    (db:with-lock-db
		     (servdat-dbfile *db-serv-info*)
		     (lambda (dbh dbfile)
		       (db:release-lock dbh dbfile host port)))) ;; I'm not the server - should not have a lock to remove
		  (let* ((sdat *db-serv-info*) ;; we have a run-id server
			 (host (servdat-host sdat))
			 (port (servdat-port sdat))
			 (uuid (servdat-uuid sdat))
			 (res  (rmt:deregister-server *db-serv-info* *toppath* host port uuid dbfile)))
		    (debug:print-info 0 *default-log-port* "deregistered-server, res="res)
		    (debug:print-info 0 *default-log-port* "deregistering server "host":"port" with uuid "uuid)
		    )))))))


(define (common:run-sync?)
    ;; (and (common:on-homehost?)
  (args:get-arg "-server"))

(define *rmt:run-mutex* (make-mutex))
(define *rmt:run-flag* #f)

(define (listener-running?)
  (and *db-serv-info*
       (servdat-uconn *db-serv-info*)))

;; Main entry point to start a server. was start-server
(define (rmt:run hostn)
  (mutex-lock! *rmt:run-mutex*)
  (if *rmt:run-flag*
      (begin
	(debug:print-warn 0 *default-log-port* "rmt:run already running.")
	(mutex-unlock! *rmt:run-mutex*))
      (begin
	(set! *rmt:run-flag* #t)
	(mutex-unlock! *rmt:run-mutex*)
	;;  ;; Configurations for server
	;;  (tcp-buffer-size 2048)
	;;  (max-connections 2048) 
	(debug:print 2 *default-log-port* "PID: "(current-process-id)". Attempting to start the server ...")
	(if (listener-running?)
	    (let* ((uconn (servdat-uconn *db-serv-info*)))
	      (wait-and-close uconn))
	    (let* ((port            (portlogger:open-run-close portlogger:find-port))
		   (handler-proc    (lambda (rem-host-port qrykey cmd params) ;;
				      (set! *db-last-access* (current-seconds))
				      (assert (list? params) "FATAL: handler called with non-list params")
				      (assert (args:get-arg "-server") "FATAL: handler called on non-server side. cmd="cmd", params="params)
				      (debug:print 0 *default-log-port* "handler call: "cmd", params="params)
				      (api:execute-requests *dbstruct-db* cmd params))))
	      ;; (api:process-request *dbstuct-db* 
	      (if (not *db-serv-info*)
		  (set! *db-serv-info* (make-servdat host: hostn port: port)))
	      (let* ((uconn (run-listener handler-proc port))
		     (rport (udat-port uconn))) ;; the real port
		(servdat-host-set! *db-serv-info* hostn)
		(servdat-port-set! *db-serv-info* rport)
		(servdat-uconn-set! *db-serv-info* uconn)
		(wait-and-close uconn)
		(db:print-current-query-stats)
		)))
	(let* ((host (servdat-host *db-serv-info*))
	       (port (servdat-port *db-serv-info*))
	       (mode (or (servdat-mode *db-serv-info*)
			 "non-db")))
	  ;; server exit stuff here
	  ;; (rmt:server-shutdown host port) - always do in on-exit
	  ;; (portlogger:open-run-close portlogger:set-port port "released") ;; moved to on-exit 
	  (debug:print-info 0 *default-log-port* "Server "host":"port" mode "mode"shutdown complete. Exiting")
	  ))))

;;======================================================================
;; S E R V E R   U T I L I T I E S 
;;======================================================================


;;======================================================================
;; NEW SERVER METHOD
;;======================================================================

;; only use for main.db - need to re-write some of this :(
;;
(define (get-lock-db sdat dbfile host port)
  (assert host "FATAL: get-lock-db called with host not set.")
  (assert port "FATAL: get-lock-db called with port not set.")
  (let* ((dbh (db:open-run-db dbfile db:initialize-db)) ;; open-run-db creates a standard db with schema used by all situations
	 (res (db:get-iam-server-lock dbh dbfile host port))
	 (uconn (servdat-uconn sdat)))
    ;; res => list then already locked, check server is responsive
    ;;     => #t then sucessfully got the lock
    ;;     => #f reserved for future use as to indicate something went wrong
    (match res
      ((owner_pid owner_host owner_port event_time)
       (if (server-ready? uconn (conc owner_host":"owner_port) "abc")
	   #f      ;; locked by someone else
	   (begin  ;; locked by someone dead and gone
	     (debug:print 0 *default-log-port* "WARNING: stale lock - have to steal it. This may fail.")
	     (db:steal-lock-db dbh dbfile port))))
      (#t  #t) ;; placeholder so that we don't touch res if it is #t
      (else (set! res #f)))
    (sqlite3:finalize! dbh)
    res))


(define (register-server pkts-dir pkt-spec host port servkey ipaddr dbpath)
  (let* ((pkt-dat `((host    . ,host)
		    (port    . ,port)
		    (servkey . ,servkey)
		    (pid     . ,(current-process-id))
		    (ipaddr  . ,ipaddr)
		    (dbpath  . ,dbpath)))
	 (uuid    (write-alist->pkt
		   pkts-dir
		   pkt-dat
		   pktspec: pkt-spec
		   ptype: 'server)))
    (debug:print 0 *default-log-port* "Server on "host":"port" registered in pkt "uuid)
    uuid))

(define (get-pkts-dir #!optional (apath #f))
  (let* ((effective-toppath (or *toppath* apath)))
    (assert effective-toppath
	    "ERROR: get-pkts-dir called without *toppath* set. Exiting.")
    (let* ((pdir (conc effective-toppath "/.meta/srvpkts")))
      (if (file-exists? pdir)
	  pdir
	  (begin
	    (handle-exceptions ;; this exception handler should NOT be needed but ...
		exn
		pdir
	      (create-directory pdir #t))
	    pdir)))))

;; given a pkts dir read 
;;
(define (get-all-server-pkts pktsdir-in pktspec)
  (let* ((pktsdir  (if (file-exists? pktsdir-in)
		       pktsdir-in
		       (begin
			 (create-directory pktsdir-in #t)
			 pktsdir-in)))
	 (all-pkt-files (glob (conc pktsdir "/*.pkt"))))
    (map (lambda (pkt-file)
	   (read-pkt->alist pkt-file pktspec: pktspec))
	 all-pkt-files)))

(define (server-address srv-pkt)
  (conc (alist-ref 'host srv-pkt) ":"
	(alist-ref 'port srv-pkt)))
	
(define (server-ready? uconn host-port key) ;; server-address is host:port
  (let* ((params `((cmd . ping)(key . ,key)))
	 (data `((cmd . ping)
		 (key . ,key)
		 (params . ,params))) ;; I don't get it.
	 (res  (send-receive uconn host-port 'ping data)))
    (if (eq? res 'ping-ack) ;; yep, likely it is who we want on the other end
	res
	#f)))
;; (begin (debug:print-info 0 *default-log-port* "server-ready? => "res) #f))))

; from the pkts return servers associated with dbpath
;; NOTE: Only one can be alive - have to check on each
;;       in the list of pkts returned
;;
(define (get-viable-servers serv-pkts dbpath)
  (let loop ((tail serv-pkts)
	     (res  '()))
    (if (null? tail)
	res ;; NOTE: sort by age so oldest is considered first
	(let* ((spkt (car tail)))
	  (loop (cdr tail)
		(if (equal? dbpath (alist-ref 'dbpath spkt))
		    (cons spkt res)
		    res))))))

(define (remove-pkts-if-not-alive uconn serv-pkts)
  (filter (lambda (pkt)
	    (let* ((host (alist-ref 'host pkt))
		   (port (alist-ref 'port pkt))
		   (host-port (conc host":"port))
		   (key  (alist-ref 'servkey  pkt))
		   (pktz (alist-ref 'Z        pkt))
		   (res  (server-ready? uconn host-port key)))
	      (if res
		  res
		  (let* ((pktsdir (get-pkts-dir *toppath*))
			 (pktpath (conc pktsdir"/"pktz".pkt")))
		    (debug:print 0 *default-log-port* "WARNING: pkt with no server "pktpath)
		    (delete-file* pktpath)
		    #f))))
	  serv-pkts))

;; from viable servers get one that is alive and ready
;;
(define (get-the-server uconn apath serv-pkts)
  (let loop ((tail serv-pkts))
    (if (null? tail)
	#f
	(let* ((spkt  (car tail))
	       (host  (alist-ref 'ipaddr spkt))
	       (port  (alist-ref 'port spkt))
	       (host-port (conc host":"port))
	       (dbpth (alist-ref 'dbpath spkt))
	       (srvkey (alist-ref 'Z spkt)) ;; (alist-ref 'srvkey spkt))
	       (addr  (server-address spkt)))
	  (if (server-ready? uconn host-port srvkey)
	      spkt
	      (loop (cdr tail)))))))

;; am I the "first" in line server? I.e. my D card is smallest
;; use Z card as tie breaker
;;
(define (get-best-candidate serv-pkts dbpath)
  (if (null? serv-pkts)
      #f
      (let loop ((tail serv-pkts)
		 (best  (car serv-pkts)))
	(if (null? tail)
	    best
	    (let* ((candidate (car tail))
		   (candidate-bd (string->number (alist-ref 'D candidate)))
		   (best-bd      (string->number (alist-ref 'D best)))
		   ;; bigger number is younger
		   (candidate-z  (alist-ref 'Z candidate))
		   (best-z       (alist-ref 'Z best))
		   (new-best     (cond
				  ((> best-bd candidate-bd) ;; best is younger than candidate
				   candidate)
				  ((< best-bd candidate-bd) ;; candidate is younger than best
				   best)
				  (else
				   (if (string>=? best-z candidate-z)
				       best
				       candidate))))) ;; use Z card as tie breaker
	      (if (null? tail)
		  new-best
		  (loop (cdr tail) new-best)))))))
	  
;;======================================================================
;; END NEW SERVER METHOD
;;======================================================================

;; sdat must be defined and the host and port set and the same as previous
;;
(define (host-port-is-stable? sdat old-host old-port)
  (and sdat
       (let ((new-host (servdat-host sdat))
	     (new-port (servdat-port sdat)))
	 (and new-host
	      new-port
	      (equal? new-host old-host)
	      (equal? new-port old-port)))))

;; if .db/main.db check the pkts
;; 
(define (rmt:wait-for-server pkts-dir db-file server-key)
  (let* ((sdat *db-serv-info*))
    (let loop ((start-time (current-milliseconds))
	       (changed    #t)
	       (last-sdat  "not this")
	       (last-host  #f)
	       (last-port  #f))
      (begin ;; let ((sdat #f))
	(thread-sleep! 0.01)
	(debug:print-info 0 *default-log-port* "Waiting for server alive signature")
	(mutex-lock! *heartbeat-mutex*)
	(set! sdat *db-serv-info*)
	(mutex-unlock! *heartbeat-mutex*)
	(if (and sdat
		 (not changed)
		 (>= (- (current-milliseconds) start-time) 100))
	    (let* ((uconn (servdat-uconn sdat)))
	      (servdat-status-set! sdat 'iface-stable)
	      (debug:print-info 0 *default-log-port* "Received server alive signature, now attempting to lock in server")
	      ;; create a server pkt in *toppath*/.meta/srvpkts
	      
	      ;; TODO:
	      ;;   1. change sdat to stuct
	      ;;   2. add uuid to struct
	      ;;   3. update uuid in sdat here
	      ;;
	      (servdat-uuid-set! sdat
				 (register-server
				  pkts-dir *srvpktspec*
				  (get-host-name)
				  (servdat-port sdat) server-key
				  (servdat-host sdat) db-file))
	      ;; (set! *my-signature* (servdat-uuid sdat)) ;; replace with Z, no, stick with proper key
	      ;; now read pkts and see if we are a contender
	      (let* ((all-pkts     (get-all-server-pkts pkts-dir *srvpktspec*))
		     (viables      (get-viable-servers all-pkts db-file))
		     (alive        (remove-pkts-if-not-alive uconn viables))
		     (best-srv     (get-best-candidate alive db-file))
		     (best-srv-key (if best-srv (alist-ref 'servkey best-srv) #f))
		     (i-am-srv     (equal? best-srv-key server-key))
		     (delete-pkt   (lambda ()
				     (let* ((pktfile (conc (get-pkts-dir *toppath*)
							 "/" (servdat-uuid *db-serv-info*)
							 ".pkt")))
				       (debug:print-info 0 *default-log-port* "Attempting to remove bogus pkt file "pktfile)
				       (delete-file* pktfile))))) ;; remove immediately instead of waiting for on-exit
		(debug:print 0 *default-log-port* "best-srv-key: "best-srv-key", server-key: "server-key", i-am-srv: "i-am-srv)
		;; am I the best-srv, compare server-keys to know
		(if i-am-srv
		    (if (get-lock-db sdat db-file (servdat-host sdat)(servdat-port sdat)) ;; (db:get-iam-server-lock *dbstruct-db* *toppath* run-id)
			(begin
			  (debug:print-info 0 *default-log-port* "I'm the server!")
			  (servdat-dbfile-set! sdat db-file)
			  (servdat-status-set! sdat 'db-locked))
			(begin
			  (debug:print-info 0 *default-log-port* "I'm not the server, exiting.")
			  (bdat-time-to-exit-set! *bdat* #t)
			  (delete-pkt)
			  (thread-sleep! 0.2)
			  (exit)))
		    (begin
		      (debug:print-info 0 *default-log-port*
				   "Keys do not match "best-srv-key", "server-key", exiting.")
		      (bdat-time-to-exit-set! *bdat* #t)
		      (delete-pkt)
		      (thread-sleep! 0.2)
		      (exit)))
		sdat))
	    (begin ;; sdat not yet contains server info
	      (debug:print-info 0 *default-log-port* "Still waiting, last-sdat=" last-sdat)
	      (thread-sleep! 0.1)
	      (if (> (- (current-milliseconds) start-time) 120000) ;; been waiting for two minutes
		  (begin
		    (debug:print-error 0 *default-log-port* "transport appears to have died, exiting server")
		    (exit))
		  (loop start-time
			(not (host-port-is-stable? sdat last-host last-port))
			sdat
			(servdat-host sdat)
			(servdat-port sdat)))))))))

(define (rmt:register-server sinfo apath iface port server-key dbname)
  (servdat-conns sinfo) ;; just checking types
  (rmt:open-main-connection sinfo apath) ;; we need a channel to main.db
  (rmt:send-receive-real sinfo apath      ;; params: host port servkey pid ipaddr dbpath
			 (db:run-id->dbname #f)
			 'register-server `(,iface
					    ,port
					    ,server-key
					    ,(current-process-id)
					    ,iface
					    ,apath
					    ,dbname)))

(define (rmt:get-count-servers sinfo apath)
  (servdat-conns sinfo) ;; just checking types
  (rmt:open-main-connection sinfo apath) ;; we need a channel to main.db
  (rmt:send-receive-real sinfo apath      ;; params: host port servkey pid ipaddr dbpath
			 (db:run-id->dbname #f)
			 'get-count-servers `(,apath)))

(define (rmt:get-servers-info apath)
  (rmt:send-receive 'get-servers-info #f `(,apath)))

(define (rmt:deregister-server db-serv-info apath iface port server-key dbname)
  (rmt:open-main-connection db-serv-info apath) ;; we need a channel to main.db
  (rmt:send-receive db-serv-info apath      ;; params: host port servkey pid ipaddr dbpath
                         (db:run-id->dbname #f)
                         'deregister-server `(,iface
                                              ,port
                                              ,server-key
                                              ,(current-process-id)
                                              ,iface
                                              ,apath
                                              ,dbname)))

(define (rmt:wait-for-stable-interface #!optional (num-tries-allowed 100))
  ;; wait until *db-serv-info* stops changing
  (let* ((stime (current-seconds)))
    (let loop ((last-host  #f)
	       (last-port  #f)
	       (tries 0))
      (let* ((curr-host (and *db-serv-info* (servdat-host *db-serv-info*)))
	     (curr-port (and *db-serv-info* (servdat-port *db-serv-info*))))
	;; first we verify port and interface, update *db-serv-info* in need be.
	(cond
	 ((> tries num-tries-allowed)
	  (debug:print 0 *default-log-port* "rmt:keep-running, giving up after trying for several minutes.")
	  (exit 1))
	 ((not *db-serv-info*)
	  (thread-sleep! 0.25)
	  (loop curr-host curr-port (+ tries 1)))
	 ((or (not last-host)(not last-port))
	  (debug:print 0 *default-log-port* "rmt:keep-running, still no interface, tries="tries)
	  (thread-sleep! 0.25)
	  (loop curr-host curr-port (+ tries 1)))
	 ((or (not (equal? last-host curr-host))
	      (not (equal? last-port curr-port)))
	  (debug:print-info 0 *default-log-port* "WARNING: interface changed, refreshing iface and port info")
	  (thread-sleep! 0.25)
	  (loop curr-host curr-port (+ tries 1)))
	 ((< (- (current-seconds) stime) 1) ;; keep up the looping until at least 3 seconds have passed
	  (thread-sleep! 0.5)
	  (loop curr-host curr-port (+ tries 1)))
	 (else
	  (rmt:get-signature) ;; sets *my-signature* as side effect
	  (servdat-status-set! *db-serv-info* 'interface-stable)
	  (debug:print 0 *default-log-port*
		       "SERVER STARTED: " curr-host
		       ":" curr-port
		       " AT " (current-seconds) " server signature: " *my-signature*
		       " with "(servdat-trynum *db-serv-info*)" port changes")
	  (flush-output *default-log-port*)
	  #t))))))

;; run rmt:keep-running in a parallel thread to monitor that the db is being 
;; used and to shutdown after sometime if it is not.
;;
(define (rmt:keep-running dbname) 
  ;; if none running or if > 20 seconds since 
  ;; server last used then start shutdown
  ;; This thread waits for the server to come alive
  (debug:print-info 0 *default-log-port* "Starting the sync-back, keep alive thread in server")

  (let* ((sinfo             *db-serv-info*)
	 (server-start-time (current-seconds))
	 (pkts-dir          (get-pkts-dir))
	 (server-key        (rmt:get-signature)) ;; This servers key
	 (is-main           (equal? (args:get-arg "-db") ".db/main.db"))
	 (last-access       0)
	 (server-timeout    (server:expiration-timeout))
	 (shutdown-server-sequence (lambda (host port)
				     (set! *unclean-shutdown* #f) ;; Should not be needed anymore
				     (debug:print-info 0 *default-log-port* "Starting to shutdown the server. pid="(current-process-id))
				     ;; (rmt:server-shutdown host port) -- called in on-exit
				     ;; (portlogger:open-run-close portlogger:set-port port "released") called in on-exit
				     (exit)))
	 (timed-out?        (lambda ()
			      (<= (+ last-access server-timeout)
				  (current-seconds)))))
    (servdat-dbfile-set! *db-serv-info* (args:get-arg "-db"))
    ;; main and run db servers have both got wait logic (could/should merge it)
    (if is-main
	(rmt:wait-for-server pkts-dir dbname server-key)
	(rmt:wait-for-stable-interface))
    ;; this is our forever loop
    (let* ((iface (servdat-host *db-serv-info*))
	   (port  (servdat-port *db-serv-info*))
	   (uconn (servdat-uconn *db-serv-info*)))
      (let loop ((count          0)
		 (bad-sync-count 0)
		 (start-time     (current-milliseconds)))
	(if (and (not is-main)
		 (common:low-noise-print 60 "servdat-status"))
	    (debug:print-info 0 *default-log-port* "servdat-status is " (servdat-status *db-serv-info*)))

	(mutex-lock! *heartbeat-mutex*)
	;; set up the database handle
	(if (not *dbstruct-db*) ;; no db opened yet, open the db and register with main if appropriate
	      (let ((watchdog (bdat-watchdog *bdat*)))
		(debug:print 0 *default-log-port* "SERVER: dbprep")
		(db:setup dbname) ;; sets *dbstruct-db* as side effect
		(servdat-status-set! *db-serv-info* 'db-opened)
		;; IFF I'm not main, call into main and register self
		(if (not is-main)
		    (let ((res (rmt:register-server sinfo
						    *toppath* iface port
						    server-key dbname)))
		      (if res ;; we are the server
			  (servdat-status-set! *db-serv-info* 'have-interface-and-db)
			  ;; now check that the db locker is alive, clear it out if not
			  (let* ((serv-info (rmt:server-info *toppath* dbname)))
			    (match serv-info
				   ((host port servkey pid ipaddr apath dbpath)
				    (if (not (server-ready? uconn (conc host":"port) servkey))
					(begin
					  (debug:print-info 0 *default-log-port* "Server registered but not alive. Removing and trying again.")
					  (rmt:deregister-server sinfo apath host port servkey dbpath) ;; servkey pid ipaddr apath dbpath)
					  (loop (+ count 1) bad-sync-count start-time))))
				   (else
				    (debug:print 0 *default-log-port* "We are not the server for "dbname", exiting. Server info is: "serv-info)
				    (exit)))))))
		(debug:print 0 *default-log-port*
			     "SERVER: running, db "dbname" opened, megatest version: "
			   (common:get-full-version))
	      ))
	
	(db:sync-inmem->disk *dbstruct-db* *toppath* dbname force-sync: #t)
	
	(mutex-unlock! *heartbeat-mutex*)
	
	;; when things go wrong we don't want to be doing the various
	;; queries too often so we strive to run this stuff only every
	;; four seconds or so.
	(let* ((sync-time (- (current-milliseconds) start-time))
	       (rem-time  (quotient (- 4000 sync-time) 1000)))
	  (if (and (<= rem-time 4)
		   (>  rem-time 0))
	      (thread-sleep! rem-time)))
    
	;; Transfer *db-last-access* to last-access to use in checking that we are still alive
	(set! last-access *db-last-access*)
	
	(if (< count 1) ;; 3x3 = 9 secs aprox
	    (loop (+ count 1) bad-sync-count (current-milliseconds)))
	
	(if (common:low-noise-print 60 "dbstats")
	    (begin
	      (debug:print 0 *default-log-port* "Server stats:")
	      (db:print-current-query-stats)))
	(let* ((hrs-since-start  (/ (- (current-seconds) server-start-time) 3600)))
	  (cond
	   ((not *server-run*)
	    (debug:print-info 0 *default-log-port* "*server-run* set to #f. Shutting down.")
	    (shutdown-server-sequence (get-host-name) port))
	   ((timed-out?)
	    (debug:print-info 0 *default-log-port* "Server timed out. seconds since last db access: " (- (current-seconds) last-access))
	    (shutdown-server-sequence (get-host-name) port))
	   ((and *server-run*
		 (or (not (timed-out?))
		     (if is-main ;; do not exit if there are other servers (keep main open until all others gone)
			 (> (rmt:get-count-servers sinfo *toppath*) 1)
			 #f)))
	    (if (common:low-noise-print 120 "server continuing")
		(debug:print-info 0 *default-log-port* "Server continuing, seconds since last db access: " (- (current-seconds) last-access)))
	    (loop 0 bad-sync-count (current-milliseconds)))
	   (else
	    (set! *unclean-shutdown* #f)
	    (debug:print-info 0 *default-log-port* "Server timed out. seconds since last db access: " (- (current-seconds) last-access))
	    (shutdown-server-sequence (get-host-name) port)
	    #;(debug:print-info 0 *default-log-port* "Sending 'quit to server, received: "
			      (open-send-receive-nn (conc iface":"port)      ;; do this here and not in server-shutdown
						    (sexpr->string 'quit))))))))))

(define (rmt:get-reasonable-hostname)
  (let* ((inhost (or (args:get-arg "-server") "-")))
    (if (equal? inhost "-")
	(get-host-name)
	inhost)))

;; Call this to start the actual server
;;
;; all routes though here end in exit ...
;;
;; This is the point at which servers are started
;;
(define (rmt:server-launch dbname)
  (debug:print-info 0 *default-log-port* "Entered rmt:server-launch")
  (let* ((th2 (make-thread (lambda ()
			     (debug:print-info 0 *default-log-port* "Server run thread started")
			     (rmt:run (rmt:get-reasonable-hostname)))
			   "Server run"))
	 (th3 (make-thread (lambda ()
			     (debug:print-info 0 *default-log-port* "Server monitor thread started")
			     (if (args:get-arg "-server")
				 (rmt:keep-running dbname)
				 #;(rmt:wait-for-stable-interface)))
			     "Keep running")))
    (thread-start! th2)
    (thread-sleep! 0.252) ;; give the server time to settle before starting the keep-running monitor.
    (thread-start! th3)
    (set! *didsomething* #t)
    (thread-join! th2)
    (thread-join! th3))
  #f)
	    
;;======================================================================
;;  S E R V E R   -  D I R E C T   C A L L S
;;======================================================================

(define (rmt:kill-server run-id)
  (rmt:send-receive 'kill-server #f (list run-id)))

(define (rmt:start-server run-id)
  (rmt:send-receive 'start-server #f (list run-id)))

(define (rmt:server-info apath dbname)
  (rmt:send-receive 'get-server-info #f (list apath dbname)))


)

;; ulex: Distributed sqlite3 db
;;;
;; Copyright (C) 2018-2021 Matt Welland
;; Redistribution and use in source and binary forms, with or without
;; modification, is permitted.
;;
;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS
;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE
;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
;; DAMAGE.

;;======================================================================
;; ABOUT:
;;   See README in the distribution at https://www.kiatoa.com/fossils/ulex
;; NOTES:
;;   Why sql-de-lite and not say, dbi?  - performance mostly, then simplicity.
;;
;;======================================================================

(module ulex
	*
	#;(
     
     ;; NOTE: looking for the handler proc - find the run-listener :)
     
     run-listener     ;; (run-listener handler-proc [port]) => uconn

     ;; NOTE: handler-proc params;
     ;;       (handler-proc rem-host-port qrykey cmd params)

     send-receive     ;; (send-receive uconn host-port cmd data)

     ;; NOTE: cmd can be any plain text symbol except for these;
     ;;         'ping 'ack 'goodbye 'response
     
     set-work-handler ;; (set-work-handler proc)

     wait-and-close   ;; (wait-and-close uconn)

     ulex-listener?
     
     ;; needed to get the interface:port that was automatically found
     udat-port
     udat-host-port
     
     ;; for testing only
     ;; pp-uconn
     
     ;; parameters
     work-method   ;; parameter; 'threads, 'mailbox, 'limited, 'direct
     return-method ;; parameter; 'mailbox, 'polling, 'direct
     )

(import scheme
	chicken.base
	chicken.file
	chicken.io
	chicken.time
	chicken.condition
	chicken.port
	chicken.string
	chicken.sort
	chicken.pretty-print
	chicken.tcp
	
	address-info
	mailbox
	matchable
	;; queues
	regex
	regex-case
	simple-exceptions
	s11n
	srfi-1
	srfi-18
	srfi-4
	srfi-69
	system-information
	;; tcp6
	tcp-server
	typed-records

	md5
	message-digest
	(prefix base64 base64:)
	z3
	)

;; udat struct, used by both caller and callee
;; instantiated as uconn by convention
;;
(defstruct udat
  ;; the listener side
  (port #f)
  (host-port #f) ;; my host:port
  (socket #f)
  ;; the peers
  (peers  (make-hash-table)) ;; host:port->peer
  ;; work handling
  (work-queue (make-mailbox))
  (work-proc  #f)                ;; set by user
  (cnum       0)                 ;; cookie number
  (mboxes     (make-hash-table)) ;; for the replies
  (avail-cmboxes '())            ;; list of (<cookie> . <mbox>) for re-use
  ;; threads
  (numthreads 10)
  (cmd-thread #f)
  (work-queue-thread #f)
  (num-threads-running 0)
  ) 

;;======================================================================
;; serialization
;;   NOTE: I've had problems with read/write and s11n serialize, deserialize
;;         thus the inefficient method here
;;======================================================================

(define serializing-method (make-parameter 'complex))


;; NOTE: Can remove the regex and base64 encoding for zmq
(define (obj->string obj)
  (case (serializing-method)
    ((complex)
     (string-substitute
      (regexp "=") "_"
      (base64:base64-encode 
       (z3:encode-buffer
        (with-output-to-string
          (lambda ()(serialize obj))))) ;; BB: serialize - this is
					;; what causes problems
					;; between different builds of
					;; megatest communicating.
					;; serialize is sensitive to
					;; binary image of mtest.
      #t))
    ((write)(with-output-to-string (lambda ()(write obj))))
    ((s11n) (with-output-to-string (lambda ()(serialize obj))))
    (else obj))) ;; rpc

(define (string->obj msg #!key (transport 'http))
  (case (serializing-method)
    ((complex)
     (handle-exceptions
      exn
      (begin
        (print "ULEX ERROR: cannot translate received data \""msg"\"")
        (print-call-chain (current-error-port))
        msg)
      (with-input-from-string 
          (z3:decode-buffer
           (base64:base64-decode
            (string-substitute 
             (regexp "_") "=" msg #t)))
        (lambda ()(deserialize)))))
    ((write)(with-input-from-string msg (lambda ()(read))))
    ((s11n)(with-input-from-string msg (lambda ()(deserialize))))
    (else msg))) ;; rpc


;;======================================================================
;; listener
;;======================================================================

;; is uconn a ulex connector (listener)
;;
(define (ulex-listener? uconn)
  (udat? uconn))

;; create a tcp listener and return a populated udat struct with
;; my port, address, hostname, pid etc.
;; return #f if fail to find a port to allocate.
;;
;;  if udata-in is #f create the record
;;  if there is already a serv-listener return the udata
;;
(define (setup-listener uconn #!optional (port 4242))
  (handle-exceptions
   exn
   (if (< port 65535)
       (setup-listener uconn (+ port 1))
       #f)
   (connect-listener uconn port)))

(define (connect-listener uconn port)
  ;; (tcp-listener-socket LISTENER)(socket-name so)
  ;; sockaddr-address, sockaddr-port, sockaddr->string
  (let* ((tlsn (tcp-listen port 1000 #f)) ;; (tcp-listen TCPPORT [BACKLOG [HOST]])
	 (addr (get-my-best-address))) ;; (hostinfo-addresses (host-information (current-hostname)))
    (udat-port-set!      uconn port)
    (udat-host-port-set! uconn (conc addr":"port))
    (udat-socket-set!    uconn tlsn)
    uconn))

;; run-listener does all the work of starting a listener in a thread
;; it then returns control
;;
(define (run-listener handler-proc #!optional (port-suggestion 4242))
  (let* ((uconn (make-udat)))
    (udat-work-proc-set! uconn handler-proc)
    (if (setup-listener uconn port-suggestion)
	(let* ((orig-in  (current-input-port))
	       (orig-out (current-output-port)))
	  ((make-tcp-server
	    (udat-socket uconn)
	    (lambda ()
	      (let* ((rdat
		      (string->obj (read))
		      ;; (read in)
		      ;; (deserialize)
		      ) 
		     (resp (let ((tcp-in  (current-input-port))
				 (tcp-out (current-output-port)))
			     (current-input-port orig-in)
			     (current-output-port orig-out)
			     (let ((res (do-work uconn rdat)))
			       (current-input-port tcp-in)
			       (current-output-port tcp-out)
			       res))))
		(write (obj->string resp))
		;; (serialize resp)
		;; (write resp out)
		)))))
	(assert #f "ERROR: run-listener called without proper setup."))))

(define (wait-and-close uconn)
  (thread-join! (udat-cmd-thread uconn))
  (tcp-close (udat-socket uconn)))

;;========================================================================
;; peers and connections
;;========================================================================

(define *send-mutex* (make-mutex))

;; send structured data to recipient
;;
;;  NOTE: qrykey is what was called the "cookie" previously
;;
;;     retval tells send to expect and wait for return data (one line) and return it or time out
;;       this is for ping where we don't want to necessarily have set up our own server yet.
;;
(define (send-receive udata host-port cmd params)
  (let* ((host-port-lst (string-split host-port ":"))
	 (host          (car host-port-lst))
	 (port          (string->number (cadr host-port-lst)))
	 (my-host-port (and udata (udat-host-port udata)))          ;; remote will return to this
	 (isme         (equal? host-port my-host-port)) ;; calling myself?
	 ;; dat is a self-contained work block that can be sent or handled locally
	 (dat          (list `(host-port . ,my-host-port)
			     `(qrykey . qrykey)
			     `(cmd . ,cmd)
			     `(params . ,params))))
    (cond
     (isme (do-work udata dat)) ;; no transmission needed
     (else
      (handle-exceptions ;; TODO - MAKE THIS EXCEPTION CMD SPECIFIC?
       exn
       (begin
         (print "ULEX send-receive: "cmd", "params", exn="exn)
         (message exn))
       (begin
	 ;; (mutex-lock! *send-mutex*) ;; DOESN'T SEEM TO HELP
	 (let-values (((inp oup)(tcp-connect host port)))
	   (let ((res (if (and inp oup)
			  (begin
			    (write (obj->string dat) oup)
			    (close-output-port oup)
			    (string->obj (read inp)))
			  (begin
			    (print "ERROR: send called but no receiver has been setup. Please call setup first!")
			    #f))))
	     (close-input-port inp)
	     ;; (mutex-unlock! *send-mutex*) ;; DOESN'T SEEM TO HELP
	     res)))))))) ;; res will always be 'ack unless return-method is direct

;;======================================================================
;; work queues - this is all happening on the listener side
;;======================================================================

;; move the logic to return the result somewhere else?
;;
(define (do-work uconn rdat)
  ;; put this following into a do-work procedure
  (match rdat
     ((rem-host-port qrykey cmd params)
      (case cmd
	((ping) 'ping-ack) ;; bypass calling the proc
	(else
	 (let* ((proc       (udat-work-proc uconn))
		(start-time (current-milliseconds))
		(result     (with-output-to-port (current-error-port)
			      (lambda ()
				(proc rem-host-port qrykey cmd params))))
		(end-time   (current-milliseconds))
		(run-time   (- end-time start-time)))
	   result))))
     (else
      (print "ERROR: rdat "rdat", did not match rem-host-port qrykey cmd params"))))

;;======================================================================
;; misc utils
;;======================================================================

(define (pp-uconn uconn)
  (pp (udat->alist uconn)))

;;======================================================================
;; network utilities
;;======================================================================

;; NOTE: Look at address-info egg as alternative to some of this

(define (rate-ip ipaddr)
  (regex-case ipaddr
    ( "^127\\..*" _ 0 )
    ( "^(10\\.0|192\\.168)\\..*" _ 1 )
    ( else 2 ) ))

;; Change this to bias for addresses with a reasonable broadcast value?
;;
(define (ip-pref-less? a b)
  (> (rate-ip a) (rate-ip b)))

(define (get-my-best-address)
  (let ((all-my-addresses (get-all-ips)))
    (cond
     ((null? all-my-addresses)
      (get-host-name))                                          ;; no interfaces?
     ((eq? (length all-my-addresses) 1)
      (car all-my-addresses))                      ;; only one to choose from, just go with it
     (else
      (car (sort all-my-addresses ip-pref-less?))))))

(define (get-all-ips-sorted)
  (sort (get-all-ips) ip-pref-less?))

(define (get-all-ips)
  (map address-info-host
       (filter (lambda (x)
		 (equal? (address-info-type x) "tcp"))
	       (address-infos (get-host-name)))))

)