Megatest

CSCOPTS=
INSTALL=install
SRCFILES =

# all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut ndboard
all : $(PREFIX)/bin/.$(ARCHSTR) mtest
# add dboard mtut and tcmt back later

# Configuration stuff
transport-flavor :
	@echo Creating transport-flavor with full as flavor. Options include: full, simple
	echo full > transport-flavor

ulex.scm dbmgrmod.scm : ulex.scm.template dbmgrmod.scm.template transport-flavor ulex-*/*scm
	./configure

# module source files
MSRCFILES = autoload.scm dbi.scm ducttape-lib.scm pkts.scm stml2.scm	\
            cookie.scm mutils.scm mtargs.scm apimod.scm	ulex.scm	\
            configfmod.scm commonmod.scm dbmod.scm rmtmod.scm		\
            debugprint.scm mtver.scm csv-xml.scm servermod.scm		\
            adjutant.scm processmod.scm testsmod.scm	\
            itemsmod.scm keysmod.scm mtmod.scm rmtmod.scm		\
            tasksmod.scm pgdb.scm launchmod.scm runsmod.scm		\
            portloggermod.scm archivemod.scm ezstepsmod.scm		\
            subrunmod.scm bigmod.scm testsmod.scm dbmgrmod.scm



GUIMODFILES = tree.scm dashboard-tests.scm  vgmod.scm \
              dashboard-context-menu.scm dcommon.scm 



mofiles/dashboard-context-menu.o : mofiles/dcommon.o
mofiles/dashboard-tests.o : mofiles/dcommon.o


OFILES   = $(SRCFILES:%.scm=%.o)


MOFILES = $(addprefix mofiles/,$(MSRCFILES:%.scm=%.o))
GMOFILES = $(addprefix mofiles/,$(GUIMODFILES:%.scm=%.o))

# compiled import files
MOIMPFILES = $(MSRCFILES:%.scm=%.import.o)
GMOIMPFILES = $(GUIMODFILES:%.scm=%.import.o)

mofiles/bigmod.o : mofiles/configfmod.o
mofiles/bigmod.o : mofiles/dbmod.o
mofiles/bigmod.o : mofiles/rmtmod.o
# mofiles/clientmod.o : mofiles/servermod.oibpq-dev
mofiles/commonmod.o : megatest-fossil-hash.scm
mofiles/commonmod.o : mofiles/configfmod.o
mofiles/commonmod.o : mofiles/debugprint.o

mofiles/commonmod.o : mofiles/keysmod.o
mofiles/commonmod.o : mofiles/mtargs.o
mofiles/commonmod.o : mofiles/mtver.o
mofiles/commonmod.o : mofiles/processmod.o
mofiles/configfmod.o : mofiles/keysmod.o
mofiles/dbimod.o : mofiles/autoload.o
mofiles/dbmod.o : mofiles/commonmod.o

mofiles/launchmod.o : mofiles/bigmod.o
mofiles/launchmod.o : mofiles/ezstepsmod.o
mofiles/launchmod.o : mofiles/rmtmod.o mofiles/servermod.o
mofiles/mtmod.o : mofiles/debugprint.o
mofiles/portloggermod.o : mofiles/tasksmod.o
mofiles/rmtmod.o : mofiles/apimod.o
mofiles/rmtmod.o : mofiles/commonmod.o mofiles/portloggermod.o
mofiles/rmtmod.o : mofiles/itemsmod.o mofiles/ulex.o
mofiles/rmtmod.o : mofiles/dbmgrmod.o
mofiles/runsmod.o : mofiles/rmtmod.o mofiles/archivemod.o
mofiles/servermod.o : mofiles/commonmod.o
mofiles/stml2.o : mofiles/cookie.o mofiles/dbi.o
mofiles/tasksmod.o : mofiles/pgdb.o mofiles/dbmod.o
mofiles/testsmod.o : mofiles/commonmod.o
mofiles/testsmod.o : mofiles/itemsmod.o mofiles/rmtmod.o mofiles/tasksmod.o

# split modules. Note: we can switch between ulex and ulex simple.
mofiles/ulex.o : ulex/ulex.scm ulex-simple/ulex.scm

dashboard.o megatest.o : db_records.scm megatest-fossil-hash.scm


ADTLSCR=mt_laststep mt_runstep mt_ezstep
HELPERS=$(addprefix $(PREFIX)/bin/,$(ADTLSCR))
DEPLOYHELPERS=$(addprefix deploytarg/,$(ADTLSCR))
MTESTHASH=$(shell fossil info|grep checkout:| awk '{print $$2}')

ifeq ($(MTESTHASH),)

#     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

TODO
====

Loose ends
----------

15:09:29 error in calling find-and-mark-incomplete for run-id 5, exn=#<condition: (exn type)>
         might be related to initial conditions in the db. (no run entry in runs table?).

. -list-servers not correct
. move *remotedat* into bigdata
. add back server stats on exit (look in rmt:run in rmtmod.scm)


WW15

(module apimod
  (
api:run-server-process
api:start-server
api:dispatch-cmd
api:execute-requests
;; api:process-request
)
	
(import scheme
	chicken.base
	chicken.process-context.posix
	chicken.string
	chicken.time

	 (logd        (conc apath "/logs")) 
	 (logf        (conc logd "/server-launch-";;(current-process-id)
			    (seconds->year-work-week/day-time-fname (current-seconds))
			    "-"cleandbname".log"))
	 (logf2       (conc logd "/server-"
			    (seconds->year-work-week/day-time-fname (current-seconds))
			    "-"cleandbname"-"))
	 (cmd  (conc "nbfake megatest -server - -area "apath" -db "dbname)
		     ;; " -autolog "logf2 ;; the side log did not help. Ended up with two logs and the pid in the name was not that useful.
		     ))
    (if (not (directory-exists? logd))
	(create-directory logd #t))
    (system (conc "NBFAKE_LOG="logf" "cmd))))

;; special function to get server
;; look up in db
;; if found -> return it

    ((have-incompletes?)            (apply db:have-incompletes? dbstruct params))
    ((login)                        (apply db:login dbstruct params))
    ((general-call)                 (let ((stmtname   (car params))
					  (run-id     (cadr params))
					  (realparams (cddr params)))
				      (db:general-call dbstruct stmtname run-id realparams)))
    ((sdb-qry)                      (apply sdb:qry params))
    ((ping)                         `(#t ,(current-process-id) ,(cadr params))) ;; (current-process-id))
    ((get-changed-record-ids)       (apply db:get-changed-record-ids dbstruct params))
    ((get-run-record-ids) 	   (apply db:get-run-record-ids dbstruct params))	
    ;; TESTMETA
    ((testmeta-get-record)       (apply db:testmeta-get-record dbstruct params))

    ;; TASKS 
    ((find-task-queue-records)   (apply tasks:find-task-queue-records dbstruct params))

;; http-server  send-response
;;                 api:process-request
;;                    db:*
;;
;; NB// Runs on the server as part of the server loop
;;
#;(define (api:process-request dbstruct indat) ;; the $ is the request vars proc
  (let* ((cmd-in  (alist-ref 'cmd indat)) ;; ($ 'cmd))
	 (cmd     (if (string? cmd-in)(string->symbol cmd-in) cmd-in))
	 (params  (alist-ref 'params indat))
         (key     (alist-ref 'key indat))    ;; TODO - add this back
	 ;; (doprint (apply common:low-noise-print 10 params))
	 )
    ;; (if doprint (debug:print 0 *default-log-port* "cmd: " cmd " with params: " params ", key: " key))

#!/bin/bash

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

# Configure the build

if [[ "$1"x == "x" ]];then
    PREFIX=$PWD
else
    PREFIX=$1
fi


#======================================================================
# Configure stuff needed for eggs
#======================================================================

function configure_dependencies () {

    #======================================================================
    # libnanomsg
    #======================================================================

    if [[ ! $(ls /usr/lib/*/libnanomsg*) ]];then
	echo "libnanomsg build needed."
	echo "BUILD_NANOMSG=yes" >> makefile.inc
    fi

    #======================================================================
    # postgresql libraries
    #======================================================================

    if [[ ! $(ls /usr/lib/*/libpq.*) ]];then
	echo "Postgresql build needed."
	echo "BUILD_POSTGRES=yes" >> makefile.inc
    fi

    if [[ ! $(ls /usr/lib/*/libsqlite3.*) ]];then
    echo "Sqlite3 build needed."
	echo "BUILD_SQLITE3=yes" >> makefile.inc
    fi

}

#======================================================================
# Initialize makefile.inc
#======================================================================

echo "" > makefile.inc

#======================================================================
# Do we need Chicken?
#======================================================================

if [[ -e /usr/bin/sw_vers ]]; then
    ARCHSTR=$(/usr/bin/sw_vers -productVersion)
else
    ARCHSTR=$(lsb_release -sr)
fi

echo "CHICKEN_PREFIX=$PREFIX/.$ARCHSTR" >> makefile.inc
CHICKEN_PREFIX=$PREFIX/bin/.$ARCHSTR

if [[ ! $(type csi) ]];then
    echo "Chicken build needed."
    echo "BUILD_CHICKEN=yes" >> makefile.inc
    configure_dependencies
    echo "include chicken.makefile" >> makefile.inc
else
    echo "CSIPATH=$(which csi)" >> makefile.inc
    CSIPATH=$(which csi)
    echo "CKPATH=$(dirname $(dirname $CSIPATH))" >> makefile.inc
fi

# Make setup scripts
echo "#!/bin/bash" > setup.sh
echo "export PATH=$CHICKEN_PREFIX/bin:\$PATH" >> setup.sh
echo "export LD_LIBRARY_PATH=$CHICKEN_PREFIX/lib" >> setup.sh
echo 'exec "$@"' >> setup.sh
chmod a+x setup.sh

echo "setenv PATH $CHICKEN_PREFIX/bin:\$PATH" > setup.csh
echo "setenv LD_LIBRARY_PATH $CHICKEN_PREFIX/lib" >> setup.csh

echo "All done creating makefile.inc, feel free to edit it!"
echo "run \"setup.sh bash\" or source setup.csh to get PATH and LD_LIBRARY_PATH adjusted"

README for IUP





  IUP is a portable toolkit for building graphical user interfaces. It offers a configuration API in three basic languages: C, Lua and LED. IUP's purpose is to allow a program to be executed in different systems without any modification, therefore it is highly portable. Its main advantages are:

    * high performance, due to the fact that it uses native interface elements.

    * fast learning by the user, due to the simplicity of its API.



  Build instructions and usage are available in the IUP documentation.



  For complete information, visit IUP's web site at http://www.tecgraf.puc-rio.br/iup

  or access its documentation in the HTML folder.




(end of README)

csm
address-info
ansi-escape-sequences
apropos
base64
breadline
crypt
csv-abnf
directory-utils
dot-locking
filepath
fmt
format
http-client
itemsmod
json
linenoise
mailbox
md5
message-digest
nanomsg
postgresql
queues
regex
regex-case
rfc3339
s11n
sha1
simple-exceptions
slice
sparse-vectors
spiffy
spiffy-directory-listing
spiffy-request-vars
sql-de-lite
sqlite3
sql-null
srfi-1
srfi-13
srfi-19
sxml-modifications
sxml-serializer
sxml-transforms
system-information
tcp6
test
typed-records
uri-common
z3

echo " rsync -av include/ $PREFIX/include/"
echo " or (depending on versions and what you see in the iup tars - they seem to vary"
echo "     cp *.a *.so $PREFIX/lib"
echo "     cp include/*.h $PREFIX/include"
echo "  4. run the chicken-install like this:"

echo "If you use a wrapper (e.g. ck5) to create the chicken environment:"
echo "CSC_OPTIONS=\"-I$PREFIX/include -I$PREFIX/include/im -I$PREFIX/include/cd -I$PREFIX/include/iup -L$PREFIX/lib -C -std=gnu99\" ck5 chicken-install iup canvas-draw -feature disable-iup-matrixex"
echo "else:"
echo "CSC_OPTIONS=\"-I$PREFIX/include -I$PREFIX/include/im -I$PREFIX/include/cd -I$PREFIX/include/iup -L$PREFIX/lib -C -std=gnu99\" chicken-install iup canvas-draw"


# (export PREFIX=/home/matt/data/buildall/ck5.2;CSC_OPTIONS="-I/home/matt/data/buildall/ck5.2/include -I/home/matt/data/buildall/ck5.2/include/im -I/home/matt/data/buildall/ck5.2/include/cd -I/home/matt/data/buildall/ck5.2/include/iup -L/home/matt/data/buildall/ck5.2/lib -C -std=gnu99" ck5 chicken-install iup -feature disable-iup-matrixex)
 

(declare (uses mtver))
(declare (uses debugprint))
(declare (uses stml2))
(declare (uses pkts))
(declare (uses processmod))
(declare (uses mtargs))
(declare (uses configfmod))
;; (declare (uses hostinfo))
(declare (uses keysmod))

;; odd but it works?
;; (declare (uses itemsmod))

(module commonmod
	   (

test:get-item-path
test:test-get-fullname
make-and-init-bigdata
call-with-environment-variables
common:simple-file-lock
common:simple-file-lock-and-wait
common:simple-file-release-lock
common:with-simple-file-lock
common:fail-safe
get-file-descriptor-count
common:get-this-exe-fullpath
common:get-sync-lock-filepath
common:find-local-megatest
common:logpro-exit-code->status-sym
common:worse-status-sym

*task-db*
*db-access-allowed*
*db-access-mutex*
*db-transaction-mutex*
*db-cache-path*
*db-with-db-mutex*
*db-api-call-time*
*didsomething*
*no-sync-db*
*my-signature*
*transport-type*
*logged-in-clients*

*server-run*
*run-id*
*server-kind-run*
*home-host*
*heartbeat-mutex*
*api-process-request-count*
*max-api-process-requests*

runs:gendat-inc-results-last-update-set!
runs:gendat-inc-results-fmt-set!
runs:gendat-run-info-set!
runs:gendat-runname-set!
runs:gendat-target-set!

megatest-fossil-hash

rmt:mk-signature
rmt:get-signature

)

	
(import scheme
	chicken.base
	chicken.condition
	chicken.file

	chicken.io
	chicken.string
	chicken.sort
	chicken.time.posix
	
	(prefix base64 base64:)
	(prefix sqlite3 sqlite3:)

	address-info
	directory-utils
	matchable
	md5
	message-digest
	regex
	regex-case
	sparse-vectors

	stml2
	pkts
	processmod
	(prefix mtargs args:)
	configfmod
	keysmod
	;; itemsmod
	;; hostinfo
	)

;;======================================================================
;; CONTENTS
;;
;;  config file utils
;;  misc conversion, data manipulation functions

;; (define *watchdog* #f)
;; A hash table that can be accessed by #{scheme ...} calls in
;; config files. Allows communicating between confgs
;;
(define *user-hash-data* (make-hash-table))

(define *db-keys* #f)
(define *didsomething* #f)

(define *pkts-info*    (make-hash-table)) ;; store stuff like the last parent here
(define *configinfo*   #f)   ;; raw results from setup, includes toppath and table from megatest.config
(define *runconfigdat* #f)   ;; run configs data
(define *configdat*    #f)   ;; megatest.config data ==> moved to configfmod
(define *configstatus* #f)   ;; status of data; 'fulldata : all processing done, #f : no data yet, 'partialdata : partial read done
(define *toppath*      #f)

(define *my-signature* #f)
(define *transport-type*    'http)             ;; override with [server] transport http|rpc|nmsg
;; replaced by *rmt:remote*
;; (define *runremote*         #f)                ;; if set up for server communication this will hold <host port>
;; (define *max-cache-size*    0)
(define *logged-in-clients* (make-hash-table))
;; (define *server-id*         #f)


(define *server-run*        #t)
(define *run-id*            #f)
(define *server-kind-run*   (make-hash-table))
(define *home-host*         #f)
;; (define *total-non-write-delay* 0)
(define *heartbeat-mutex*   (make-mutex))
(define *api-process-request-count* 0)

;; (define db:dbfile-path common:get-db-tmp-area)
(define *global-db-store* (make-hash-table))


;;======================================================================
;; end globals
;;======================================================================

;; Generate a unique signature for this process, used at both client and
;; server side
(define (rmt:mk-signature)
  (message-digest-string (md5-primitive) 
			 (with-output-to-string
			   (lambda ()
			     (write (list (current-directory)
                                          (current-process-id)
					  (argv)))))))

(define (rmt:get-signature) 
  (if *my-signature* *my-signature*
      (let ((sig (rmt:mk-signature)))
        (set! *my-signature* sig)
        *my-signature*)))


;;                       0           1              2              3
(defstruct launch:einf (pid #t)(exit-status #t)(exit-code #t)(rollup-status 0))

;; copied from egg call-with-environment-variables
;;
(define (call-with-environment-variables variables thunk)

	      #f)))))

(define (common:simple-file-release-lock fname)
  (handle-exceptions
      exn
      #f ;; I don't really care why this failed (at least for now)
    (delete-file* fname)))

(define (common:with-simple-file-lock fname proc)
  (let* ((lkfname (conc fname ".lock")))
    (common:simple-file-lock-and-wait lkfname)
    (let ((res (proc)))
      (common:simple-file-release-lock lkfname)
      res)))

;;======================================================================
;; PUlled below from common.scm
;;======================================================================

;; execute thunk, return value.  If exception thrown, trap exception, return #f, and emit nonfatal condition note to *default-log-port* .
;; arguments - thunk, message

		  d
		  (begin
		    ;; (if (common:low-noise-print 60 "tests:get-tests-search-path" d)
		    ;;	(debug:print 0 *default-log-port* "WARNING: problem with directory " d ", dropping it from tests path"))
		    #f)))
	    (append paths (list (conc *toppath* "/tests"))))))

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

#;(define (server:get-best-guess-address hostname)
  (let ((res #f))
    (for-each 
     (lambda (adr)
       (if (not (eq? (u8vector-ref adr 0) 127))
	   (set! res adr)))
     ;; NOTE: This can fail when there is no mention of the host in /etc/hosts. FIXME
     (vector->list (hostinfo-addresses (hostname->hostinfo hostname))))
    (string-intersperse 
     (map number->string
	  (u8vector->list
	   (if res res (hostname->ip hostname)))) ".")))

;; 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 (server:get-best-guess-address hostname)
  (let ((all-addresses (get-all-ips hostname)))
    (cond
     ((null? all-addresses)
      hostname #;(get-host-name))                                          ;; no interfaces?
     ((eq? (length all-addresses) 1)
      (car all-addresses))                      ;; only one to choose from, just go with it
     (else
      (car (sort all-addresses ip-pref-less?))))))

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

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

(define (tests:readlines filename)
  (call-with-input-file filename
    (lambda (p)
      (let loop ((line (read-line p))
                 (result '()))
        (if (eof-object? line)

	 configf:set-section-var
	 configf:var-is?
	 configf:write-alist
	 configf:write-config
	 find-config
	 getenv
	 mytarget
	 my-with-lock
	 nice-path
	 process:cmd-run->list
	 runconfig:read
	 runconfigs-get
	 safe-setenv
	 setenv
	 configf:eval-string-in-environment

;;======================================================================
;; parameters
;;======================================================================

;; while targets are Megatest specific they are a useful concept
(define mytarget (make-parameter #f))

;; fake locker
(define (fake-locker fname proc)(proc))

;; locking is optional, many environments don't care (e.g. running on one machine)
;; NOTE: the locker must follow the same syntax as with-dot-lock*
;;       with-dot-lock* has problems if /tmp and the file being
;;       locked are not on the same filesystem
;;
(define my-with-lock (make-parameter fake-locker)) ;; with-dot-lock*))

;;======================================================================
;; move debug stuff to separate module then put these back where they belong
;;======================================================================
;;======================================================================
;; lookup routines - replicated from configf
;;======================================================================

    (configf:alist->config
     (with-input-from-file fname read))))

;;======================================================================
;; DO THE LOCKING AROUND THE CALL
;;======================================================================
;;
(define (configf:write-alist cdat fname #!optional (check-written #f))
  ;; (if (not (common:faux-lock fname))
  ;; (debug:print 0 *default-log-port* "INFO: NEED LOCKING ADDED HERE " fname)
  ((my-with-lock)
   fname
   (lambda ()
     (let* ((dat  (configf:config->alist cdat))
            (res
             (begin
               (with-output-to-file fname ;; first write out the file
		 (lambda ()
                   (pp dat)))
               ;; I don't like this. It makes write-alist complicated
	       ;; move to something like write-and-verify-alist. -mrw-
               (if check-written
		   (if (file-exists? fname)   ;; now verify it is readable
		       (if (configf:read-alist fname)
			   'data-good ;; data is good.

			   (handle-exceptions
			       exn
			       (begin
				 (debug:print 0 *default-log-port* "deleting " fname " failed, exn=" exn)

				 'data-bad)
			     (debug:print 0 *default-log-port* "WARNING: content " dat " for cache " fname " is not readable. Deleting generated file.")
			     (delete-file fname)))

		       'data-not-there)
		   'data-not-checked))))
       res))))
  
(define (common:get-fields cfgdat)
  (let ((fields (hash-table-ref/default cfgdat "fields" '())))
    (map car fields)))

)

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


# Flavors include: simple, full and none






# look at build.config (not a version controlled file and



# create ulex.scm and dbmgr.scm





if [[ -e transport-flavor ]];then




    FLAVOR=$(cat transport-flavor)




























else


    FLAVOR=simple












fi







sed -e "s/FLAVOR/$FLAVOR/" ulex.scm.template > ulex.scm


sed -e "s/FLAVOR/$FLAVOR/" dbmgrmod.scm.template > dbmgrmod.scm

	srfi-1
	regex regex-case srfi-69
	typed-records
	sparse-vectors
	format
	srfi-4
	srfi-14
	srfi-18
	)

;; (include "common_records.scm")
;; (include "db_records.scm")
;; (include "run_records.scm")
;; (include "task_records.scm")
;; (include "megatest-version.scm")

(define (dashboard:do-update-rundat tabdat)
  (dboard:update-rundat
   tabdat
   (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%")
   (dboard:tabdat-numruns tabdat)
   (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%")
   ;; generate key patterns from the target stored in tabdat
   (let* ((dbkeys  (dboard:tabdat-dbkeys tabdat)))
     (let ((fres   (if (dboard:tabdat-target tabdat)
                       (let ((ptparts (append (dboard:tabdat-target tabdat)(make-list (length dbkeys) "%"))))
                         (map (lambda (k v)(list k v)) dbkeys ptparts))
                       (let ((res '()))
                         (for-each (lambda (key)
                                     (if (not (equal? key "runname"))
                                         (let ((val (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) key #f)))

(import dashboard)

;; ease debugging by loading ~/.dashboardrc
(let ((debugcontrolf (get-debugcontrolf)))
  (if debugcontrolf
      (load debugcontrolf)))

(import srfi-18)

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

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

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

(include "ulex-simple/dbmgr.scm")

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

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

(include "ulex-FLAVOR/dbmgr.scm")

;; open or create the disk db file
;; create and fill the inmemory db
;; assemble into dbr:dbdat struct and return
;; 
(define (db:open-dbdat apath dbfile dbinit-proc)
  (let* ((db       (db:open-run-db dbfile dbinit-proc))
	 (inmem    (db:open-inmem-db dbinit-proc))
	 (dbdat    (make-dbr:dbdat
		    db:     db
		    inmem:  inmem
		    ;; run-id: run-id  ;; no can do, there are many run-id values that point to single db
		    fname:  dbfile)))
    (assert (and (sqlite3:database? db)(sqlite3:database? inmem))
	    "FATAL: should have both inmem and on-disk db at this time.")
    ;; now sync the disk file data into the inmemory db
    (db:sync-tables (db:sync-all-tables-list) '("last_update" . 0) db inmem)
    ;; (sqlite3:finalize! db) ;; open and close every sync
    dbdat))













;; open the disk database file
;; NOTE: May need to add locking to file create process here
;; returns an sqlite3 database handle
;;
(define (db:open-run-db dbfile dbinit-proc)
  (let* ((parent-dir (pathname-directory dbfile)))

;; called in http-transport and replicated in rmt.scm for *local* access. 
;;
(define (db:setup db-file) ;; run-id)
  (assert *toppath* "FATAL: db:setup called before toppath is available.")
  (let* ((dbstruct (or *dbstruct-db* (make-dbr:dbstruct))))
    (db:get-dbdat dbstruct *toppath* db-file)
    (if (not *dbstruct-db*)(set! *dbstruct-db* dbstruct))
    (assert (db:check-setup dbstruct *toppath* db-file) "FATAL: db:setup did NOT complete properly")
    dbstruct))

(define (db:check-setup dbstruct apath dbfile)
  (let* ((dbdat       (db:get-dbdat dbstruct apath dbfile))
	 (dbfullname  (conc apath "/" dbfile))
	 (db          (dbr:dbdat-db dbdat)) ;; (db:open-run-db dbfullname db:initialize-db)) ;; 
	 (inmem       (dbr:dbdat-inmem dbdat)))
    (and (sqlite3:database? db)
	 (sqlite3:database? inmem))))

;;======================================================================
;; setting/getting a lock on the db for only one server per db
;;
;;  NOTE:
;;       These operate directly on the disk file, NOT on the inmemory db
;;       The lockname is the filename (can have many to one, run-id to fname 

;; ;;     (mutex-unlock! *db-multi-sync-mutex*)
;; ;;     (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb)))

;; NOTE: touched logic is disabled/not done
;; sync run to disk if touched
;;
(define (db:sync-inmem->disk dbstruct apath dbfile #!key (force-sync #f))

  (let* ((dbdat       (db:get-dbdat dbstruct apath dbfile))
	 (dbfullname  (conc apath "/" dbfile))
	 (db          (dbr:dbdat-db dbdat)) ;; (db:open-run-db dbfullname db:initialize-db)) ;; 
	 (inmem       (dbr:dbdat-inmem dbdat))
	 (start-t     (current-seconds))
	 (last-update (dbr:dbdat-last-write dbdat))
	 (last-sync   (dbr:dbdat-last-sync dbdat)))
    (if (and (sqlite3:database? db)
	     (sqlite3:database? inmem))
	(begin
	  (debug:print-info 0 *default-log-port* "Syncing for dbfile: "dbfile", last-update: "last-update", last-sync: "last-sync)
	  (mutex-lock! *db-multi-sync-mutex*)
	  (let* ((update_info (cons "last_update" (if force-sync 0 last-update))) ;;  "last_update"))
   		 (need-sync   (or force-sync (>= last-update last-sync))))
	    (if need-sync
		(begin
		  (db:sync-tables (db:sync-all-tables-list) update_info inmem db)
		  (dbr:dbdat-last-sync-set! dbdat start-t))
		(debug:print 0 *default-log-port* "Skipping sync as nothing touched.")))
	  ;; (sqlite3:finalize! db)
	  (mutex-unlock! *db-multi-sync-mutex*))
	(debug:print-info 0 *default-log-port* "Skipping sync due to databases not being open."))))
    
;; TODO: Add final sync to this
;;
(define (db:safely-close-sqlite3-db db stmt-cache #!key (try-num 3))
  (if (<= try-num 0)
      #f
      (handle-exceptions
	  exn
	(begin
	  (print "Attempt to safely close sqlite3 db failed. Trying again. exn=" exn)
	  (thread-sleep! 3)
	  (sqlite3:interrupt! db)
	  (db:safely-close-sqlite3-db db stmt-cache try-num: (- try-num 1)))
	(if (sqlite3:database? db)
	    (let* ((stmts (and stmt-cache (hash-table-ref/default stmt-cache db #f))))
	      (if stmts (map sqlite3:finalize! (hash-table-values stmts)))
	      (sqlite3:finalize! db)
	      #t)
	    #f))))

;; close all opened run-id dbs
(define (db:close-all dbstruct)
  (assert (dbr:dbstruct? dbstruct) "FATAL: db:close-all called with dbstruct not set up.")
  (handle-exceptions
   exn
   (begin
     (debug:print 0 *default-log-port* "WARNING: Finalizing failed, "  ((condition-property-accessor 'exn 'message) exn) ", note - exn=" exn)
     (print-call-chain *default-log-port*))
   ;; (db:sync-touched dbstruct 0 force-sync: #t) ;; NO. Do not do this here. Instead we rely on a server to be started when there are writes, even if the server itself is not going to be used as a server.

                              id           INTEGER PRIMARY KEY,
                              test_id      INTEGER,
                              state        TEXT DEFAULT 'new',
                              status       TEXT DEFAULT 'n/a',
                              archive_type TEXT DEFAULT 'bup',
                              du           INTEGER,
                              archive_path TEXT);")))
    (debug:print 0 *default-log-port* "creating triggers from init")
    (db:create-triggers db)    
    db)) ;; )

;;======================================================================
;; A R C H I V E S
;;======================================================================

;; dneeded is minimum space needed, scan for existing archives that 
;; are on disks with adequate space and already have this test/itempath

(define (db:set-run-state-status dbstruct run-id state status )
  (db:with-db
   dbstruct #f #f
   (lambda (db)
          (sqlite3:execute db "UPDATE runs SET status=?,state=? WHERE id=?;" status state run-id))))



(define (db:get-run-status dbstruct run-id)
  (let ((res "n/a"))
    (db:with-db
     dbstruct #f #f
     (lambda (db)
       (sqlite3:for-each-row 
	(lambda (status)

      ;; "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id NOT IN (SELECT id FROM runs WHERE state='deleted') AND NOT (uname = 'n/a' AND item_path = '');")
      "SELECT count(id) FROM tests WHERE state in ('RUNNING','REMOTEHOSTSTART','LAUNCHED') AND run_id=?;" 
      run-id)))) ;; NOT IN (SELECT id FROM runs WHERE state='deleted');")

;; NEW BEHAVIOR: Look only at single run with run-id
;; 
;; (define (db:get-running-stats dbstruct run-id)
(define (db:get-count-tests-running-for-run-id dbstruct run-id) 


  (let* ((qry  "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=?;")) ;; )
    (db:with-db
     dbstruct
     run-id
     #f
     (lambda (db)
       (let* (#;(stmth (db:get-cache-stmth dbstruct db qry)))
	 #;(sqlite3:first-result stmth run-id)
	 (sqlite3:first-result db qry run-id)
	 )))))

;; For a given testname how many items are running? Used to determine
;; probability for regenerating html
;;
(define (db:get-count-tests-running-for-testname dbstruct run-id testname)
  (db:with-db
   dbstruct

	(list newstate newstatus))))

(define (db:set-state-status-and-roll-up-run dbstruct run-id curr-state curr-status)
  ;; (mutex-lock! *db-transaction-mutex*)
    (db:with-db
     dbstruct #f #f
     (lambda (db)
;;       (let ((tr-res
              (sqlite3:with-transaction
               db
               (lambda ()
                 (let* ((state-status-counts  (db:get-all-state-status-counts-for-run dbstruct run-id))
			(state-statuses       (db:roll-up-rules state-status-counts #f #f ))
                        (newstate             (car state-statuses))
                        (newstatus            (cadr state-statuses))) 
                   (if (or (not (eq? newstate curr-state)) (not (eq?  newstatus curr-status)))
                       (begin
			 (db:set-run-state-status dbstruct run-id newstate newstatus)
			 #t) ;; changes made
		       #f) ;; no changes
		   ))))))
         ;; (mutex-unlock! *db-transaction-mutex*)
;;          tr-res))))


(define (db:get-all-state-status-counts-for-run dbstruct run-id)
 (let* ((test-count-recs (db:with-db
                          dbstruct #f #f
                          (lambda (db)
                            (sqlite3:map-row

(declare (uses mtver))
(declare (uses debugprint))
(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses rmtmod))
(declare (uses mtargs))
(declare (uses testsmod))
(declare (uses dbmgrmod))

(module dcommon
	*

 (import scheme
	 chicken.base
	 chicken.condition

	 srfi-69
	 sparse-vectors
	 srfi-1
	 )

(import mtver
	dbmod
	dbmgrmod
	commonmod
	debugprint
	configfmod
	rmtmod
	;; gutils
	(prefix mtargs args:)
	testsmod)

(declare (unit debugprint))
(declare (uses mtargs))

(module debugprint
	*
	
;;(import scheme chicken data-structures extras files ports)
(import scheme
	chicken.base
	chicken.string
	chicken.time
	chicken.time.posix
	chicken.port
	chicken.process-context
	chicken.process-context.posix
	
	(prefix mtargs args:)
	srfi-1
	system-information
	)

;;======================================================================
;; debug stuff
;;======================================================================

(define verbosity (make-parameter '()))
(define *default-log-port*  (current-error-port))
(define debug:print-logger (make-parameter #f)) ;; set to a proc to call on every logging print
	 
(define (debug:setup)
  (let ((debugstr (or (args:get-arg "-debug")
      		      (args:get-arg "-debug-noprop")
      		      (get-environment-variable "MT_DEBUG_MODE"))))
    (verbosity (debug:calc-verbosity debugstr 'q))
    (debug:check-verbosity (verbosity) debugstr)

(define (debug:handle-remote-logging params)
  (if (debug:print-logger) ;; NOTE: turn params into string to keep things simple for now
      ((debug:print-logger)(conc "REMOTE ("(get-host-name)", pid="(current-process-id)") "
				 (string-intersperse (map conc params) " ") "; "
				 (string-intersperse (command-line-arguments) " ")))))

(define debug:enable-timestamp (make-parameter #t))

(define (debug:timestamp)
  (if (debug:enable-timestamp)
      (conc (time->string 
	     (seconds->local-time (current-seconds)) "%H:%M:%S") " ")
      ""))

  (define (debug:print n e . params)
  (if (debug:debug-mode n)
      (with-output-to-port (or e (current-error-port))
	(lambda ()
	  ;; (if *logging*
	      ;; (db:log-event (apply conc params))
	  (apply print (debug:timestamp) params)
	  (debug:handle-remote-logging params)
	  )))
  #t ;; only here to make remote stuff happy. It'd be nice to fix that ...
  )

(define (debug:print-error n e . params)
  ;; normal print
  (if (debug:debug-mode n)
      (with-output-to-port (if (port? e) e (current-error-port))
	(lambda ()
	  (apply print "ERROR: " (debug:timestamp) params)
	  (debug:handle-remote-logging (cons "ERROR: " params))
	  )))
  ;; pass important messages to stderr
  (if (and (eq? n 0)(not (eq? e (current-error-port)))) 
      (with-output-to-port (current-error-port)
	(lambda ()
	  (apply print "ERROR: " (debug:timestamp) params)
	  ))))

(define (debug:print-info n e . params)
  (if (debug:debug-mode n)
      (with-output-to-port (if (port? e) e (current-error-port))
	(lambda ()
	  (apply print "INFO: (" n ") "(debug:timestamp) params) ;; res)
	  (debug:handle-remote-logging (cons "INFO: " params))
	  ))))

(define (debug:print-warn n e . params)
  (if (debug:debug-mode n)
      (with-output-to-port (if (port? e) e (current-error-port))
	(lambda ()
	  (apply print "WARN: (" n ") " (debug:timestamp) params) ;; res)
	  (debug:handle-remote-logging (cons "WARN: " params))
	  ))))
)

	  ;; (db:test-remove-steps db run-id testname itemdat)
	  ;; now is also a good time to write the .testconfig file
	  (let* ((tconfig-fname   (conc work-area "/.testconfig"))
		 (tconfig-tmpfile (conc tconfig-fname ".tmp"))
		 (tconfig         (tests:get-testconfig test-name item-path tconfigreg #t force-create: #t)) ;; 'return-procs)))
		 (scripts (configf:get-section tconfig "scripts")))
	    ;; create .testconfig file
	    (configf:write-alist tconfig tconfig-tmpfile #t) ;; the #t forces a check of the written data
	    (assert (file-exists? tconfig-tmpfile) "FATAL: We just wrote the dang file, how can it not exist?")
	    (move-file tconfig-tmpfile tconfig-fname #t)
	    (delete-file* ".final-status")

	    ;; extract scripts from testconfig and write them to files in test run dir
	    (for-each
	     (lambda (scriptdat)
	       (match scriptdat

;; > 3 RUNNING with not test_dead do nothing (run should already be RUNNING/ na
;; > 0 RUNNING and test_dead then send KILLREQ ==> COMPLETED
;; 0 RUNNING ==> this is actually the first condition, should not get here

(define (runs:end-of-run-check run-id )
  (let* ((not-completed-cnt (rmt:get-not-completed-cnt run-id))  
	 (running-cnt (rmt:get-count-tests-running-for-run-id run-id))
	 (all-test-launched (rmt:get-var run-id (conc "launch-complete-" run-id)))
	 (current-state (rmt:get-run-state run-id))
	 (current-status (rmt:get-run-status run-id)))
    ;;get-vars run-id to query metadata table to check if all completed. if all-test-launched = yes then only not-completed-cnt = 0 means everyting is completed if no entry found in the table do nothing 
    (debug:print 0 *default-log-port* "Running test cnt :" running-cnt)                      
    (rmt:set-state-status-and-roll-up-run  run-id current-state current-status)
    (runs:update-junit-test-reporter-xml run-id) 
    (cond 

;;

(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 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 megatest
	*

  (import scheme
	  chicken.base
	  chicken.bitwise
	  chicken.condition
	  ;; chicken.csi

	  srfi-98
	  srfi-69

	  ;; local modules
	  autoload
	  adjutant
	  csv-xml
	  ;; hostinfo
	  mtver
	  mutils
	  cookie
	  csv-xml
	  ducttape-lib
	  (prefix mtargs args:)
	  pkts

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

     			 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

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!

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

     				       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
     

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

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




)

(import scheme
	chicken.base
	chicken.condition
	chicken.string
	chicken.sort
	
	list-utils
	;; postgresql
	srfi-1
	srfi-69
	typed-records
	
	(prefix dbi dbi:)
	configfmod
	(prefix mtargs args:)

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

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

;; generate entries for ~/.megatestrc with the following
;;
;;  grep define ../rmt.scm | grep rmt: |perl -pi -e 's/\(define\s+\((\S+)\W.*$/\1/'|sort -u

(declare (unit rmtmod))

(declare (uses apimod))
(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses dbmod))
(declare (uses debugprint))
(declare (uses itemsmod))
(declare (uses mtargs))
(declare (uses mtver))
(declare (uses pgdb))
(declare (uses portloggermod))
(declare (uses servermod))
(declare (uses tasksmod))
(declare (uses ulex))
(declare (uses dbmgrmod))

(module rmtmod
	*
	
(import scheme
		
	chicken.base

	chicken.process-context.posix
	chicken.sort
	chicken.string
	;; chicken.tcp
	chicken.random
	chicken.time
	chicken.time.posix

	
	directory-utils
	format
	;; http-client
	;; intarweb
	matchable
	md5
	message-digest
	;; nng ;; nanomsg
	(prefix base64 base64:)
	(prefix sqlite3 sqlite3:)
	regex
	s11n
	;; spiffy
	;; spiffy-directory-listing
	;; spiffy-request-vars

	pgdb
	pkts
	portloggermod
	(prefix mtargs args:)
	servermod
	stml2
	tasksmod











































































































































































































































	dbmgrmod

	ulex




	)



































































































;;======================================================================
;;
;; A C T U A L   A P I   C A L L S  
;;
;;======================================================================














;;======================================================================
;;  M I S C
;;======================================================================

(define (rmt:login run-id)
  (rmt:send-receive 'login run-id (list *toppath* megatest-version *my-signature*)))

		     dbh
		     spec-id target run-name state status owner event-time comment fail-count pass-count  area-id last-update publish-time))
		       (let* ((smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" #f)))
             (if (or (not smallest-time) (< last-update smallest-time))
        				(hash-table-set! smallest-last-update-time "smallest-time" last-update))
             (tasks:run-id->mtpg-run-id dbh cached-info run-id area-info smallest-last-update-time))
		  #f)))))))

(define (tasks:sync-test-gen-data dbh cached-info test-data-ids smallest-last-update-time)
  (let ((test-ht (hash-table-ref cached-info 'tests))
        (data-ht (hash-table-ref cached-info 'data)))
    (for-each
     (lambda (test-data-id)
        (let* ((test-data-info  (rmt:get-data-info-by-id test-data-id))
               (data-id (db:test-data-get-id  test-data-info))

  (not (equal? (common:get-last-run-version)
               (common:version-signature))))

(define (common:api-changed?)
  (not (equal? (substring (->string megatest-version) 0 4)
               (substring (conc (common:get-last-run-version)) 0 4))))


















































(define (std-exit-procedure)
  ;;(common:telemetry-log-close)
  (on-exit (lambda () 0))
  ;;(debug:print-info 13 *default-log-port* "std-exit-procedure called; *time-to-exit*="*time-to-exit*)
  (let ((no-hurry  (if (bdat-time-to-exit *bdat*) ;; hurry up
		       #f
		       (begin
			 (bdat-time-to-exit-set! *bdat* #t)
			 #t))))
    (debug:print-info 4 *default-log-port* "starting exit process, finalizing databases.")
    (if (and no-hurry (debug:debug-mode 18))
	(rmt:print-db-stats))
    (let ((th1 (make-thread
		(lambda () ;; thread for cleaning up, give it five seconds
		  (let* ((start-time (current-seconds)))
		    #;(if *db-serv-info*
			(let* ((host (servdat-host *db-serv-info*))
			       (port 	       (servdat-port *db-serv-info*)))
			  (debug:print-info 0 *default-log-port* "Shutting down server/responder.")
			  ;;
			  ;; TODO - add flushing/waiting on the work queue
			  ;;
			  (rmt:server-shutdown host port)
			  (portlogger:open-run-close portlogger:set-port port "released")))
				
		    (debug:print-info 0 *default-log-port* "Shutdown activities completed in "(- (current-seconds) start-time)" seconds"))
		  ;; (if *dbstruct-db* (db:close-all *dbstruct-db*)) ;; one second allocated
		  #;(if (bdat-task-db *bdat*)    ;; TODO: Check that this is correct for task db
		  (let ((db (cdr (bdat-task-db *bdat*))))
		  (if (sqlite3:database? db)
		  (begin
		  (debug:print-info 0 *default-log-port* "Closing down task db "db)

      (thread-start! th2)
      (thread-join! th1)
      )
    )

  0)






;; called in megatest.scm, host-port is string hostname:port
;;
;; NOTE: This is NOT called directly from clients as not all transports support a client running
;;       in the same process as the server. 
;;
;; conn is a conndat record
;;
#;(define (server:ping uconn #!key (do-exit #f))

  (let* ((srvkey (conndat-srvkey uconn))
	 (msg (sexpr->string '(ping ,srvkey))))
    (send-receive uconn 'ping msg))) ;; (server-ready? host port server-id))

;;======================================================================
;; http-transportmod.scm contents moved here
;;======================================================================

(define (http-transport:make-server-url hostport)
  (if (not hostport)
      #f
      (conc "http://" (car hostport) ":" (cadr hostport))))

;;======================================================================
;; S E R V E R
;; ======================================================================

;; (define (http-get-function fnkey)
;;   (hash-table-ref/default *http-functions* fnkey (lambda () "nothing here yet")))

















































































































;;======================================================================
;; C L I E N T S
;;======================================================================

(define (rmt:get-time-to-cleanup)
  (let ((res #f))

  (set! *http-connections-next-cleanup* (+ (current-seconds) 10))
  (mutex-unlock! *http-mutex*))

(define (rmt:inc-requests-and-prep-to-close-all-connections)
  (mutex-lock! *http-mutex*)
  (set! *http-requests-in-progress* (+ 1 *http-requests-in-progress*)))










































































































































































































































































































































































































































































































































































































































































)

;;======================================================================
;; A T T I C
;;======================================================================

	(currtime (current-seconds)))
    (if (> (- currtime lasttime) waitval)
	(begin
	  (hash-table-set! *runs:denoise* key currtime)
	  #t)
	#f)))

(define *too-soon-delays* (make-hash-table))

;; to-soon delay, when matching event happened in less than dseconds delay wseconds
;;
(define (runs:too-soon-delay key dseconds wseconds)
  (let* ((last-time (hash-table-ref/default *too-soon-delays* key #f)))
    (if (and last-time
	     (< (- (current-seconds) last-time) dseconds))
	(begin
	  (debug:print-info 4 *default-log-port* "Whoa, slow down there ... "key" has been too recently seen.")
	  (thread-sleep! wseconds)))
    (hash-table-set! *too-soon-delays* key (current-seconds))))

(define (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs)

  ;; Take advantage of a good place to exit if running the one-pass methodology
  (if (and (> (runs:dat-can-run-more-tests-count runsdat) 20)
	   (args:get-arg "-one-pass"))
      (exit 0))

    ;; Ensure all tests are registered in the test_meta table
    (runs:update-all-test_meta #f)

    ;; run the run prehook if there are no tests yet run for this run:
    ;;
    (runs:run-pre-hook run-id)
    ;; mark all test launched flag as false in the meta table 
    (rmt:set-var run-id (conc "launch-complete-" run-id) "no")
    (debug:print-info 1 *default-log-port* "Setting end-of-run to no")
    (let* ((config-reruns      (let ((x (configf:lookup *configdat* "setup" "reruns")))
			       (if x (string->number x) #f)))
	  (config-rerun-cnt (if config-reruns
			config-reruns
			1)))
    (if (eq? config-rerun-cnt run-count)

			   waitons:     waitons
			   testmode:    testmode
			   newtal:      newtal
			   itemmaps:    itemmaps
			   ;; prereqs-not-met: prereqs-not-met
			   )))
	(runs:dat-regfull-set! runsdat regfull)

	(runs:too-soon-delay (conc "loop delay " hed) 1 1)
	
	(if (> num-running 0)
            (set! last-time-some-running (current-seconds)))

        (if (> (current-seconds)(+ last-time-some-running (or (configf:lookup *configdat* "setup" "give-up-waiting") 36000)))
            (hash-table-set! *max-tries-hash* tfullname (+ (hash-table-ref/default *max-tries-hash* tfullname 0) 1)))
	;; (debug:print 0 *default-log-port* "max-tries-hash: " (hash-table->alist *max-tries-hash*))

	      (if (runs:lownoise (conc "been marked do not run " tfullname) 60)
		  (debug:print-info 0 *default-log-port* "Skipping test " tfullname " as it has been marked do not run due to being completed or not runnable"))
	      (if (or (not (null? tal))(not (null? reg)))
		  (loop (runs:queue-next-hed tal reg reglen regfull)
			(runs:queue-next-tal tal reg reglen regfull)
			(runs:queue-next-reg tal reg reglen regfull)
			reruns))))
	
        ;; (loop (car tal)(cdr tal) reg reruns))))

	(runs:incremental-print-results run-id)
	(debug:print 4 *default-log-port* "TOP OF LOOP => "
		     "test-name: " test-name
		     "\n  hed:         " hed
		     "\n  tal:         " (runs:pretty-long-list tal)

	  (debug:print-info 0 *default-log-port* "Have leftovers!")
	  (loop (car reg)(cdr reg) '() reruns))
	 (else
          (debug:print-info 4 *default-log-port* "cond branch - "  "rtq-9")
	  (debug:print-info 4 *default-log-port* "Exiting loop with...\n  hed=" hed "\n  tal=" tal "\n  reruns=" reruns))
	 ))) ;; end loop on sorted test names
    ;; this is the point where everything is launched and now you can mark the run in metadata table as all launched 
    (rmt:set-var run-id (conc "launch-complete-" run-id) "yes")  
        
    ;; now *if* -run-wait we wait for all tests to be done
    ;; Now wait for any RUNNING tests to complete (if in run-wait mode)
    ;; (if (runs:dat-load-mgmt-function runsdat)((runs:dat-load-mgmt-function runsdat)))
    (thread-sleep! 10) ;; I think there is a race condition here. Let states/statuses settle
    
    (let wait-loop ((num-running      (rmt:get-count-tests-running-for-run-id run-id))
		    (prev-num-running 0))
      ;; (debug:print-info 13 *default-log-port* "num-running=" num-running ", prev-num-running=" prev-num-running)
      (if (and (or (args:get-arg "-run-wait")
		   (equal? (configf:lookup *configdat* "setup" "run-wait") "yes"))
	       (> num-running 0))
	  (begin
	    ;; Here we mark any old defunct tests as incomplete. Do this every fifteen minutes
	    ;; (debug:print 0 *default-log-port* "Got here eh! num-running=" num-running " (> num-running 0) " (> num-running 0))
	    (thread-sleep! 5) ;; let's always sleep, prevents abutting calls to rum:get-count-tests-running-for-run-id - didn't help
	    (if (> (current-seconds)(+ last-time-incomplete 900))
		(let ((actual-num-running (rmt:get-count-tests-running-for-run-id run-id)))
		  (debug:print-info 0 *default-log-port* "Marking stuck tests as INCOMPLETE while waiting for run " run-id
				    ". Running as pid " (current-process-id) " on " (get-host-name))
		  (set! last-time-incomplete (current-seconds)) ;; FIXME, this might be causing slow down - use of set!
		  (runs:find-and-mark-incomplete-and-check-end-of-run run-id #f)
		  (debug:print-info 0 *default-log-port* "run-wait specified, waiting on " actual-num-running
				    " tests in RUNNING, REMOTEHOSTSTART or LAUNCHED state at "
				    (time->string (seconds->local-time (current-seconds))))))
	    ;; (if (runs:dat-load-mgmt-function runsdat)((runs:dat-load-mgmt-function runsdat)))

	    (wait-loop (rmt:get-count-tests-running-for-run-id run-id)
		       num-running))))
    ;; LET* ((test-record
    ;; we get here on "drop through". All done!
    ;; this is moved to runs:run-testes since this function is getting called twice to ensure everthing is completed. 
    ;; (debug:print-info 0 *default-log-port* "Calling Post Hook")    
    ;; (runs:run-post-hook run-id)

	      (debug:print-error 0 *default-log-port* "Attempted to " action-desc " but run area config file not found")
	      (exit 1))
	    ;; Extract out stuff needed in most or many calls
	    ;; here then call proc
	    (let* ((keyvals    (keys:target->keyval keys target)))
	      (proc target runname keys keyvals)))
	;; (if db (sqlite3:finalize! db))
	(set! *didsomething* #t)
	)))))

;;======================================================================
;; Lock/unlock runs
;;======================================================================

(define (runs:handle-locking target keys runname lock unlock user)
  (let* ((db       #f)

#!/bin/bash

rm tests/*log tests/simplerun/logs/*

script -c 'ck5 make unit'

(module serialize-envmod
   *
(import scheme
	z3
	base64
	chicken.port
	chicken.pretty-print
	chicken.process-context
	chicken.base
	)

(define (gen-output)
(let* ((env-str        (with-output-to-string (lambda () (pp (get-environment-variables)))))
       (zipped-env-str (z3:encode-buffer env-str))
       (b64-env-str    (base64-encode zipped-env-str)))
  (print b64-env-str))
)


(gen-output)

)

cleanup :
	killall mtest dboard -v -9 || true
	rm -rf *.log *.bak NB* logs/* .meta .db ../simpleruns/* lt

(module junk
	*

(import big-chicken
	rmtmod
	apimod
	dbmod
	srfi-18
	trace)

(trace-call-sites #t)
(trace 
  ;; db:get-tests-for-run
  ;; rmt:general-open-connection
  ;; rmt:open-main-connection
  ;; rmt:drop-conn
  ;; rmt:send-receive
  ;; rmt:log-to-main
  )

(define (make-run-id)
  (let* ((s (conc (current-process-id)))
	 (l (string-length s)))
    (string->number (substring s (- l 3) l))
    ))

(define (run)
  (let* ((th1 (make-thread
	       (lambda ()
		 (let loop ((r 0)
			    (i 1)
			    (s 0)) ;; sum
		   (let ((start-time (current-milliseconds))
			 (run-id     (+ r (make-run-id))))
		     (rmt:register-test run-id "test1" (conc "item_" i))
		     (thread-sleep! 0.01)
		     (let* ((qry-time (- (current-milliseconds) start-time))
			    (tot-query-time (+ qry-time s))
			    (avg-query-time (* 1.0 (/ tot-query-time i))))
		       (if (> qry-time 500)
			   (print "WARNING: rmt:register-test took more than 500ms, "qry-time"ms, i="i", avg-query-time="avg-query-time))
		       (if (eq? (modulo i 100) 0)
			   (print "For run-id="run-id", "(rmt:get-keys-write)" num tests registered="i" avg-query-time="avg-query-time))
		       (if (< i 500)
			   (loop r (+ i 1) tot-query-time)
			   (if (< r 100)
			       (let* ((start-time (current-milliseconds)))
				 (print "rmt:get-keys "(rmt:get-keys)" in "(- (current-milliseconds) start-time))
				 (print "Got "(length (rmt:get-tests-for-run run-id "%" '() '() 0 #f #f #f #f #f 0 #f))" tests for run "run-id)
				 (print "Average query time: "avg-query-time)
				 (loop (+ r 1) 0 tot-query-time))))))))
	       )))
    (thread-start! th1)
    (thread-join! th1)))

(run)
)

SYSTEM TEXT
RELEASE TEXT

[setup]
# Adjust max_concurrent_jobs to limit how much you load your machines
max_concurrent_jobs 50

[server]
timeout 3600

# Uncomment this to make the in-mem db into a disk based db (slower but good for debug)
# be aware that some unit tests will fail with this due to persistent data
#
# tmpdb /tmp

# This is your link path, you can move it but it is generally better to keep it stable
linktree #{getenv MT_RUN_AREA_HOME}/../simplelinks

# Valid values for state and status for steps, NB// It is not recommended you use this
[validvalues]
state start end completed

# Job tools are more advanced ways to control how your jobs are launched
[jobtools]
# useshell yes
launcher nbfake

# You can override environment variables for all your tests here
[env-override]
EXAMPLE_VAR example value

# As you run more tests you may need to add additional disks, the names are arbitrary but must be unique
[disks]
disk0 #{getenv MT_RUN_AREA_HOME}/../simpleruns

(print (rmt:get-keys))

# Test requirements are specified here
[requirements]
# waiton setup
priority 0

# Iteration for your tests are controlled by the items section
# [items]
# PARTOFDAY morning noon afternoon evening night

# test_meta is a section for storing additional data on your test
[test_meta]
author matt
owner  matt
description An example test

(import srfi-18 
	test 
	chicken.string
	chicken.process-context
	chicken.file
	chicken.pretty-print
	commonmod
	ulex
	)

(define test-work-dir (current-directory))

(work-method   'mailbox)   ;; threads, direct, mailbox
(return-method 'mailbox)   ;; polling, mailbox, direct

;; given list of lists
;;  ( ( msg expected param1 param2 ...)
;;    ( ... ) )
;; apply test to all
;;
(define (test-batch proc pname inlst #!key (post-proc #f))

;; read in all the _record files
;; (let ((files (glob "*_records.scm")))
;;   (for-each
;;    (lambda (file)
;;      (print "Loading " file)
;;      (load file))
;;    files))

(define-syntax run-in-thread
  (syntax-rules ()
    ((_ body ...)
     (let ((th1 (make-thread (lambda ()
			       body ...)
			     "the thread")))
       (thread-start! th1)
       (thread-join! th1)))))


(let* ((unit-test-name (list-ref (argv) 4))
       (fname          (conc "../unittests/" unit-test-name ".scm")))
  (if (file-exists? fname)
      (load fname)
      (print "ERROR: Unit test " unit-test-name " not found in unittests directory")))

;; (test-batch rmt:get-latest-host-load
;;             "rmt:get-latest-host-load"
;;             (list (list "localhost"  #t (get-host-name))
;;                   (list "not-a-host" #t "not-a-host"  ))
;;             post-proc: pair?)
;;                                            
;; (test #f #t (list? (rmt:get-changed-record-ids 0)))
;;

(run-in-thread

 ;; (test #f #f (begin (runs:update-all-test_meta #f) #f)) 
(test #f '("test1" "test2")(sort (alist-ref "tagtwo" (rmt:get-tests-tags) equal?) string<=?))
(test #f '() (rmt:get-key-val-pairs 0))
(test #f '("SYSTEM" "RELEASE") (rmt:get-keys))
(test #f '("SYSTEM" "RELEASE") (rmt:get-keys-write)) ;; dummy query to force server start
(test #f '() (rmt:get-key-vals 1))
(test #f (vector '("SYSTEM" "RELEASE") '()) (rmt:get-targets))
(test #f "" (rmt:get-target 1))

(test #f #t (vector? (rmt:get-runs "%" 10 0 keypatts)))
(test #f '(1)(rmt:get-all-run-ids))
(test #f '()(rmt:get-prev-run-ids 1))
(test #f #t (begin (rmt:lock/unlock-run 1 #t #f "mikey") #t))
(test #f "JUSTFINE" (rmt:get-run-status 1))
(test #f #t (begin (rmt:set-run-status 1 "NOTFINE" msg: "A message") #t))
(test #f #t (begin (rmt:update-run-event_time 1) #t))
)
;; (rmt:get-runs-by-patt  keys runnamepatt targpatt offset limit fields last-runs-update) ;; fields of #f uses default
;;
(let ((keys (rmt:get-keys))
      (rnp  "%")    ;; run name patt
      (tpt  "%/%")) ;; target patt
  (test-batch rmt:get-runs-by-patt
              "rmt:get-runs-by-patt"

;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

;; Run like this:
;;
;;  ./rununittest.sh server 1;(cd simplerun;megatest -stop-server 0)

(import rmtmod trace http-client apimod dbmod
	launchmod srfi-69 ulex system-information)

(trace-call-sites #t)
(trace
 ;; get-the-server
 ;; db:get-dbdat
 ;; rmt:find-main-server
;;  rmt:send-receive-real
;;  rmt:send-receive
 ;; sexpr->string
 ;; server-ready?
 ;; rmt:register-server
 ;; api:run-server-process
 ;; rmt:open-main-connection
 ;; rmt:general-open-connection
 ;; rmt:get-conny
 ;; common:watchdog
 ;; rmt:find-main-server
 ;; get-all-server-pkts
 ;; get-viable-servers
 ;; get-best-candidate
 ;; api:run-server-process
 ;; rmt:run
 ;; rmt:try-start-server
 ;;
 ;; ulex
 ;;
 ;; wait-and-close
 ;; run-listener
 )


(test #f #t (servdat? (let ((s (make-servdat)))
			  (set! *servdat* s)
			  s)))
(test #f #f (rmt:get-conn *servdat* *toppath* ".db/main.db"))
(test #f #f (rmt:find-main-server *servdat* *toppath* ".db/main.db"))
(define th1 (make-thread (lambda ()
			   (rmt:run (get-host-name)))
			 "rmt:run thread"))
(thread-start! th1)
(thread-sleep! 0.5) ;; give things some time to get going
;; switch to *db-serv-info* instead of *servdat*
(define *uconn* (servdat-uconn *db-serv-info*))
(print "*uconn*: " *uconn*)
(test #f #t (ulex-listener? (servdat-uconn *db-serv-info*)))
(test #f #t (string? (udat-host-port *uconn*)))


(run-in-thread
 (test #f 'ack (server-ready? *uconn* (udat-host-port *uconn*) (servdat-uuid *db-serv-info*))))
  





(test #f #t (rmt:open-main-connection *db-serv-info* *toppath*))
;; (pp (hash-table->alist (remotedat-conns *db-serv-info*)))
(test #f #t (conndat? (rmt:get-conn *db-serv-info* *toppath* ".db/main.db")))




(define remote *db-serv-info*)
(define keyvals  '(("SYSTEM" "a")("RELEASE" "b")))

(run-in-thread
 (test #f (map car keyvals) (rmt:get-keys)))



(exit)

 )

(define *db* (db:setup ".db/main.db"))

;; these let me cut and paste from source easily
(define apath *toppath*)
(define dbname ".db/2.db")
(define remote *db-serv-info*)
(define keyvals  '(("SYSTEM" "a")("RELEASE" "b")))

(test #f #t (rmt:open-main-connection remote apath))
(test #f #t (conndat? (rmt:get-conn *db-serv-info* *toppath* ".db/main.db")))
(test #f #t (conndat? (rmt:get-conn *db-serv-info* *toppath* ".db/main.db")))
(test #f 'server-started (rmt:send-receive-real *db-serv-info* *toppath* ".db/main.db"
					   'start-server `(,apath ,dbname)))


(thread-sleep! 2)
(test #f #t (rmt:general-open-connection *db-serv-info* *toppath* ".db/2.db"))

;; (let loop ((end-time (+ (current-seconds) 61)))
  (test #f #t (list? (rmt:get-servers-info *toppath*)))

  (test #f '("SYSTEM" "RELEASE") (rmt:get-keys))
  (test #f 1 (rmt:send-receive 'register-run #f (list keyvals "run1" "new" "n/a" "justme" #f)))
  ;; (print "Got here.")

  (test #f 1 (rmt:send-receive 'register-run 1 (list keyvals "run1" "new" "n/a" "justme" #f)))

  (test #f 2 (rmt:register-run keyvals "run2" "new" "n/a" "justme" #f))
  ;; (test #f 2 (rmt:deregister-server *db-serv-info* *toppath* iface port server-key dbname

  (test #f 2 (rmt:get-count-servers *db-serv-info* *toppath*))

  (test #f "run2" (rmt:get-run-name-from-id 2))
  (test #f #f     (rmt:send-receive 'get-test-info-by-id 2 '(2 1)))
  
  (test #f #t     (rmt:general-call 'update-cpuload-diskfree 2 1.5 1e6 1))
;;  (if (< (current-seconds) end-time)(loop end-time)))

;;======================================================================
;; 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* (make-servdat))

(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
	 (start-rmt:run (lambda ()
			  (let* ((th1 (make-thread (lambda ()(rmt:run (get-host-name))) "non-db mode server")))
			    (thread-start! th1)
			    (thread-sleep! 1)
			    (let loop ((count 0))
			      (assert (< count 30) "FATAL: responder failed to initialize in rmt:open-main-connection")
			      (if (or (not *db-serv-info*)
				      (not (servdat-uconn *db-serv-info*)))
				  (begin
				    (thread-sleep! 1)
				    (loop (+ count 1)))
				  (begin
				    (servdat-mode-set! *db-serv-info* 'non-db)
				    (servdat-uconn *db-serv-info*)))))))
	 (myconn    (servdat-uconn *db-serv-info*)))
    (cond
     ((not myconn)
      (start-rmt:run)
      (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 cmd rid params #!key (attemptnum 1)(area-dat #f))
  (let* ((apath      *toppath*)
	 (sinfo      *db-serv-info*)
	 (dbname     (db:run-id->dbname rid)))
    (if *localmode*
	(api:execute-requests *dbstruct* cmd params)
	(begin
	  (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)
  (assert (not (eq? 'primordial (thread-name (current-thread)))) "FATAL: Do not call rmt:send-receive-real in the primodial thread.")
  (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))
	   #;(th1      (make-thread (lambda ()
				    (set! res (send-receive uconn (conndat-hostport cdat) cmd params)))
				  "send-receive thread")))
      ;; (thread-start! th1)
      ;; (thread-join! th1)   ;; gratuitious thread stuff is so that mailbox is not used in primordial thead
      ;; 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)

;; 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 (and *db-serv-info*
		 (servdat-uconn *db-serv-info*))
	    (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 '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
;;======================================================================

;; 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-seconds))
	       (changed    #t)
	       (last-sdat  "not this"))
      (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-seconds) start-time) 2))
	    (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)
	      (sleep 4)
	      (if (> (- (current-seconds) start-time) 120) ;; been waiting for two minutes
		  (begin
		    (debug:print-error 0 *default-log-port* "transport appears to have died, exiting server")
		    (exit))
		  (loop start-time
			(equal? sdat last-sdat)
			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-real 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))
	      ;; start the watchdog

	      ;; is this really needed?
	      
	      #;(if watchdog
		  (if (not (member (thread-state watchdog)
				   '(ready running blocked
					   sleeping dead)))
		      (begin
			(debug:print-info 0 *default-log-port* "Starting watchdog thread (in state "(thread-state watchdog)")")
			(thread-start! watchdog))
		      (debug:print-info 0 *default-log-port* "Not starting watchdog thread (in state "(thread-state watchdog)")"))
		  (debug:print 0 *default-log-port* "ERROR: *watchdog* not setup, cannot start it."))
	      #;(loop (+ count 1) bad-sync-count start-time)
	      ))
	
	(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)))
			     "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)))

;;======================================================================
;; Nanomsg transport
;;======================================================================

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

#;(define (open-nn-connection host-port)
  (let ((req  (make-req-socket))
        (uri  (conc "tcp://" host-port)))
    (nng-dial req uri)
    (socket-set! req 'nng/recvtimeo 2000)
    req))

#;(define (send-receive-nn req msg)
  (nng-send req msg)
  (nng-recv req))

#;(define (close-nn-connection req)
  (nng-close! req))
  
;; ;; open connection to server, send message, close connection
;; ;;
;; (define (open-send-close-nn host-port msg #!key (timeout 3) ) ;; default timeout is 3 seconds
;;   (let ((req  (make-req-socket 'req))
;;         (uri  (conc "tcp://" host-port))
;;         (res  #f)
;;         ;; (contacts (alist-ref 'contact attrib))
;;         ;; (mode (alist-ref 'mode attrib))
;; 	)
;;     (socket-set! req 'nng/recvtimeo 2000)
;;     (handle-exceptions
;;      exn
;;      (let ((emsg ((condition-property-accessor 'exn 'message) exn)))
;;        ;; Send notification       
;;        (debug:print 0 *default-log-port* "ERROR: Failed to connect / send to " uri " message was \"" emsg "\"" )
;;        #f)
;;      (nng-dial req uri)
;;      ;; (print "Connected to the server " )
;;      (nng-send req msg)
;;      ;; (print "Request Sent")  
;;      (let* ((th1  (make-thread (lambda ()
;;                                  (let ((resp (nng-recv req)))
;;                                    (nng-close! req)
;;                                    (set! res (if (equal? resp "ok")
;;                                                  #t
;;                                                  #f))))
;;                                "recv thread"))
;;             (th2 (make-thread (lambda ()
;;                                 (thread-sleep! timeout)
;;                                 (thread-terminate! th1))
;; 			      "timer thread")))
;;        (thread-start! th1)
;;        (thread-start! th2)
;;        (thread-join! th1)
;;        res))))
;; 
#;(define (open-send-receive-nn host-port msg #!key (timeout 3) ) ;; default timeout is 3 seconds
  (let ((req  (make-req-socket))
        (uri  (conc "tcp://" host-port))
        (res  #f)) 
    (handle-exceptions
     exn
     (let ((emsg ((condition-property-accessor 'exn 'message) exn)))
       ;; Send notification      
       (debug:print 0 *default-log-port* "ERROR: Failed to connect / send to " uri " message was \"" emsg "\", exn=" exn)
       #f)
     (nng-dial req uri)
     (nng-send req msg)
     (let* ((th1  (make-thread (lambda ()
                                 (let ((resp (nng-recv req)))
                                   (nng-close! req)
                                   ;; (print resp)
                                   (set! res resp)))
                               "recv thread"))
            (th2 (make-thread (lambda ()
                                (thread-sleep! timeout)
                                (thread-terminate! th1))
                             "timer thread")))
       (thread-start! th1)
       (thread-start! th2)
       (thread-join! th1)
       res))))

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

;; run ping in separate process, safest way in some cases
;;
#;(define (server:ping-server ifaceport)
  (with-input-from-pipe 
   (conc (common:get-megatest-exe) " -ping " ifaceport)
   (lambda ()
     (let loop ((inl (read-line))
		(res "NOREPLY"))
       (if (eof-object? inl)
	   (case (string->symbol res)
	     ((NOREPLY)  #f)
	     ((LOGIN_OK) #t)
	     (else       #f))
	   (loop (read-line) inl))))))

;; NOT USED (well, ok, reference in rpc-transport but otherwise not used).
;;
#;(define (server:login toppath)
  (lambda (toppath)
    (set! *db-last-access* (current-seconds)) ;; might not be needed.
    (if (equal? *toppath* toppath)
	#t
	#f)))

;; (define server:sync-lock-token "SERVER_SYNC_LOCK")
;; (define (server:release-sync-lock)
;;   (db:no-sync-del! *no-sync-db* server:sync-lock-token))
;; (define (server:have-sync-lock?)
;;   (let* ((have-lock-pair (db:no-sync-get-lock *no-sync-db* server:sync-lock-token))
;;          (have-lock?     (car have-lock-pair))
;;          (lock-time      (cdr have-lock-pair))
;;          (lock-age       (- (current-seconds) lock-time)))
;;     (cond
;;      (have-lock? #t)
;;      ((>lock-age
;;        (* 3 (configf:lookup-number *configdat* "server" "minimum-intersync-delay" default: 180)))
;;       (server:release-sync-lock)
;;       (server:have-sync-lock?))
;;      (else #f))))

)

;; 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.string
	chicken.sort
	chicken.pretty-print
	
	address-info
	mailbox
	matchable
	;; queues
	regex
	regex-case
	simple-exceptions
	s11n
	srfi-1
	srfi-18
	srfi-4
	srfi-69
	system-information
	tcp6
	typed-records
	)

;; udat struct, used by both caller and callee
;; instantiated as uconn by convention
;;
(defstruct udat
  ;; the listener side
  (port #f)
  (host-port #f)
  (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)
  ) 

;; Parameters

;; work-method:
(define work-method (make-parameter 'mailbox))
;;    mailbox - all rdat goes through mailbox
;;    threads - all rdat immediately executed in new thread
;;    direct  - no queuing
;;

;; return-method, return the result to waiting send-receive:
(define return-method (make-parameter 'mailbox))
;;    mailbox - create a mailbox and use it for passing returning results to send-receive
;;    polling - put the result in a hash table keyed by qrykey and send-receive can poll it for result
;;    direct  - no queuing, result is passed back in single tcp connection
;;

;; ;; struct for keeping track of others we are talking to
;; ;;
;; (defstruct pdat
;;   (host-port  #f)
;;   (conns      '()) ;; list of pcon structs, pop one off when calling the peer
;;   )
;; 
;; ;; struct for peer connections, keep track of expiration etc.
;; ;;
;; (defstruct pcon
;;   (inp #f)
;;   (oup #f)
;;   (exp (+ (current-seconds) 59)) ;; expires at this time, set to (+ (current-seconds) 59)
;;   (lifetime (+ (current-seconds) 600)) ;; throw away and create new after five minutes
;;   )

;;======================================================================
;; 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* ((th1 (make-thread (lambda ()(ulex-cmd-loop uconn)) "Ulex command loop"))
	       (th2 (make-thread (lambda ()
				   (case (work-method)
				     ((mailbox limited)
				      (process-work-queue uconn))))
				 "Ulex work queue processor")))
	  ;; (tcp-buffer-size 2048)
	  (thread-start! th1)
	  (thread-start! th2)
	  (udat-cmd-thread-set! uconn th1)
	  (udat-work-queue-thread-set! uconn th2)
	  (print "cmd loop and process workers started, listening on "(udat-host-port uconn)".")
	  uconn)
	(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.
;;
;; NOTE: see below for beginnings of code to allow re-use of tcp connections
;;        - I believe (without substantial evidence) that re-using connections will
;;          be beneficial ...
;;
(define (send udata host-port qrykey cmd params)
  (let* ((my-host-port (udat-host-port udata))          ;; remote will return to this
	 (isme         #f #;(equal? host-port my-host-port)) ;; calling myself?
	 ;; dat is a self-contained work block that can be sent or handled locally
	 (dat          (list my-host-port qrykey cmd params #;(cons (current-seconds)(current-milliseconds)))))
    (cond
     (isme (ulex-handler udata dat)) ;; no transmission needed
     (else
      (handle-exceptions ;; TODO - MAKE THIS EXCEPTION CMD SPECIFIC?
	  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
			     (serialize dat oup)
			     (close-output-port oup)
			     (deserialize 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

(define (send-via-polling uconn host-port cmd data)
  (let* ((qrykey (make-cookie uconn))
	 (sres   (send uconn host-port qrykey cmd data)))
    (case sres
      ((ack)
       (let loop ((start-time (current-milliseconds)))
	 (if (> (current-milliseconds)(+ start-time 10000)) ;; ten seconds timeout
	     (begin
	       (print "ULEX ERROR: timed out waiting for response from "host-port", "cmd" "data)
	       #f)
	     (let* ((result (hash-table-ref/default (udat-mboxes uconn) qrykey #f))) ;; NOTE: we are re-using mboxes hash
	       (if result ;; result is '(status . result-data) or #f for nothing yet
		   (begin
		     (hash-table-delete! (udat-mboxes uconn) qrykey)
		     (cdr result))
		   (begin
		     (thread-sleep! 0.01)
		     (loop start-time)))))))
      (else
       (print "ULEX ERROR: Communication failed? sres="sres)
       #f))))

(define (send-via-mailbox uconn host-port cmd data)
  (let* ((cmbox     (get-cmbox uconn)) ;; would it be better to keep a stack of mboxes to reuse?
	 (qrykey    (car cmbox))
	 (mbox      (cdr cmbox))
	 (mbox-time (current-milliseconds))
	 (sres      (send uconn host-port qrykey cmd data))) ;; short res
    (if (eq? sres 'ack)
	(let* ((mbox-timeout-secs    120 #;(if (eq? 'primordial (thread-name (current-thread)))
				     #f
				     120)) ;; timeout)
	       (mbox-timeout-result 'MBOX_TIMEOUT)
	       (res                  (mailbox-receive! mbox mbox-timeout-secs mbox-timeout-result))
	       (mbox-receive-time    (current-milliseconds)))
	  ;; (put-cmbox uconn cmbox) ;; reuse mbox and cookie. is it worth it?
	  (hash-table-delete! (udat-mboxes uconn) qrykey)
	  (if (eq? res 'MBOX_TIMEOUT)
	      (begin
		(print "WARNING: mbox timed out for query "cmd", with data "data
		       ", waiting for response from "host-port".")

		;; here it might make sense to clean up connection records and force clean start?
		;; NO. The progam using ulex needs to do the reset. Right thing here is exception
		
		#f)  ;; convert to raising exception?
	      res))
	(begin
	  (print "ERROR: Communication failed? Got "sres)
	  #f))))
  
;; send a request to the given host-port and register a mailbox in udata
;; wait for the mailbox data and return it
;;
(define (send-receive uconn host-port cmd data)
  (let* ((start-time (current-milliseconds))
	 (result     (cond
		      ((member cmd '(ping goodbye)) ;; these are immediate
		       (send uconn host-port 'ping cmd data))
		      ((eq? (work-method) 'direct)
		       ;; the result from send will be the actual result, not an 'ack
		       (send uconn host-port 'direct cmd data))
		      (else
		       (case (return-method)
			 ((polling)
			  (send-via-polling uconn host-port cmd data))
			 ((mailbox) 
			  (send-via-mailbox uconn host-port cmd data))
			 (else
			  (print "ULEX ERROR: unrecognised return-method "(return-method)".")
			  #f)))))
	 (duration    (- (current-milliseconds) start-time)))
    ;; this is ONLY for development and debugging. It will be removed once Ulex is stable.
    (if (< 5000 duration)
	(print "ULEX WARNING: round-trip took "(inexact->exact (round (/ duration 1000)))
	       " seconds; "cmd", host-port="host-port", data="data))
    result))
    

;;======================================================================
;; responder side
;;======================================================================

;; take a request, rdat, and if not immediate put it in the work queue
;;
;; Reserved cmds; ack ping goodbye response
;;
(define (ulex-handler uconn rdat)
  (assert (list? rdat) "FATAL: ulex-handler give rdat as not list")
  (match rdat ;;  (string-split controldat)
    ((rem-host-port qrykey cmd params);; timedata)
     ;; (print "ulex-handler got: "rem-host-port" qrykey: "qrykey" cmd: "cmd" params: "params)
     (case cmd
       ;; ((ack )(print "Got ack! But why? Should NOT get here.") 'ack)
       ((ping)
	;; (print "Got Ping!")
	;; (add-to-work-queue uconn rdat)
	'ack)
       ((goodbye)
	;; just clear out references to the caller. NOT COMPLETE
	(add-to-work-queue uconn rdat)
	'ack)
       ((response) ;; this is a result from remote processing, send it as mail ...
	(case (return-method)
	  ((polling)
	   (hash-table-set! (udat-mboxes uconn) qrykey (cons 'ok params))
	   'ack)
	  ((mailbox)
	   (let ((mbox (hash-table-ref/default (udat-mboxes uconn) qrykey #f)))
	     (if mbox
		 (begin
		   (mailbox-send! mbox params) ;; params here is our result
		   'ack)
		 (begin
		   (print "ERROR: received result but no associated mbox for cookie "qrykey)
		   'no-mbox-found))))
	  (else (print "ULEX ERROR: unrecognised return-method "(return-method))
		'bad-return-method)))
       (else ;; generic request - hand it to the work queue
	(add-to-work-queue uconn rdat)
	'ack)))
    (else
     (print "ULEX ERROR: bad rdat "rdat)
     'bad-rdat)))

;; given an already set up uconn start the cmd-loop
;;
(define (ulex-cmd-loop uconn)
  (let* ((serv-listener (udat-socket uconn))
	 (listener      (lambda ()
			  (let loop ((state 'start))
			    (let-values (((inp oup)(tcp-accept serv-listener)))
			      ;; (mutex-lock! *send-mutex*) ;; DOESN'T SEEM TO HELP
			      (let* ((rdat  (deserialize inp)) ;; '(my-host-port qrykey cmd params)
				     (resp  (ulex-handler uconn rdat)))
				(serialize resp oup)
				(close-input-port inp)
				(close-output-port oup)
				;; (mutex-unlock! *send-mutex*) ;; DOESN'T SEEM TO HELP
				)
			      (loop state))))))
    ;; start N of them
    (let loop ((thnum   0)
	       (threads '()))
      (if (< thnum 100)
	  (let* ((th (make-thread listener (conc "listener" thnum))))
	    (thread-start! th)
	    (loop (+ thnum 1)
		  (cons th threads)))
	  (map thread-join! threads)))))

;; add a proc to the cmd list, these are done symetrically (i.e. in all instances)
;; so that the proc can be dereferenced remotely
;;
(define (set-work-handler uconn proc)
  (udat-work-proc-set! uconn proc))

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

;; rdat is (rem-host-port qrykey cmd params)
					     
(define (add-to-work-queue uconn rdat)
  #;(queue-add! (udat-work-queue uconn) rdat)
  (case (work-method)
    ((threads)
     (thread-start! (make-thread (lambda ()
				   (do-work uconn rdat))
				 "worker thread")))
    ((mailbox)
     (mailbox-send! (udat-work-queue uconn) rdat))
    ((direct)
     (do-work uconn rdat))
    (else
     (print "ULEX ERROR: work-method "(work-method)" not recognised, using mailbox.")
     (mailbox-send! (udat-work-queue uconn) rdat))))
     
;; move the logic to return the result somewhere else?
;;
(define (do-work uconn rdat)
  (let* ((proc (udat-work-proc uconn))) ;; get it each time - conceivebly it could change
    ;; put this following into a do-work procedure
    (match rdat
      ((rem-host-port qrykey cmd params)
       (let* ((start-time (current-milliseconds))
	      (result (proc rem-host-port qrykey cmd params))
	      (end-time (current-milliseconds))
	      (run-time (- end-time start-time)))
	 (case (work-method)
	   ((direct) result)
	   (else
	    (print "ULEX: work "cmd", "params" done in "run-time" ms")
	    ;; send 'response as cmd and result as params
	    (send uconn rem-host-port qrykey 'response result) ;; could check for ack
	    (print "ULEX: response sent back to "rem-host-port" in "(- (current-milliseconds) end-time))))))
      (MBOX_TIMEOUT 'do-work-timeout)
      (else
       (print "ERROR: rdat "rdat", did not match rem-host-port qrykey cmd params")))))

;; NEW APPROACH:
;;   
(define (process-work-queue uconn) 
  (let ((wqueue (udat-work-queue uconn))
	(proc   (udat-work-proc  uconn))
	(numthr (udat-numthreads uconn)))
    (let loop ((thnum    1)
	       (threads '()))
      (let ((thlst (cons (make-thread (lambda ()
					(let work-loop ()
					  (let ((rdat (mailbox-receive! wqueue 24000 'MBOX_TIMEOUT)))
					    (do-work uconn rdat))
					  (work-loop)))
				      (conc "work thread " thnum))
			 threads)))
	(if (< thnum numthr)
	    (loop (+ thnum 1)
		  thlst)
	    (begin
	      (print "ULEX: Starting "(length thlst)" worker threads.")
	      (map thread-start! thlst)
	      (print "ULEX: Threads started. Joining all.")
	      (map thread-join! thlst)))))))

;; below was to enable re-use of connections. This seems non-trivial so for
;; now lets open on each call
;;
;; ;; given host-port get or create peer struct
;; ;;
;; (define (udat-get-peer uconn host-port)
;;   (or (hash-table-ref/default (udat-peers uconn) host-port #f)
;;       ;; no peer, so create pdat and init it
;;       
;;       ;; NEED stack of connections, pop and use; inp, oup,
;;       ;; creation_time (remove and create new if over 24hrs old
;;       ;; 
;;       (let ((pdat (make-pdat host-port: host-port)))
;; 	(hash-table-set! (udat-peers uconn) host-port pdat)
;; 	pdat)))
;; 
;; ;; is pcon alive
;; 
;; ;; given host-port and pdat get a pcon
;; ;;
;; (define (pdat-get-pcon pdat host-port)
;;   (let loop ((conns (pdat-conns pdat)))
;;     (if (null? conns) ;; none? make and return - do NOT add - it will be pushed back on list later
;; 	(init-pcon (make-pcon))
;; 	(let* ((conn (pop conns)))
;; 	  
;; ;; given host-port get a pcon struct
;; ;;
;; (define (udat-get-pcon 
      
;;======================================================================
;; misc utils
;;======================================================================

(define (make-cookie uconn)
  (let ((newcnum (+ (udat-cnum uconn) 1)))
    (udat-cnum-set! uconn newcnum)
    (conc (udat-host-port uconn) ":"
	  newcnum)))

;; cookie/mboxes

;; we store each mbox with a cookie (<cookie> . <mbox>)
;;
(define (get-cmbox uconn)
  (if (null? (udat-avail-cmboxes uconn))
      (let ((cookie (make-cookie uconn))
	    (mbox   (make-mailbox)))
	(hash-table-set! (udat-mboxes uconn) cookie mbox)
	`(,cookie . ,mbox))
      (let ((cmbox (car (udat-avail-cmboxes uconn))))
	(udat-avail-cmboxes-set! uconn (cdr (udat-avail-cmboxes uconn)))
	cmbox)))

(define (put-cmbox uconn cmbox)
  (udat-avail-cmboxes-set! uconn (cons cmbox (udat-avail-cmboxes uconn))))

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

)

;;======================================================================
;; 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* (make-servdat))
;; 
;; (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
;; 	 (start-rmt:run (lambda ()
;; 			  (let* ((th1 (make-thread (lambda ()(rmt:run (get-host-name))) "non-db mode server")))
;; 			    (thread-start! th1)
;; 			    (thread-sleep! 1)
;; 			    (let loop ((count 0))
;; 			      (assert (< count 30) "FATAL: responder failed to initialize in rmt:open-main-connection")
;; 			      (if (or (not *db-serv-info*)
;; 				      (not (servdat-uconn *db-serv-info*)))
;; 				  (begin
;; 				    (thread-sleep! 1)
;; 				    (loop (+ count 1)))
;; 				  (begin
;; 				    (servdat-mode-set! *db-serv-info* 'non-db)
;; 				    (servdat-uconn *db-serv-info*)))))))
;; 	 (myconn    (servdat-uconn *db-serv-info*)))
;;     (cond
;;      ((not myconn)
;;       (start-rmt:run)
;;       (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 cmd rid params #!key (attemptnum 1)(area-dat #f))
  (let* ((apath      *toppath*)
	 (dbname     (db:run-id->dbname rid)))
	(api:execute-requests *dbstruct* 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)
;;   (assert (not (eq? 'primordial (thread-name (current-thread)))) "FATAL: Do not call rmt:send-receive-real in the primodial thread.")
;;   (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))
;; 	   #;(th1      (make-thread (lambda ()
;; 				    (set! res (send-receive uconn (conndat-hostport cdat) cmd params)))
;; 				  "send-receive thread")))
;;       ;; (thread-start! th1)
;;       ;; (thread-join! th1)   ;; gratuitious thread stuff is so that mailbox is not used in primordial thead
;;       ;; 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)
;; 
;; ;; 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 (and *db-serv-info*
;; 		 (servdat-uconn *db-serv-info*))
;; 	    (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 'ack) ;; yep, likely it is who we want on the other end
	res
  #f))
  #t)

;; ; 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
;; ;;======================================================================
;; 
;; ;; 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-seconds))
;; 	       (changed    #t)
;; 	       (last-sdat  "not this"))
;;       (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-seconds) start-time) 2))
;; 	    (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)
;; 	      (sleep 4)
;; 	      (if (> (- (current-seconds) start-time) 120) ;; been waiting for two minutes
;; 		  (begin
;; 		    (debug:print-error 0 *default-log-port* "transport appears to have died, exiting server")
;; 		    (exit))
;; 		  (loop start-time
;; 			(equal? sdat last-sdat)
;; 			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-real 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))
;; 	      ;; start the watchdog
;; 
;; 	      ;; is this really needed?
;; 	      
;; 	      #;(if watchdog
;; 		  (if (not (member (thread-state watchdog)
;; 				   '(ready running blocked
;; 					   sleeping dead)))
;; 		      (begin
;; 			(debug:print-info 0 *default-log-port* "Starting watchdog thread (in state "(thread-state watchdog)")")
;; 			(thread-start! watchdog))
;; 		      (debug:print-info 0 *default-log-port* "Not starting watchdog thread (in state "(thread-state watchdog)")"))
;; 		  (debug:print 0 *default-log-port* "ERROR: *watchdog* not setup, cannot start it."))
;; 	      #;(loop (+ count 1) bad-sync-count start-time)
;; 	      ))
;; 	
;; 	(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)))
			     "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)))
;; 
;; ;;======================================================================
;; ;; Nanomsg transport
;; ;;======================================================================
;; 
;; #;(define (is-port-in-use port-num)
;;   (let* ((ret #f))
;;     (let-values (((inp oup pid)
;; 		  (process "netstat" (list  "-tulpn" ))))
;;       (let loop ((inl (read-line inp)))
;;         (if (not (eof-object? inl))
;;             (begin 
;; 	      (if (string-search (regexp (conc ":" port-num)) inl)
;; 		  (begin
;; 					;(print "Output: "  inl)
;; 		    (set! ret  #t))
;; 		  (loop (read-line inp)))))))
;;     ret))
;; 
;; #;(define (open-nn-connection host-port)
;;   (let ((req  (make-req-socket))
;;         (uri  (conc "tcp://" host-port)))
;;     (nng-dial req uri)
;;     (socket-set! req 'nng/recvtimeo 2000)
;;     req))
;; 
;; #;(define (send-receive-nn req msg)
;;   (nng-send req msg)
;;   (nng-recv req))
;; 
;; #;(define (close-nn-connection req)
;;   (nng-close! req))
;;   
;; ;; ;; open connection to server, send message, close connection
;; ;; ;;
;; ;; (define (open-send-close-nn host-port msg #!key (timeout 3) ) ;; default timeout is 3 seconds
;; ;;   (let ((req  (make-req-socket 'req))
;; ;;         (uri  (conc "tcp://" host-port))
;; ;;         (res  #f)
;; ;;         ;; (contacts (alist-ref 'contact attrib))
;; ;;         ;; (mode (alist-ref 'mode attrib))
;; ;; 	)
;; ;;     (socket-set! req 'nng/recvtimeo 2000)
;; ;;     (handle-exceptions
;; ;;      exn
;; ;;      (let ((emsg ((condition-property-accessor 'exn 'message) exn)))
;; ;;        ;; Send notification       
;; ;;        (debug:print 0 *default-log-port* "ERROR: Failed to connect / send to " uri " message was \"" emsg "\"" )
;; ;;        #f)
;; ;;      (nng-dial req uri)
;; ;;      ;; (print "Connected to the server " )
;; ;;      (nng-send req msg)
;; ;;      ;; (print "Request Sent")  
;; ;;      (let* ((th1  (make-thread (lambda ()
;; ;;                                  (let ((resp (nng-recv req)))
;; ;;                                    (nng-close! req)
;; ;;                                    (set! res (if (equal? resp "ok")
;; ;;                                                  #t
;; ;;                                                  #f))))
;; ;;                                "recv thread"))
;; ;;             (th2 (make-thread (lambda ()
;; ;;                                 (thread-sleep! timeout)
;; ;;                                 (thread-terminate! th1))
;; ;; 			      "timer thread")))
;; ;;        (thread-start! th1)
;; ;;        (thread-start! th2)
;; ;;        (thread-join! th1)
;; ;;        res))))
;; ;; 
;; #;(define (open-send-receive-nn host-port msg #!key (timeout 3) ) ;; default timeout is 3 seconds
;;   (let ((req  (make-req-socket))
;;         (uri  (conc "tcp://" host-port))
;;         (res  #f)) 
;;     (handle-exceptions
;;      exn
;;      (let ((emsg ((condition-property-accessor 'exn 'message) exn)))
;;        ;; Send notification      
;;        (debug:print 0 *default-log-port* "ERROR: Failed to connect / send to " uri " message was \"" emsg "\", exn=" exn)
;;        #f)
;;      (nng-dial req uri)
;;      (nng-send req msg)
;;      (let* ((th1  (make-thread (lambda ()
;;                                  (let ((resp (nng-recv req)))
;;                                    (nng-close! req)
;;                                    ;; (print resp)
;;                                    (set! res resp)))
;;                                "recv thread"))
;;             (th2 (make-thread (lambda ()
;;                                 (thread-sleep! timeout)
;;                                 (thread-terminate! th1))
;;                              "timer thread")))
;;        (thread-start! th1)
;;        (thread-start! th2)
;;        (thread-join! th1)
;;        res))))
;; 
;; ;;======================================================================
;; ;; S E R V E R   U T I L I T I E S 
;; ;;======================================================================
;; 
;; ;; run ping in separate process, safest way in some cases
;; ;;
;; #;(define (server:ping-server ifaceport)
;;   (with-input-from-pipe 
;;    (conc (common:get-megatest-exe) " -ping " ifaceport)
;;    (lambda ()
;;      (let loop ((inl (read-line))
;; 		(res "NOREPLY"))
;;        (if (eof-object? inl)
;; 	   (case (string->symbol res)
;; 	     ((NOREPLY)  #f)
;; 	     ((LOGIN_OK) #t)
;; 	     (else       #f))
;; 	   (loop (read-line) inl))))))
;; 
;; ;; NOT USED (well, ok, reference in rpc-transport but otherwise not used).
;; ;;
;; #;(define (server:login toppath)
;;   (lambda (toppath)
;;     (set! *db-last-access* (current-seconds)) ;; might not be needed.
;;     (if (equal? *toppath* toppath)
;; 	#t
;; 	#f)))
;; 
;; ;; (define server:sync-lock-token "SERVER_SYNC_LOCK")
;; ;; (define (server:release-sync-lock)
;; ;;   (db:no-sync-del! *no-sync-db* server:sync-lock-token))
;; ;; (define (server:have-sync-lock?)
;; ;;   (let* ((have-lock-pair (db:no-sync-get-lock *no-sync-db* server:sync-lock-token))
;; ;;          (have-lock?     (car have-lock-pair))
;; ;;          (lock-time      (cdr have-lock-pair))
;; ;;          (lock-age       (- (current-seconds) lock-time)))
;; ;;     (cond
;; ;;      (have-lock? #t)
;; ;;      ((>lock-age
;; ;;        (* 3 (configf:lookup-number *configdat* "server" "minimum-intersync-delay" default: 180)))
;; ;;       (server:release-sync-lock)
;; ;;       (server:have-sync-lock?))
;; ;;      (else #f))))

)