Megatest

# make install CSCOPTS='-accumulate-profile -profile-name $(PWD)/profile-ww$(shell date +%V.%u)'
# rm <files>.o ; make install CSCOPTS='-profile' ; ... ;  chicken-profile | less
SHELL=/bin/bash
PREFIX=$(PWD)
CSCOPTS=
INSTALL=install
SRCFILES = common.scm items.scm launch.scm ods.scm runconfig.scm	\
           configf.scm db.scm keys.scm margs.scm process.scm runs.scm	\
           tasks.scm tests.scm genexample.scm tdb.scm mt.scm		\

           ezsteps.scm lock-queue.scm api.scm subrun.scm		\
           portlogger.scm archive.scm env.scm diff-report.scm		\
           cgisetup/models/pgdb.scm

# server.scm http-transport.scm client.scm rmt.scm

# module source files
MSRCFILES = dbfile.scm debugprint.scm mtargs.scm commonmod.scm dbmod.scm \
            configfmod.scm servermod.scm clientmod.scm rmtmod.scm        \
            artifacts.scm 

all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut

# dbmod.import.o is just a hack here
mofiles/dbfile.o     : mofiles/debugprint.o mofiles/commonmod.o # dbmod.import.o
db.o : dbmod.import.o
mofiles/debugprint.o : mofiles/mtargs.o
mofiles/servermod.o  : mofiles/artifacts.o

# ftail.scm rmtmod.scm commonmod.scm removed
# MSRCFILES = ducttape-lib.scm pkts.scm stml2.scm cookie.scm mutils.scm	\
#             mtargs.scm commonmod.scm dbmod.scm adjutant.scm ulex.scm	\
#             rmtmod.scm apimod.scm

GUISRCF = dashboard-context-menu.scm dashboard-tests.scm		\

$(PREFIX)/bin/.$(ARCHSTR)/mtexec : mtexec
	$(INSTALL) mtexec $(PREFIX)/bin/.$(ARCHSTR)/mtexec

$(PREFIX)/bin/mtexec : $(PREFIX)/bin/.$(ARCHSTR)/mtexec utils/mk_wrapper
	utils/mk_wrapper $(PREFIX) mtexec $(PREFIX)/bin/mtexec
	chmod a+x $(PREFIX)/bin/mtexec

# mtserv

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

$(PREFIX)/bin/.$(ARCHSTR)/mtserv : mtserv
	$(INSTALL) mtserv $(PREFIX)/bin/.$(ARCHSTR)/mtserv

$(PREFIX)/bin/mtserv : $(PREFIX)/bin/.$(ARCHSTR)/mtserv utils/mk_wrapper
	utils/mk_wrapper $(PREFIX) mtserv $(PREFIX)/bin/mtserv
	chmod a+x $(PREFIX)/bin/mtserv

# tcmt

$(PREFIX)/bin/.$(ARCHSTR)/tcmt : tcmt
	$(INSTALL) tcmt $(PREFIX)/bin/.$(ARCHSTR)/tcmt

$(PREFIX)/bin/tcmt : $(PREFIX)/bin/.$(ARCHSTR)/tcmt utils/mk_wrapper
	utils/mk_wrapper $(PREFIX) tcmt $(PREFIX)/bin/tcmt

install : $(PREFIX)/bin/.$(ARCHSTR) $(PREFIX)/bin/.$(ARCHSTR)/mtest $(PREFIX)/bin/megatest \
          $(PREFIX)/bin/.$(ARCHSTR)/dboard $(PREFIX)/bin/dashboard $(HELPERS) $(PREFIX)/bin/nbfake \
          $(PREFIX)/bin/.$(ARCHSTR)/mtexec $(PREFIX)/bin/mtexec $(PREFIX)/bin/serialize-env \
	  $(PREFIX)/bin/nbfind $(PREFIX)/bin/mtrunner $(PREFIX)/bin/viewscreen $(PREFIX)/bin/mt_xterm \
          $(PREFIX)/bin/mt-old-to-new.sh $(PREFIX)/bin/mt-new-to-old.sh \
	  $(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun \
	  $(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun $(PREFIX)/bin/mtutil \
	  $(PREFIX)/share/db/mt-pg.sql \
          $(PREFIX)/share/js/jquery-3.1.0.slim.min.js \
          $(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so \
          $(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so.0 \
          $(PREFIX)/bin/.$(ARCHSTR)/lib/libxcb-xlib.so.0
#         $(PREFIX)/bin/.$(ARCHSTR)/ndboard

# $(PREFIX)/bin/newdashboard $(PREFIX)/bin/tcmt 

$(PREFIX)/bin/.$(ARCHSTR) : 
	mkdir -p $(PREFIX)/bin/.$(ARCHSTR)
	mkdir -p $(PREFIX)/bin/.$(ARCHSTR)/lib

test: tests/tests.scm
	cd tests;csi -I .. -b -n tests.scm

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

(use srfi-69 posix)

(declare (unit api))
(declare (uses rmtmod))
(declare (uses db))
(declare (uses dbmod))
(declare (uses dbfile))
(declare (uses tasks))

(import dbmod)
(import dbfile)
(import rmtmod)

;; allow these queries through without starting a server
;;
(define api:read-only-queries
  '(get-key-val-pairs
    get-var
    get-keys

	       (vector #f res))
             (begin
               #;(common:telemetry-log (conc "api-out:"(->string cmd))
               payload: `((params . ,params)
               (ok-res . #f)))
               (vector #t res))))))))

;;    (dartifact->alist
;;         (car (get-dartifacts db #f 0 #f))
;;        '((foods (fruit . f)
;;                 (meat . m)))))
;; => "beef"
;;

;; NOTE: We call artifacts "arfs"

(module artifacts
(
;; cards, util and misc
;; sort-cards
;; calc-sha1
;;
;; low-level constructor procs, exposed only for development/testing, will be removed

dartifacts->alists ;; apply dartifact->alist to a list of alists using a artifact-spec
alist->artifact    ;; returns two values uuid, artifact
get-value     ;; looks up a value given a key in a dartifact
flatten-all   ;; merge the list of values from a query which includes a artifact into a flat alist <== really useful!
check-artifact

;; artifact alists
get-artifact-fname
write-alist->artifact
read-artifact->alist

;; archive database
;; archive-open-db
;; write-archive-artifacts
;; archive-artifacts

write-bundle
read-bundle

;; new artifacts db
with-todays-adb
get-all-artifacts
refresh-artifacts-db
)

(import scheme)

(cond-expand
 (chicken-5
  (import (chicken base)
	  (chicken process) (chicken time posix)
	(chicken io) (chicken file) (chicken pathname)
        chicken.process-context.posix (chicken string)
	(chicken time) (chicken sort) (chicken file posix) (chicken condition)
	(chicken port) (chicken process-context)
	))
 (chicken-4
  (import chicken
	  posix
	  data-structures
	  extras
	  ports
	  files
	  setup-api
	  )
  (define file-executable? file-execute-access?))
 (else))

 (import  srfi-69 srfi-1
	  regex srfi-13 srfi-69
	  crypt sha1 matchable message-digest sqlite3 typed-records
	  directory-utils
	  scsh-process)
 
;;======================================================================
;; DATA MANIPULATION UTILS
;;======================================================================

(define-inline (unescape-data data)
  (string-translate* data '(("\\n" . "\n") ("\\\\" . "\\"))))

;;======================================================================
;; Read/write packets to files (convience functions)
;;======================================================================

(define (get-artifact-fname targdir uuid)
  (conc targdir "/" uuid ".artifact"))

;; write alist to a artifact file
;;
(define (write-alist->artifact targdir dat #!key (artifactspec '())(ptype #f))
  (let-values (((uuid artifact)(alist->artifact dat artifactspec ptype: ptype)))
    (with-output-to-file (get-artifact-fname targdir uuid)
      (lambda ()
	(print artifact)))
    uuid)) ;; return the uuid

;; read artifact into alist
;;
(define (read-artifact->alist artifact-file #!key (artifactspec #f))

(declare (unit client))

(declare (uses common))
(declare (uses db))
(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.

;; (module client

;; *

;; 
;; )
;; 
;; (import client)
;; 
;; (include "common_records.scm")
;; (include "db_records.scm")
;; 
;; ;; client:get-signature
;; (define (client:get-signature)
;;   (if *my-client-signature* *my-client-signature*
;;       (let ((sig (conc (get-host-name) " " (current-process-id))))
;; 	(set! *my-client-signature* sig)
;; 	*my-client-signature*)))
;; 
;; ;; Not currently used! But, I think it *should* be used!!!
;; #;(define (client:logout serverdat)
;;   (let ((ok (and (socket? serverdat)
;; 		 (cdb:logout serverdat *toppath* (client:get-signature)))))
;;     ok))
;; 
;; ;; Do all the connection work, look up the transport type and set up the
;; ;; connection if required.
;; ;;
;; ;; There are two scenarios. 
;; ;;   1. We are a test manager and we received *transport-type* and *runremote* via cmdline
;; ;;   2. We are a run tests, list runs or other interactive process and we must figure out
;; ;;      *transport-type* and *runremote* from the monitor.db
;; ;;
;; ;; client:setup
;; ;;
;; ;; lookup_server, need to remove *runremote* stuff
;; ;;
;;  

;; ;;(define (http-transport:server-dat-make-url runremote)
;; (define (client:get-url runremote)
;;   (if (and (remote-iface runremote)
;; 	   (remote-port  runremote))
;;       (conc "http://" 
;; 	    (remote-iface runremote)
;; 	    ":"
;; 	    (remote-port  runremote))
;;       #f))
;; 
;; (define (client:setup areapath runremote #!key (remaining-tries 100) (failed-connects 0)(area-dat #f))
;;   (mutex-lock! *rmt-mutex*)
;;   (let ((res (client:setup-http areapath runremote remaining-tries: remaining-tries failed-connects: failed-connects area-dat: area-dat)))
;;     (mutex-unlock! *rmt-mutex*)
;;     res))
;; 
;; (define (client:setup-http areapath runremote #!key (remaining-tries 100) (failed-connects 0))
;;   (debug:print-info 2 *default-log-port* "client:setup remaining-tries=" remaining-tries)
;;   (server:start-and-wait areapath)
;;   (if (<= remaining-tries 0)
;;       (begin
;; 	(debug:print-error 0 *default-log-port* "failed to start or connect to server")
;; 	(exit 1))
;;       ;;
;;       ;; Alternatively here, we can get the list of candidate servers and work our way
;;       ;; through them searching for a good one.
;;       ;;
;;       (let* ((server-dat (server:choose-server areapath 'best))) ;; list host port start-time server-id pid
;; ;;	     (runremote  (or area-dat *runremote*)))
;; 	(if (not server-dat) ;; no server found
;; 	    (begin
;; 	      (if (< remaining-tries 99)(thread-sleep! 1)) ;; obviously it needs time
;; 	      (client:setup-http areapath runremote remaining-tries: (- remaining-tries 1)))
;; 	    (match server-dat
;; 	      ((host port start-time server-id pid)
;; 	       (debug:print-info 4 *default-log-port* "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries)
;; 	       (if (not runremote)
;;                    (begin
;; 		     ;; Here we are creating a runremote where there was none or it was clobbered with #f
;; 		     ;;
;; 		     (set! runremote (make-remote))
;;                      (let* ((server-info (server:check-if-running areapath)))
;; 		       (remote-server-info-set! runremote server-info)
;;                        (if server-info
;;                            (begin
;;                              (remote-server-url-set! runremote (server:record->url server-info))
;;                              (remote-server-id-set! runremote (server:record->id server-info)))))))
;; 	       ;; at this point we have a runremote
;; 	       (if (and host port server-id)
;; 		   (let* ((nada     (client:connect host port server-id runremote))
;; 			  (ping-res (rmt:login-no-auto-client-setup runremote)))
;; 		     (if ping-res
;; 			 (if runremote
;; 			     (begin
;; 			       (debug:print-info 2 *default-log-port* "connected to " (client:get-url runremote))
;; 			       runremote)
;; 			     (client:setup-http areapath runremote remaining-tries: (- remaining-tries 1)))
;; 			 (begin    ;; login failed but have a server record, clean out the record and try again
;; 			   (debug:print-info 0 *default-log-port* "client:setup, login unsuccessful, will attempt to start server ... ping-res=" ping-res ", server-dat=" server-dat) ;; had runid.  Fixes part of Randy;s ticket 1405717332
;; 			   (http-transport:close-connections runremote)
;; 			   (thread-sleep! 1)
;; 			   (client:setup-http areapath runremote remaining-tries: (- remaining-tries 1))
;; 			   )))
;; 		   (begin    ;; no server registered
;; 		     ;; (server:kind-run areapath)
;; 		     (server:start-and-wait areapath)
;; 		     (debug:print-info 0 *default-log-port* "client:setup, no server registered, remaining-tries=" remaining-tries)
;; 		     (thread-sleep! 1) ;; (+ 5 (random (- 20 remaining-tries))))  ;; give server a little time to start up, randomize a little to avoid start storms.
;; 		     (client:setup-http areapath runremote remaining-tries: (- remaining-tries 1)))))
;; 	      (else
;; 	       (debug:print 0 *default-log-port* "ERROR: malformed server-dat="server-dat)))))))

;; 
;; ;;
;; ;; connect - stored in remote-condat
;; ;;
;; ;; (define (http-transport:client-connect iface port server-id runremote)
;; (define (client:connect iface port server-id runremote-in)
;;   (let* ((runremote (or runremote-in
;; 			(make-runremote))))
;;     (debug:print-info 2 *default-log-port* "Connecting to server at "iface":"port", id "server-id)
;;     (let* ((api-url      (conc "http://" iface ":" port "/api"))
;; 	   (api-uri      (uri-reference (conc "http://" iface ":" port "/api")))
;; 	   (api-req      (make-request method: 'POST uri: api-uri)))
;;       ;;	 (server-dat   (vector iface port api-uri api-url api-req (current-seconds) server-id)))
;;       (remote-iface-set!   runremote iface)
;;       (remote-port-set!    runremote port)
;;       (remote-server-id-set! runremote server-id)
;;       (remote-connect-time-set! runremote (current-seconds))
;;       (remote-last-access-set! runremote (current-seconds))
;;       (remote-api-url-set! runremote api-url)
;;       (remote-api-uri-set! runremote api-uri)
;;       (remote-api-req-set! runremote api-req)
;;       runremote)))
;; 
;; 

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

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

;;(use srfi-18 extras tcp s11n srfi-1 posix regex srfi-69 hostinfo md5
;;     message-digest matchable spiffy uri-common intarweb http-client
;;     spiffy-request-vars uri-common intarweb directory-utils)

(declare (unit clientmod))

(module clientmod
*

)

(use srfi-1 posix regex regex-case srfi-69)
(use (prefix sqlite3 sqlite3:))

(declare (unit dashboard-context-menu))
(declare (uses common))
(declare (uses db))
(declare (uses gutils))
(declare (uses rmtmod))
(declare (uses ezsteps))
;; (declare (uses sdb))
;; (declare (uses filedb))
(declare (uses subrun))

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

(use srfi-1 posix regex regex-case srfi-69)
(use (prefix sqlite3 sqlite3:))

(declare (unit dashboard-tests))
(declare (uses common))
(declare (uses db))
(declare (uses gutils))
(declare (uses rmtmod))
(declare (uses ezsteps))
;; (declare (uses sdb))
;; (declare (uses filedb))
(declare (uses subrun))

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

(declare (unit db))
(declare (uses common))
(declare (uses dbmod))
;; (declare (uses debugprint))
(declare (uses dbfile))
(declare (uses keys))
(declare (uses ods))
;; (declare (uses client))
(declare (uses mt))

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

;; 
;;     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 diff-report))
(declare (uses common))
(declare (uses rmtmod))
         
(include "common_records.scm")
(use matchable)
(use fmt)
(use ducttape-lib)
(define css "")

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

;; (require-extension (srfi 18) extras tcp s11n)
;; 
;; 
;; (use  srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest posix-extras)
;; 
;; (use spiffy uri-common intarweb http-client spiffy-request-vars intarweb spiffy-directory-listing)
;; 
;; ;; Configurations for server
;; (tcp-buffer-size 2048)
;; (max-connections 2048) 
;; 
(declare (unit http-transport))
;; 
;; (declare (uses common))
;; (declare (uses db))
;; (declare (uses tests))
;; (declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
;; (declare (uses server))
;; ;; (declare (uses daemon))
;; (declare (uses portlogger))
;; (declare (uses rmt))
;; (declare (uses dbfile))
;; (declare (uses commonmod))
;; 
;; (include "common_records.scm")
;; (include "db_records.scm")
;; (include "js-path.scm")
;; 
;; (import dbfile commonmod)
;; 
;; (require-library stml)
;; (define (http-transport:make-server-url hostport)
;;   (if (not hostport)
;;       #f
;;       (conc "http://" (car hostport) ":" (cadr hostport))))
;; 
;; (define *server-loop-heart-beat* (current-seconds))
;; 
;; ;;======================================================================
;; ;; S E R V E R
;; ;; ======================================================================
;; 
;; ;; Call this to start the actual server
;; ;;
;; 

;; (define *db:process-queue-mutex* (make-mutex))
;; 
;; (define (http-transport:run hostn)
;;   ;; Configurations for server
;;   (tcp-buffer-size 2048)
;;   (max-connections 2048) 
;;   (debug:print 2 *default-log-port* "Attempting to start the server ...")
;;   (let* ((db              #f) ;;        (open-db)) ;; we don't want the server to be opening and closing the db unnecesarily
;; 	 (hostname        (get-host-name))
;; 	 (ipaddrstr       (let ((ipstr (if (string=? "-" hostn)
;; 					   ;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".")
;; 					   (server:get-best-guess-address hostname)
;; 					   #f)))
;; 			    (if ipstr ipstr hostn))) ;; hostname))) 
;; 	 (start-port      (portlogger:open-run-close portlogger:find-port))
;; 	 (link-tree-path  (common:get-linktree))
;; 	 (tmp-area        (common:get-db-tmp-area))
;; 	 (start-file      (conc tmp-area "/.server-start")))
;;     (debug:print-info 0 *default-log-port* "portlogger recommended port: " start-port)
;;     ;; set some parameters for the server
;;     (root-path     (if link-tree-path 
;; 		       link-tree-path
;; 		       (current-directory))) ;; WARNING: SECURITY HOLE. FIX ASAP!
;;     (handle-directory spiffy-directory-listing)
;;     (handle-exception (lambda (exn chain)
;; 			(signal (make-composite-condition
;; 				 (make-property-condition 
;; 				  'server
;; 				  'message "server error")))))
;; 
;;     ;; http-transport:handle-directory) ;; simple-directory-handler)
;;     ;; Setup the web server and a /ctrl interface
;;     ;;
;;     (vhost-map `(((* any) . ,(lambda (continue)
;; 			       ;; open the db on the first call 
;; 				 ;; This is were we set up the database connections
;; 			       (let* (($   (request-vars source: 'both))
;; 				      (dat ($ 'dat))
;; 				      (res #f))
;; 				 (cond
;; 				  ((equal? (uri-path (request-uri (current-request)))
;; 					   '(/ "api"))
;; 				   (send-response body:    (api:process-request *dbstruct-dbs* $) ;; the $ is the request vars proc
;; 						  headers: '((content-type text/plain)))
;; 				   (mutex-lock! *heartbeat-mutex*)
;; 				   (set! *db-last-access* (current-seconds))
;; 				   (mutex-unlock! *heartbeat-mutex*))
;; 				  ((equal? (uri-path (request-uri (current-request))) 
;; 					   '(/ ""))
;; 				   (send-response body: (http-transport:main-page)))
;; 				  ((equal? (uri-path (request-uri (current-request))) 
;; 					   '(/ "json_api"))
;; 				   (send-response body: (http-transport:main-page)))
;; 				  ((equal? (uri-path (request-uri (current-request))) 
;; 					   '(/ "runs"))
;; 				   (send-response body: (http-transport:main-page)))
;; 				  ((equal? (uri-path (request-uri (current-request))) 
;; 					   '(/ any))
;; 				   (send-response body: "hey there!\n"
;; 						  headers: '((content-type text/plain))))
;; 				  ((equal? (uri-path (request-uri (current-request))) 
;; 					   '(/ "hey"))
;; 				   (send-response body: "hey there!\n" 
;; 						  headers: '((content-type text/plain))))
;;                                   ((equal? (uri-path (request-uri (current-request))) 
;; 					   '(/ "jquery3.1.0.js"))
;; 				   (send-response body: (http-transport:show-jquery) 
;; 						  headers: '((content-type application/javascript))))
;;                                   ((equal? (uri-path (request-uri (current-request))) 
;; 					   '(/ "test_log"))
;; 				   (send-response body: (http-transport:html-test-log $) 
;; 						  headers: '((content-type text/HTML))))    
;;                                   ((equal? (uri-path (request-uri (current-request))) 
;; 					   '(/ "dashboard"))
;; 				   (send-response body: (http-transport:html-dboard $) 
;; 						  headers: '((content-type text/HTML)))) 
;; 				  (else (continue))))))))
;;     (handle-exceptions
;; 	exn
;;       (debug:print 0 *default-log-port* "Failed to create file " start-file ", exn=" exn)
;;       (with-output-to-file start-file (lambda ()(print (current-process-id)))))
;;     (http-transport:try-start-server ipaddrstr start-port)))
;; 
;; ;; This is recursively run by http-transport:run until sucessful
;; ;;
;; (define (http-transport:try-start-server ipaddrstr portnum)
;;   (let ((config-hostname (configf:lookup *configdat* "server" "hostname"))
;; 	(config-use-proxy (equal? (configf:lookup *configdat* "client" "use-http_proxy") "yes")))
;;     (if (not config-use-proxy)
;; 	(determine-proxy (constantly #f)))
;;     (debug:print-info 0 *default-log-port* "http-transport:try-start-server time=" (seconds->time-string (current-seconds)) " ipaddrsstr=" ipaddrstr " portnum=" portnum " config-hostname=" config-hostname)
;;     (handle-exceptions
;; 	exn
;; 	(begin
;; 	  ;; (print-error-message exn)
;; 	  (if (< portnum 64000)
;; 	      (begin 
;; 		(debug:print 0 *default-log-port* "WARNING: attempt to start server failed. Trying again ...")
;; 		(debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
;; 		(debug:print 5 *default-log-port* "exn=" (condition->list exn))
;; 		(portlogger:open-run-close portlogger:set-failed portnum)
;; 		(debug:print 0 *default-log-port* "WARNING: failed to start on portnum: " portnum ", trying next port")
;; 		(thread-sleep! 0.1)
;; 		
;; 		;; get_next_port goes here
;; 		(http-transport:try-start-server ipaddrstr
;; 						 (portlogger:open-run-close portlogger:find-port)))
;; 	      (begin
;; 		(debug:print 0 *default-log-port* "ERROR: Tried and tried but could not start the server"))))
;;       ;; any error in following steps will result in a retry
;;       (set! *server-info* (list ipaddrstr portnum))
;;       (debug:print 0 *default-log-port* "INFO: Trying to start server on " ipaddrstr ":" portnum)
;;       ;; This starts the spiffy server
;;       ;; NEED WAY TO SET IP TO #f TO BIND ALL
;;       ;; (start-server bind-address: ipaddrstr port: portnum)
;;       (if config-hostname ;; this is a hint to bind directly
;; 	  (start-server port: portnum) ;; bind-address: (if (equal? config-hostname "-")
;; 					;;		ipaddrstr
;; 					;;		config-hostname))
;; 	  (start-server port: portnum))
;;       (portlogger:open-run-close portlogger:set-port portnum "released")
;;       (debug:print 1 *default-log-port* "INFO: server has been stopped"))))
;; 
;; ;;======================================================================
;; ;; S E R V E R   U T I L I T I E S 
;; ;;======================================================================
;; 
;; ;;======================================================================
;; ;; C L I E N T S
;; ;;======================================================================
;; 
;; (define *http-mutex* (make-mutex))
;; 
;; ;; NOTE: Large block of code from 32436b426188080f72fceb6894af541fbad9921e removed here
;; ;;       I'm pretty sure it is defunct.
;; 
;; ;; This next block all imported en-mass from the api branch
;; (define *http-requests-in-progress* 0)
;; (define *http-connections-next-cleanup* (current-seconds))
;; 
;; (define (http-transport:get-time-to-cleanup)
;;   (let ((res #f))
;;     (mutex-lock! *http-mutex*)
;;     (set! res (> (current-seconds) *http-connections-next-cleanup*))
;;     (mutex-unlock! *http-mutex*)
;;     res))
;; 
;; (define (http-transport:inc-requests-count)
;;   (mutex-lock! *http-mutex*)
;;   (set! *http-requests-in-progress* (+ 1 *http-requests-in-progress*))
;;   ;; Use this opportunity to slow things down iff there are too many requests in flight
;;   (if (> *http-requests-in-progress* 5)
;;       (begin
;; 	(debug:print-info 0 *default-log-port* "Whoa there buddy, ease up...")
;; 	(thread-sleep! 1)))
;;   (mutex-unlock! *http-mutex*))
;; 
;; (define (http-transport:dec-requests-count proc) 
;;   (mutex-lock! *http-mutex*)
;;   (proc)
;;   (set! *http-requests-in-progress* (- *http-requests-in-progress* 1))
;;   (mutex-unlock! *http-mutex*))
;; 
;; (define (http-transport:dec-requests-count-and-close-all-connections)
;;   (set! *http-requests-in-progress* (- *http-requests-in-progress* 1))
;;   (let loop ((etime (+ (current-seconds) 5))) ;; give up in five seconds
;;     (if (> *http-requests-in-progress* 0)
;; 	(if (> etime (current-seconds))
;; 	    (begin
;; 	      (thread-sleep! 0.05)
;; 	      (loop etime))
;; 	    (debug:print-error 0 *default-log-port* "requests still in progress after 5 seconds of waiting. I'm going to pass on cleaning up http connections"))
;; 	(close-all-connections!)))
;;   (set! *http-connections-next-cleanup* (+ (current-seconds) 10))
;;   (mutex-unlock! *http-mutex*))
;; 
;; (define (http-transport:inc-requests-and-prep-to-close-all-connections)
;;   (mutex-lock! *http-mutex*)
;;   (set! *http-requests-in-progress* (+ 1 *http-requests-in-progress*)))
;; 
;; ;; Send "cmd" with json payload "params" to serverdat and receive result
;; ;;
;; (define (http-transport:client-api-send-receive run-id runremote cmd params #!key (numretries 3))
;;   (assert (remote? runremote) "FATAL: http-transport:client-api-send-receive called with serverdat="serverdat)
;;   (let* ((fullurl    (remote-api-req runremote))
;; 	 (res        (vector #f "uninitialized"))
;; 	 (success    #t)
;; 	 (sparams    (db:obj->string params transport: 'http))
;;          (server-id  (remote-server-id runremote)))
;;        (debug:print-info 11 *default-log-port* "cmd=" cmd " fullurl=" fullurl " server-id=" server-id " current time:" (current-seconds)) 
;; 
;;        ;; set up the http-client here
;;        (max-retry-attempts 1)
;;        ;; consider all requests indempotent
;;        (retry-request? (lambda (request)
;; 			 #f))
;;        ;; send the data and get the response
;;        ;; extract the needed info from the http data and 
;;        ;; process and return it.
;;        (let* ((send-recieve (lambda ()
;; 			      (mutex-lock! *http-mutex*)
;; 			      ;; (condition-case (with-input-from-request "http://localhost"; #f read-lines)
;; 			      ;;					       ((exn http client-error) e (print e)))
;; 			      (set! res (vector                ;;; DON'T FORGET - THIS IS THE CLIENT SIDE! NOTE: consider moving this to client.scm since we are only supporting http transport at this time.
;; 					 success
;; 					 (db:string->obj 
;; 					  (handle-exceptions
;; 					      exn
;; 					      (let ((call-chain (get-call-chain))
;; 						    (msg        ((condition-property-accessor 'exn 'message) exn)))
;; 						(set! success #f)
;;                                                 (if (debug:debug-mode 1)
;;                                                     (debug:print-info 0 *default-log-port* "couldn't talk to server, trying again ...")
;;                                                     (begin
;;                                                       (debug:print 0 *default-log-port* "WARNING: failure in with-input-from-request to " fullurl ".")
;;                                                       (debug:print 0 *default-log-port* " message: " msg ", exn=" exn)
;;                                                       (debug:print 0 *default-log-port* " cmd: " cmd " params: " params " key:" (or server-id "thekey"))
;;                                                       (debug:print 0 *default-log-port* " call-chain: " call-chain)))
;; 						;; what if another thread is communicating ok? Can't happen due to mutex
;; 						(http-transport:close-connections runremote)
;; 						(mutex-unlock! *http-mutex*)
;; 						;; (close-connection! fullurl)
;; 						(db:obj->string #f))
;; 					      (with-input-from-request ;; was dat
;; 					       fullurl 
;; 					       (list (cons 'key (or server-id   "thekey"))
;; 						     (cons 'cmd cmd)
;; 						     (cons 'params sparams))
;; 					       read-string))
;; 					  transport: 'http)
;; 					 0)) ;; added this speculatively
;; 			      ;; Shouldn't this be a call to the managed call-all-connections stuff above?
;; 			      ;; (close-all-connections!) ;; BUG? WHY IS THIS HERE? Are we failing to reuse connections?
;; 			      (mutex-unlock! *http-mutex*)
;; 			      ))
;; 	      (time-out     (lambda ()
;; 			      (thread-sleep! 45)
;; 			      (debug:print 0 *default-log-port* "WARNING: send-receive took more than 45 seconds!!")
;; 			      #f))
;; 	      (th1 (make-thread send-recieve "with-input-from-request"))
;; 	      (th2 (make-thread time-out     "time out")))
;; 	 (thread-start! th1)
;; 	 (thread-start! th2)
;; 	 (thread-join! th1)
;;           (vector-set! res 0 success)
;; 	 (thread-terminate! th2)
;; 	 (if (vector? res)
;; 	     (if (vector-ref res 0) ;; this is the first flag or the second flag? 
;;                  (let* ((res-dat (vector-ref res 1)))
;;                     (if (and (string? res-dat) (string-contains res-dat "server-id mismatch"))
;;                      (signal (make-composite-condition
;; 		          (make-property-condition 
;; 		       'servermismatch
;; 		       'message  (vector-ref res 1))))       
;; 		      res)) ;; this is the *inner* vector? seriously? why?
;;                  (if (debug:debug-mode 11)
;;                      (let ((call-chain (get-call-chain))) ;; note: this code also called in nmsg-transport - consider consolidating it
;;                        (print-call-chain (current-error-port))
;;                        (debug:print-error 11 *default-log-port* "error above occured at server, res=" res) ;; " message: " ((condition-property-accessor 'exn 'message) exn))
;;                        (debug:print 11 *default-log-port* " server call chain:")
;;                        (pp (vector-ref res 1) (current-error-port))
;;                        (signal (vector-ref res 0)))
;;                      res))
;; 	     (signal (make-composite-condition
;; 		      (make-property-condition 
;; 		       'timeout
;; 		       'message "nmsg-transport:client-api-send-receive-raw timed out talking to server")))))))
;; 
;; ;; careful closing of connections stored in *runremote*
;; ;;
;; (define (http-transport:close-connections runremote)
;;   (if (remote? runremote)
;;       (let ((api-dat (remote-api-uri runremote)))
;; 	(handle-exceptions
;; 	    exn
;; 	  (begin
;; 	    (print-call-chain *default-log-port*)
;; 	    (debug:print-error 0 *default-log-port* " closing connection failed with error: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn))
;; 	  (if (args:any-defined? "-server" "-execute" "-run")
;; 	      (debug:print-info 0 *default-log-port* "Closing connections to "api-dat))
;; 	  (if api-dat (close-connection! api-dat))
;; 	  (remote-conndat-set! runremote #f)
;; 	  #t))
;;       #f))
;; 
;; ;; run http-transport:keep-running in a parallel thread to monitor that the db is being 
;; ;; used and to shutdown after sometime if it is not.
;; ;;
;; (define (http-transport:keep-running) 
;;   ;; 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* ((servinfofile      #f)
;; 	 (sdat              #f)
;; 	 (no-sync-db        (db:open-no-sync-db))
;; 	 (tmp-area          (common:get-db-tmp-area))
;; 	 (started-file      (conc tmp-area "/.server-started"))
;; 	 (server-start-time (current-seconds))
;; 	 (server-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 *server-info*)
;;                           (mutex-unlock! *heartbeat-mutex*)
;;                           (if (and sdat
;; 				   (not changed)
;; 				   (> (- (current-seconds) start-time) 2))
;; 			      (let* ((servinfodir (server:get-servinfo-dir *toppath*)) ;; (conc *toppath*"/.servinfo"))
;; 				     (ipaddr      (car sdat))
;; 				     (port        (cadr sdat))
;; 				     (servinf     (conc servinfodir"/"ipaddr":"port)))
;; 				(set! servinfofile servinf)
;; 				(if (not (file-exists? servinfodir))
;; 				    (create-directory servinfodir #t))
;; 				(with-output-to-file servinf
;; 				  (lambda ()
;; 				    (let* ((serv-id (server:mk-signature)))
;; 				      (set! *server-id* serv-id)
;; 				      (print "SERVER STARTED: "ipaddr":"port" AT "(current-seconds)" server-id: "serv-id" pid: "(current-process-id))
;; 				      (print "started: "(seconds->year-week/day-time (current-seconds))))))
;; 				(set! *on-exit-procs* (cons
;; 						       (lambda ()
;; 							 (delete-file* servinf))
;; 						       *on-exit-procs*))
;; 				;; put data about this server into a simple flat file host.port
;; 				(debug:print-info 0 *default-log-port* "Received server alive signature")
;; 				sdat)
;;                               (begin
;; 				(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
;;                                     (if sdat 
;; 				      (let* ((ipaddr  (car sdat))
;; 					   (port    (cadr sdat))
;; 					   (servinf (conc (server:get-servinfo-dir *toppath*)"/"ipaddr":"port)))
;; 				        (debug:print-error 0 *default-log-port* "transport appears to have died, exiting server")
;; 				      (exit))
;;                                       (exit)

;;                                     )
;; 				    (loop start-time
;; 					  (equal? sdat last-sdat)
;; 					  sdat)))))))
;; 	 (iface       (car server-info))
;;          (port        (cadr server-info))
;;          (last-access 0)
;; 	 (server-timeout (server:expiration-timeout))
;; 	 (server-going  #f)
;; 	 (server-log-file (args:get-arg "-log"))) ;; always set when we are a server
;; 
;;     (handle-exceptions
;; 	exn
;;       (debug:print 0 *default-log-port* "Failed to create " started-file ", exn=" exn)
;;       (with-output-to-file started-file (lambda ()(print (current-process-id)))))
;; 
;;     (let loop ((count         0)
;; 	       (server-state 'available)
;; 	       (bad-sync-count 0)
;; 	       (start-time     (current-milliseconds)))
;; 
;;       ;; Use this opportunity to sync the tmp db to megatest.db
;;       (if (not server-going) ;; *dbstruct-dbs* 
;; 	  (begin
;; 	    (debug:print 0 *default-log-port* "SERVER: dbprep")
;; 	    (set! *dbstruct-dbs*  (db:setup #t)) ;;  run-id)) FIXME!!!
;; 	    (set! server-going #t)
;; 	    (debug:print 0 *default-log-port* "SERVER: running, megatest version: " (common:get-full-version))) ;; NOTE: the server is NOT yet marked as running in the log. We do that in the keep-running routine.
;; 	  (if (and no-sync-db
;; 		   (common:low-noise-print 10 "sync-all")) ;; cheesy way to reduce frequency of running sync :)
;;               (begin
;; 		(if (common:low-noise-print 120 "sync-all-print")
;;                     (debug:print 0 *default-log-port* "keep-running calling db:all-db-sync at " (time->string (seconds->local-time) "%H:%M:%S")))
;; 		(db:all-db-sync *dbstruct-dbs*)
;; 		)))
;;       
;;       ;; 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)))
;;       
;;       (if (< count 1) ;; 3x3 = 9 secs aprox
;; 	  (loop (+ count 1) 'running bad-sync-count (current-milliseconds)))
;;       
;;       ;; Check that iface and port have not changed (can happen if server port collides)
;;       (mutex-lock! *heartbeat-mutex*)
;;       (set! sdat *server-info*)
;;       (mutex-unlock! *heartbeat-mutex*)
;;       
;;       (if (not (equal? sdat (list iface port)))
;; 	  (let ((new-iface (car sdat))
;; 		(new-port  (cadr sdat)))
;; 	    (debug:print-info 0 *default-log-port* "WARNING: interface changed, refreshing iface and port info")
;; 	    (set! iface new-iface)
;; 	    (set! port  new-port)
;;              (if (not *server-id*)
;; 		 (set! *server-id* (server:mk-signature)))
;; 	    (debug:print 0 *default-log-port* "SERVER STARTED: " iface ":" port " AT " (current-seconds) " server-id: " *server-id*)
;; 	    (flush-output *default-log-port*)))
;;       
;;       ;; Transfer *db-last-access* to last-access to use in checking that we are still alive
;;       (mutex-lock! *heartbeat-mutex*)
;;       (set! last-access *db-last-access*)
;;       (mutex-unlock! *heartbeat-mutex*)
;;       
;;       (if (common:low-noise-print 120 (conc "server running on " iface ":" port))
;; 	  (begin
;;              (if (not *server-id*)
;; 		 (set! *server-id* (server:mk-signature)))
;;              (debug:print 0 *default-log-port* (current-seconds) (current-directory) (current-process-id) (argv))   
;; 	     (debug:print 0 *default-log-port* "SERVER STARTED: " iface ":" port " AT " (current-seconds) " server-id: " *server-id*)
;; 	     (flush-output *default-log-port*)))
;;       (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
;;          ((and *server-run*
;; 	       (> (+ last-access server-timeout)
;; 		  (current-seconds)))
;;           (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))
;; 	      (let ((curr-time (current-seconds)))
;; 		(handle-exceptions
;; 		    exn
;; 		    (debug:print 0 *default-log-port* "ERROR: Failed to change timestamp on info file " servinfofile ". Are you out of space on that disk? exn=" exn)
;; 		    (if (and ;; (< (- (current-seconds) server-start-time) 600) ;; run for ten minutes for experiment, 3600 thereafter
;; 			     (not *server-overloaded*)
;; 			     (file-exists? servinfofile))
;; 			(change-file-times servinfofile curr-time curr-time)))
;; 		(if (and (common:low-noise-print 120 "start new server")
;; 			(> *api-process-request-count* 50)) ;; if this server is kind of busy start up another
;; 		    (begin
;; 		      (debug:print-info 0 *default-log-port* "Server is busy, api-count "*api-process-request-count*", start another if possible...")
;; 		      (server:kind-run *toppath*)
;; 		      (if (> *api-process-request-count* 100)
;; 			  (begin
;; 			    (debug:print-info 0 *default-log-port* "Server is overloaded at api-count=" *api-process-request-count*", removing "servinfofile) 
;; 			    (delete-file* servinfofile)))))))
;;           (loop 0 server-state bad-sync-count (current-milliseconds)))
;;          (else
;;           (debug:print-info 0 *default-log-port* "Server timed out. seconds since last db access: " (- (current-seconds) last-access))
;;           (http-transport:server-shutdown port)))))))
;; 
;; (define (http-transport:server-shutdown port)
;;   (begin
;;     ;;(BB> "http-transport:server-shutdown called")
;;     (debug:print-info 0 *default-log-port* "Starting to shutdown the server. pid="(current-process-id))
;;     ;;
;;     ;; start_shutdown
;;     ;;
;;     (set! *time-to-exit* #t) ;; tell on-exit to be fast as we've already cleaned up
;;     (portlogger:open-run-close portlogger:set-port port "released")
;;     (thread-sleep! 1)
;; 
;;     ;; (debug:print-info 0 *default-log-port* "Max cached queries was    " *max-cache-size*)
;;     ;; (debug:print-info 0 *default-log-port* "Number of cached writes   " *number-of-writes*)
;;     ;; (debug:print-info 0 *default-log-port* "Average cached write time "
;;     ;; 		      (if (eq? *number-of-writes* 0)
;;     ;; 			  "n/a (no writes)"
;;     ;; 			  (/ *writes-total-delay*
;;     ;; 			     *number-of-writes*))
;;     ;; 		      " ms")
;;     ;; (debug:print-info 0 *default-log-port* "Number non-cached queries "  *number-non-write-queries*)
;;     ;; (debug:print-info 0 *default-log-port* "Average non-cached time   "
;;     ;; 		      (if (eq? *number-non-write-queries* 0)
;;     ;; 			  "n/a (no queries)"
;;     ;; 			  (/ *total-non-write-delay* 
;;     ;; 			     *number-non-write-queries*))
;;     ;; 		      " ms")
;;     
;;     (db:print-current-query-stats)
;;     #;(common:save-pkt `((action . exit)
;;                        (T      . server)
;;                        (pid    . ,(current-process-id)))
;;     *configdat* #t)
;; 
;;     ;; remove .servinfo file(s) here
;;     
;;     (debug:print-info 0 *default-log-port* "Server shutdown complete. Exiting")
;;     (exit)))
;; 
;; ;; all routes though here end in exit ...
;; ;;
;; ;; start_server? 
;; ;;
;; (define (http-transport:launch)
;;   ;; check the .servinfo directory, are there other servers running on this
;;   ;; or another host?
;;   (let* ((server-start-is-ok  (server:minimal-check *toppath*)))
;;     (if (not server-start-is-ok)
;; 	(begin
;; 	  (debug:print 0 *default-log-port* "ERROR: server start not ok, exiting now.")
;; 	  (exit 1))))
;;     
;;   ;; check that a server start is in progress, pause or exit if so
;;   (let* ((th2 (make-thread (lambda ()
;;                              (debug:print-info 0 *default-log-port* "Server run thread started")
;;                              (http-transport:run 
;;                               (if (args:get-arg "-server")
;;                                   (args:get-arg "-server")
;;                                   "-")
;;                               )) "Server run"))
;;          (th3 (make-thread (lambda ()
;;                              (debug:print-info 0 *default-log-port* "Server monitor thread started")
;;                              (http-transport:keep-running)
;;                              "Keep running"))))
;;     (thread-start! th2)
;;     (thread-sleep! 0.25) ;; give the server time to settle before starting the keep-running monitor.
;;     (thread-start! th3)
;;     (set! *didsomething* #t)
;;     (thread-join! th2)
;;     (exit)))
;; 
;; ;; (define (http-transport:server-signal-handler signum)
;; ;;   (signal-mask! signum)
;; ;;   (handle-exceptions
;; ;;    exn
;; ;;    (debug:print 0 *default-log-port* " ... exiting ...")
;; ;;    (let ((th1 (make-thread (lambda ()
;; ;; 			     (thread-sleep! 1))
;; ;; 			   "eat response"))
;; ;; 	 (th2 (make-thread (lambda ()
;; ;; 			     (debug:print-error 0 *default-log-port* "Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.")
;; ;; 			     (thread-sleep! 3) ;; give the flush three seconds to do it's stuff
;; ;; 			     (debug:print 0 *default-log-port* "       Done.")
;; ;; 			     (exit 4))
;; ;; 			   "exit on ^C timer")))
;; ;;      (thread-start! th2)
;; ;;      (thread-start! th1)
;; ;;      (thread-join! th2))))
;; 
;; ;;===============================================
;; ;; Java script
;; ;;===============================================
;; (define (http-transport:show-jquery)
;;   (let* ((data  (tests:readlines *java-script-lib*)))
;; (string-join data "\n")))
;; 
;; 
;; 
;; ;;======================================================================
;; ;; web pages
;; ;;======================================================================
;; 
;; (define (http-transport:html-test-log $)
;;    (let* ((run-id ($ 'runid))
;;          (test-item ($ 'testname))
;;          (parts (string-split test-item ":"))
;;          (test-name (car parts))
;;              
;;          (item-name (if (equal? (length parts) 1)
;;              ""
;;              (cadr parts))))
;;   ;(print $) 
;; (tests:get-test-log run-id test-name item-name)))
;; 
;; 
;; (define (http-transport:html-dboard $)
;;   (let* ((page ($ 'page))
;;          (oup       (open-output-string)) 
;;          (bdy "--------------------------")
;; 
;;          (ret  (tests:dynamic-dboard page)))
;;     (s:output-new  oup  ret)
;;    (close-output-port oup)
;; 
;;   (set! bdy   (get-output-string oup))
;;      (conc "<h1>Dashboard</h1>" bdy "<br/> <br/> "  )))
;; 
;; (define (http-transport:main-page)
;;   (let ((linkpath (root-path)))
;;     (conc "<head><h1>" (pathname-strip-directory *toppath*) "</h1></head>"
;; 	  "<body>"
;; 	  "Run area: " *toppath*
;; 	  "<h2>Server Stats</h2>"
;; 	  (http-transport:stats-table) 
;; 	  "<hr>"
;; 	  (http-transport:runs linkpath)
;; 	  "<hr>"
;; 	  ;; (http-transport:run-stats)
;; 	  "</body>"
;; 	  )))
;; 
;; (define (http-transport:stats-table)
;;   (mutex-lock! *heartbeat-mutex*)
;;   (let ((res 
;; 	 (conc "<table>"
;; 	       ;; "<tr><td>Max cached queries</td>        <td>" *max-cache-size* "</td></tr>"
;; 	       "<tr><td>Number of cached writes</td>   <td>" *number-of-writes* "</td></tr>"
;; 	       "<tr><td>Average cached write time</td> <td>" (if (eq? *number-of-writes* 0)
;; 								 "n/a (no writes)"
;; 								 (/ *writes-total-delay*
;; 								    *number-of-writes*))
;; 	       " ms</td></tr>"
;; 	       "<tr><td>Number non-cached queries</td> <td>"  *number-non-write-queries* "</td></tr>"
;; 	       ;; "<tr><td>Average non-cached time</td>   <td>" (if (eq? *number-non-write-queries* 0)
;; 	       ;; 							 "n/a (no queries)"
;; 	       ;; 							 (/ *total-non-write-delay* 
;; 	       ;; 							    *number-non-write-queries*))
;; 	       " ms</td></tr>"
;; 	       "<tr><td>Last access</td><td>"              (seconds->time-string *db-last-access*) "</td></tr>"
;; 	       "</table>")))
;;     (mutex-unlock! *heartbeat-mutex*)
;;     res))
;; 
;; (define (http-transport:runs linkpath)
;;   (conc "<h3>Runs</h3>"
;; 	(string-intersperse
;; 	 (let ((files (map pathname-strip-directory (glob (conc linkpath "/*")))))
;; 	   (map (lambda (p)
;; 		  (conc "<a href=\"" p "\">" p "</a><br>"))
;; 		files))
;; 	 " ")))
;; 
;; #;(define (http-transport:run-stats)
;;   (let ((stats (open-run-close db:get-running-stats #f)))
;;     (conc "<table>"
;; 	  (string-intersperse
;; 	   (map (lambda (stat)
;; 		  (conc "<tr><td>" (car stat) "</td><td>" (cadr stat) "</td></tr>"))
;; 		stats)
;; 	   " ")
;; 	  "</table>")))
;; 
;; ;; http-server  send-response
;; ;;                 api:process-request
;; ;;                    db:*
;; ;;
;; ;; NB// Runs on the server as part of the server loop
;; ;;
;; (define (api:process-request dbstruct $) ;; the $ is the request vars proc
;;   (debug:print 4 *default-log-port* "server-id:"  *server-id*)
;;   (let* ((cmd     ($ 'cmd))
;; 	 (paramsj ($ 'params))
;;          (key     ($ 'key))   
;; 	 (params  (db:string->obj paramsj transport: 'http))) ;; incoming data from the POST (or is it a GET?)
;;     (debug:print 4 *default-log-port* "cmd:" cmd " with params " params "key " key)
;;     (if (equal? key *server-id*)
;;       (begin
;;         (set! *api-process-request-count* (+ *api-process-request-count* 1))
;;  	(let* ((resdat  (api:execute-requests dbstruct (vector cmd params))) ;; process the request, resdat = #( flag result )
;; 	       (success (vector-ref resdat 0))
;; 	       (res     (vector-ref resdat 1))) ;; (vector flag payload), get the payload, ignore the flag (why?)
;; 	  (debug:print 4 *default-log-port* "res:" res)
;; 	  (if (not success)
;; 	      (debug:print 0 *default-log-port* "ERROR: success flag is #f for " cmd " with params " params))
;; 	  (if (> *api-process-request-count* *max-api-process-requests*)
;; 	      (set! *max-api-process-requests* *api-process-request-count*))
;; 	  (set! *api-process-request-count* (- *api-process-request-count* 1))
;; 	  ;; This can be here but needs controls to ensure it doesn't run more than every 4 seconds
;; 	  ;; (rmt:dat->json-str
;; 	  ;;  (if (or (string? res)
;; 	  ;;          (list?   res)
;; 	  ;;          (number? res)
;; 	  ;;          (boolean? res))
;; 	  ;;      res 
;; 	  ;;      (list "ERROR, not string, list, number or boolean" 1 cmd params res)))))
;; 	  (db:obj->string res transport: 'http)))
;; 	(begin
;; 	  (debug:print 0 *default-log-port*   "Server refused to process request. Server id mismatch. recived " key " expected:  " *server-id* ".\nOther arguments recived: cmd=" cmd " params = " params) 
;; 	  (db:obj->string (conc "Server refused to process request server-id mismatch: " key ", " *server-id*) transport: 'http)))))
;; 
;; 

(define (toplevel-command . a) #f)

(declare (uses common))
;; (declare (uses megatest-version))
(declare (uses margs))
(declare (uses runs))
(declare (uses launch))


(declare (uses tests))
(declare (uses genexample))
;; (declare (uses daemon))

(declare (uses db))
;; (declare (uses dcommon))

(declare (uses tdb))
(declare (uses mt))
(declare (uses api))
(declare (uses tasks)) ;; only used for debugging.
(declare (uses env))
(declare (uses diff-report))
(declare (uses db))
(declare (uses dbmod))
(declare (uses dbmod.import))
(declare (uses rmtmod))
(declare (uses clientmod))
(declare (uses servermod))
(declare (uses commonmod))
(declare (uses commonmod.import))
(declare (uses dbfile))
(declare (uses dbfile.import))
;; (declare (uses debugprint))
;; (declare (uses debugprint.import))
;; (declare (uses mtargs))
;; (declare (uses mtargs.import))

;; (declare (uses ftail))
;; (import ftail)

(import dbmod
	commonmod
	dbfile
	servermod)

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

;; Start the server - can be done in conjunction with -runall or -runtests (one day...)
;;   we start the server if not running else start the client thread
;;======================================================================

;; Server? Start up here.
;;
(if (args:get-arg "-server")
    (let* ((tl        (launch:setup))
	   (srvdat    (server:setup tl))
	   (handler   (lambda (dbstruct cmd params)
			(api:execute-requests dbstruct (if (string? cmd)
							   (string->symbol cmd)
							   cmd)
					      (db:string->obj params)))))
      (server:set-handler srvdat handler)
      (srv-obj-to-str-set! srvdat db:obj->string)
      (srv-str-to-obj-set! srvdat db:string->obj)
      (srv-dbstruct-set! srvdat (db:setup #t))
      (thread-join!
       (thread-start! (make-thread
		       (lambda ()
			 (server:run srvdat)))))
      
      ;; (server:launch 0 'http)
      ;; (http-transport:launch)  ;; NOTE: Need to replace this call
      
      (set! *didsomething* #t)))

;; The adjutant is a bit different, it does NOT run (launch:setup) as it is not necessarily tied to
;; a specific Megatest area. Detail are being hashed out and this may change.
;;
(if (args:get-arg "-adjutant")
    (begin

(declare (unit mt))
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
(declare (uses tests))
(declare (uses servermod))
(declare (uses runs))
(declare (uses rmtmod))
;; (declare (uses filedb))

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

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

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

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

(use srfi-1 posix srfi-69 readline ;;  regex regex-case srfi-69 apropos json http-client directory-utils rpc typed-records;; (srfi 18) extras)
     srfi-19  srfi-18 extras format regex regex-case
     (prefix dbi dbi:)
     matchable
     )

;; (declare (uses common))
(declare (uses margs))
(declare (uses configfmod))
(declare (uses servermod))

(include "megatest-version.scm")
(include "megatest-fossil-hash.scm")

(define help (conc "
mtserv, part of the Megatest tool suite, documentation at http://www.kiatoa.com/fossils/megatest
  version " megatest-version "
  license GPL, Copyright Matt Welland 2006-2017

Usage: mtserv action [options]
  -h                         : this help
  -manual                    : show the Megatest user manual
  -version                   : print megatest version (currently " megatest-version ")
  -start-dir path            : switch to dir at start

actions:

  server                     : start server
  repl                       : start repl
			     
Examples:

Called as " (string-intersperse (argv) " ") "
Version " megatest-version ", built from " megatest-fossil-hash ))
  ;; first token is our action, but only if no leading dash

(define *action* (if (and (> (length (argv)) 1)
                          (not (string-match "^\\-.*" (cadr (argv)))))
		     (cadr (argv))
		     #f))

(define *remargs*
  (args:get-args
   (if *action* (cdr (argv)) (argv))
   '("-log")
   '("-h"
     )
   args:arg-hash
   0))

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

(if (args:get-arg "-start-dir")
    (let* ((start-dir (args:get-arg "-start-dir")))
      (if (and (file-exists? start-dir)
	       (directory?   start-dir))
	  (change-directory start-dir)
	  (begin
	    (print "FATAL: cannot find or access "start-dir)
	    (exit 1)))))

(if *action*
    (case (string->symbol *action*)
      ((server)    (server:run))
      ((repl)
       (import extras) ;; might not be needed
       ;; (import csi)
       (import readline)
       (import apropos)
       ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ...
       
       (install-history-file (get-environment-variable "HOME") ".mtserv_history") ;;  [homedir] [filename] [nlines])
       (current-input-port (make-readline-port "mtserv> "))
       (print "Starting repl...")
       (repl))
        ;; (if (args:get-arg "-load")
	;;    (load (args:get-arg "-load"))
	;;   (repl)))
      (else
       (print "Action \""*action*"\" not recognised.")
       (print help)))
    (begin
      (print "No action provided.")
      (print help)))

#|
(define mtconf (car (simple-setup #f)))
(define dat (common:with-queue-db mtconf (lambda (conn)(get-pkts conn '()))))
(pp (pkts#flatten-all dat '((cmd . ((parent . P)(url . M)))(runtype . ((parent . P)))) 'id 'group-id 'uuid 'parent 'pkt-type 'pkt 'processed))
|#

(use format typed-records) ;; RADT => purpose of json format??

(declare (unit rmt))
(declare (uses api))
(declare (uses http-transport))
(declare (uses dbfile))

;; (include "common_records.scm")
;; ;; (declare (uses rmtmod))
;; 
;; (import dbfile) ;; rmtmod)

;; 
;; ;;
;; ;; THESE ARE ALL CALLED ON THE CLIENT SIDE!!!
;; ;;
;; 

;; ;; generate entries for ~/.megatestrc with the following
;; ;;
;; ;;  grep define ../rmt.scm | grep rmt: |perl -pi -e 's/\(define\s+\((\S+)\W.*$/\1/'|sort -u
;; 
;; ;;======================================================================
;; ;;  S U P P O R T   F U N C T I O N S
;; ;;======================================================================
;; 
;; ;; if a server is either running or in the process of starting call client:setup
;; ;; else return #f to let the calling proc know that there is no server available
;; ;;
;; (define (rmt:get-connection-info areapath runremote) ;; TODO: push areapath down.
;;   (let* ((cinfo     (if (remote? runremote)
;; 			(remote-conndat runremote)
;; 			#f)))
;; 	  (if cinfo
;; 	      cinfo
;; 	      (if (server:check-if-running areapath)
;; 		  (client:setup areapath runremote)
;; 		  #f))))
;; 
;; (define (rmt:on-homehost? runremote)
;;   (let* ((hh-dat (remote-hh-dat runremote)))
;;     (if (pair? hh-dat)
;; 	(cdr hh-dat)
;; 	(begin
;; 	  (debug:print-info 0 *default-log-port* "hh-dat="hh-dat)
;; 	  #f))))
;; 
;; 
;; ;;======================================================================
;; 
;; (define *send-receive-mutex* (make-mutex)) ;; should have separate mutex per run-id
;; 
;; ;; RA => e.g. usage (rmt:send-receive 'get-var #f (list varname))
;; ;;
;; (define (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f)) ;; start attemptnum at 1 so the modulo below works as expected
;; 
;;   #;(common:telemetry-log (conc "rmt:"(->string cmd))
;;                         payload: `((rid . ,rid)
;;                                    (params . ,params)))
;; 
;;   (if (> attemptnum 2)
;;       (debug:print 0 *default-log-port* "INFO: attemptnum in rmt:send-receive is " attemptnum))
;;     
;;   (cond
;;    ((> attemptnum 2) (thread-sleep! 0.05))
;;    ((> attemptnum 10) (thread-sleep! 0.5))
;;    ((> attemptnum 20) (thread-sleep! 1)))
;;   (if (and (> attemptnum 5) (= 0 (modulo attemptnum 15)))  
;;     (begin (server:run *toppath*) (thread-sleep! 3))) 
;;   
;;   
;;   ;;DOT digraph megatest_state_status {
;;   ;;DOT   ranksep=0;
;;   ;;DOT   // rankdir=LR;
;;   ;;DOT   node [shape="box"];
;;   ;;DOT "rmt:send-receive" -> MUTEXLOCK;
;;   ;;DOT { edge [style=invis];"case 1" -> "case 2" -> "case 3" -> "case 4" -> "case 5" -> "case 6" -> "case 7" -> "case 8" -> "case 9" -> "case 10" -> "case 11"; }
;;   ;; do all the prep locked under the rmt-mutex
;;   (mutex-lock! *rmt-mutex*)
;;   
;;   ;; 1. check if server is started IFF cmd is a write OR if we are not on the homehost, store in runremote
;;   ;; 2. check the age of the connections. refresh the connection if it is older than timeout-20 seconds.
;;   ;; 3. do the query, if on homehost use local access
;;   ;;
;;   (let* ((start-time    (current-seconds)) ;; snapshot time so all use cases get same value
;;          (areapath      *toppath*);; TODO - resolve from dbstruct to be compatible with multiple areas
;; 	 (runremote     (or area-dat
;; 			    *runremote*))
;;          (attemptnum    (+ 1 attemptnum))
;; 	 (readonly-mode (rmtmod:calc-ro-mode runremote *toppath*)))
;; 
;;     ;; DOT INIT_RUNREMOTE; // leaving off - doesn't really add to the clarity
;;     ;; DOT MUTEXLOCK -> INIT_RUNREMOTE [label="no remote?"];
;;     ;; DOT INIT_RUNREMOTE -> MUTEXLOCK;
;;     ;; ensure we have a record for our connection for given area
;;     (if (not runremote)                   ;; can remove this one. should never get here.         
;; 	(begin
;; 	  (set! *runremote* (make-remote))
;;           (let* ((server-info (remote-server-info *runremote*))) 
;;             (if server-info
;; 		(begin
;; 			(remote-server-url-set! *runremote* (server:record->url server-info))
;; 			(remote-server-id-set! *runremote* (server:record->id server-info)))))  
;; 	  (set! runremote   *runremote*))) ;; new runremote will come from this on next iteration
;;     
;;     ;; DOT SET_HOMEHOST; // leaving off - doesn't really add to the clarity
;;     ;; DOT MUTEXLOCK -> SET_HOMEHOST [label="no homehost?"];
;;     ;; DOT SET_HOMEHOST -> MUTEXLOCK;
;;     ;; ensure we have a homehost record
;;     (if (not (pair? (remote-hh-dat runremote)))  ;; not on homehost
;; 	(thread-sleep! 0.1) ;; since we shouldn't get here, delay a little
;; 	(let ((hh-data (server:choose-server areapath 'homehost)))
;; 	  (remote-hh-dat-set! runremote (or hh-data (cons #f #f)))))
;;     
;;     ;;(print "BB> readonly-mode is "readonly-mode" dbfile is "dbfile)
;;     (cond
;;      #;((> (- (current-seconds)(remote-connect-time runremote)) 180) ;; reconnect to server every 180 seconds
;;       (debug:print 0 *default-log-port* "Forcing reconnect to server(s) due to 180 second timeout.")
;;       (set! *runremote* #f)
;;       ;; BUG: close-connections should go here?
;;       (mutex-unlock! *rmt-mutex*)
;;       (rmt:send-receive cmd rid params attemptnum: 1 area-dat: area-dat))
;;      
;;      ;;DOT EXIT;
;;      ;;DOT MUTEXLOCK -> EXIT [label="> 15 attempts"]; {rank=same "case 1" "EXIT" }
;;      ;; give up if more than 150 attempts
;;      ((> attemptnum 150)
;;       (debug:print 0 *default-log-port* "ERROR: 150 tries to start/connect to server. Giving up.")
;;       (exit 1))
;; 
;;      ;;DOT CASE2 [label="local\nreadonly\nquery"];
;;      ;;DOT MUTEXLOCK -> CASE2; {rank=same "case 2" CASE2}
;;      ;;DOT CASE2 -> "rmt:open-qry-close-locally";
;;      ;; readonly mode, read request-  handle it - case 2
;;      ((and readonly-mode
;;            (member cmd api:read-only-queries)) 
;;       (mutex-unlock! *rmt-mutex*)
;;       (debug:print-info 12 *default-log-port* "rmt:send-receive, case 2")
;;       (rmt:open-qry-close-locally cmd 0 params)

;;       )
;; 
;;      ;;DOT CASE3 [label="write in\nread-only mode"];
;;      ;;DOT MUTEXLOCK -> CASE3 [label="readonly\nmode?"]; {rank=same "case 3" CASE3}
;;      ;;DOT CASE3 -> "#f";
;;      ;; readonly mode, write request.  Do nothing, return #f
;;      (readonly-mode (extras-readonly-mode *rmt-mutex* *default-log-port* cmd params))
;; 
;;      ;; This block was for pre-emptively resetting the connection if there had been no communication for some time.
;;      ;; I don't think it adds any value. If the server is not there, just fail and start a new connection.
;;      ;; also, the expire-time calculation might not be correct. We want, time-since-last-server-access > (server:get-timeout)
;;      ;;
;;      ;;DOT CASE4 [label="reset\nconnection"];
;;      ;;DOT MUTEXLOCK -> CASE4 [label="have connection,\nlast_access > expire_time"]; {rank=same "case 4" CASE4}
;;      ;;DOT CASE4 -> "rmt:send-receive";
;;      ;; reset the connection if it has been unused too long
;;      ((and runremote
;;            ;; (remote-conndat runremote)
;; 	   (> (current-seconds) ;; if it has been more than server-timeout seconds since last contact, close this connection and start a new on
;; 	      (+ (remote-last-access runremote)
;; 		 (remote-server-timeout runremote))))
;;       (debug:print-info 0 *default-log-port* "Connection to " (remote-server-url runremote) " expired due to no accesses, forcing new connection.")
;;       (http-transport:close-connections runremote)
;;       ;; moving this setting of runremote conndat to #f to inside the http-transport:close-connections
;;       ;; (remote-conndat-set! runremote #f) ;; invalidate the connection, thus forcing a new connection.
;;       (mutex-unlock! *rmt-mutex*)
;;       (rmt:send-receive cmd rid params attemptnum: attemptnum))
;;      
;;      ;;DOT CASE5 [label="local\nread"];
;;      ;;DOT MUTEXLOCK -> CASE5 [label="server not required,\non homehost,\nread-only query"]; {rank=same "case 5" CASE5};
;;      ;;DOT CASE5 -> "rmt:open-qry-close-locally";
;; 
;;      ;; on homehost and this is a read
;;      ((and (not (remote-force-server runremote)) ;; honor forced use of server, i.e. server NOT required
;; 	   (rmt:on-homehost? runremote)
;;            (member cmd api:read-only-queries))   ;; this is a read
;;       (mutex-unlock! *rmt-mutex*)
;;       (debug:print-info 12 *default-log-port* "rmt:send-receive, case  5")
;;       (rmt:open-qry-close-locally cmd 0 params))
;; 
;;      ;;DOT CASE6 [label="init\nremote"];
;;      ;;DOT MUTEXLOCK -> CASE6 [label="on homehost,\nwrite query,\nhave server,\ncan't reach it"]; {rank=same "case 6" CASE6};
;;      ;;DOT CASE6 -> "rmt:send-receive";
;;      ;; on homehost and this is a write, we already have a server, but server has died
;; 
;;      ;; reinstate this keep-alive section but inject a time condition into the (add ...
;;      ;;
;;      ;; ((and (cdr (remote-hh-dat runremote))           ;; on homehost
;;      ;;       (not (member cmd api:read-only-queries))  ;; this is a write
;;      ;;       (remote-server-url runremote)             ;; have a server
;;      ;;       (not (server:ping (remote-server-url runremote) (remote-server-id runremote))))  ;; server has died. NOTE: this is not a cheap call! Need better approach.
;;      ;;  (debug:print 0 *default-log-port* "WARNING: server appears to have died, trying to reconnect, case 6")
;;      ;;  (http-transport:close-connections area-dat: runremote) ;; make sure to clean up
;;      ;;  (set! *runremote* (make-remote))
;;      ;;  (let* ((server-info (remote-server-info *runremote*))) 
;;      ;;        (if server-info
;;      ;; 		(begin
;;      ;; 		  (remote-server-url-set! *runremote* (server:record->url server-info))
;;      ;;              (remote-server-id-set! *runremote* (server:record->id server-info)))))
;;      ;;  (remote-force-server-set! runremote (common:force-server?))
;;      ;;  (mutex-unlock! *rmt-mutex*)
;;      ;;  (debug:print-info 12 *default-log-port* "rmt:send-receive, case  6")
;;      ;;  (rmt:send-receive cmd rid params attemptnum: attemptnum))
;; 
;;      ;;DOT CASE7 [label="homehost\nwrite"];
;;      ;;DOT MUTEXLOCK -> CASE7 [label="server not required,\non homehost,\na write,\nhave a server"]; {rank=same "case 7" CASE7};
;;      ;;DOT CASE7 -> "rmt:open-qry-close-locally";
;;      ;; on homehost and this is a write, we already have a server
;;      ((and (not (remote-force-server runremote))     ;; honor forced use of server, i.e. server NOT required
;; 	   (cdr (remote-hh-dat runremote))           ;; on homehost
;;            (not (member cmd api:read-only-queries))  ;; this is a write
;;            (remote-server-url runremote))            ;; have a server
;;       (mutex-unlock! *rmt-mutex*)
;;       (debug:print-info 12 *default-log-port* "rmt:send-receive, case  4.1")
;;       (rmt:open-qry-close-locally cmd 0 params))
;; 
;;      ;;DOT CASE8 [label="force\nserver"];
;;      ;;DOT MUTEXLOCK -> CASE8 [label="server not required,\nhave homehost info,\nno connection yet,\nnot a read-only query"]; {rank=same "case 8" CASE8};
;;      ;;DOT CASE8 -> "rmt:open-qry-close-locally";
;;      ;;  on homehost, no server contact made and this is a write, passively start a server 
;;      ((and (not (remote-force-server runremote))     ;; honor forced use of server, i.e. server NOT required
;; 	   (cdr (remote-hh-dat runremote))           ;; have homehost
;;            (not (remote-server-url runremote))       ;; no connection yet
;; 	   (not (member cmd api:read-only-queries))) ;; not a read-only query
;;       (debug:print-info 12 *default-log-port* "rmt:send-receive, case  8")
;;       (let ((server-info  (server:check-if-running *toppath*))) ;; (server:read-dotserver->url *toppath*))) ;; (server:check-if-running *toppath*))) ;; Do NOT want to run server:check-if-running - very expensive to do for every write call
;; 	(if server-info
;; 	    (begin
;;               (remote-server-url-set! runremote (server:record->url server-info)) ;; the string can be consumed by the client setup if needed
;;               (remote-server-id-set! runremote (server:record->id server-info)))  
;; 	    (if (common:force-server?)
;; 		(server:start-and-wait *toppath*)
;; 		(server:kind-run *toppath*)))
;;       (remote-force-server-set! runremote (common:force-server?))
;;       (mutex-unlock! *rmt-mutex*)
;;       (debug:print-info 12 *default-log-port* "rmt:send-receive, case  8.1")
;;       (rmt:open-qry-close-locally cmd 0 params)))
;; 
;;      ;;DOT CASE9 [label="force server\nnot on homehost"];
;;      ;;DOT MUTEXLOCK -> CASE9 [label="no connection\nand either require server\nor not on homehost"]; {rank=same "case 9" CASE9};
;;      ;;DOT CASE9 -> "start\nserver" -> "rmt:send-receive";
;;      ((or (and (remote-force-server runremote)              ;; we are forcing a server and don't yet have a connection to one
;; 	       (not (remote-conndat runremote)))
;; 	  (and (not (cdr (remote-hh-dat runremote)))        ;; not on a homehost 
;; 	       (not (remote-conndat runremote))))           ;; and no connection
;;       (debug:print-info 12 *default-log-port* "rmt:send-receive, case 9, hh-dat: " (remote-hh-dat runremote) " conndat: " (remote-conndat runremote))
;;       (mutex-unlock! *rmt-mutex*)
;;       (if (not (server:check-if-running *toppath*)) ;; who knows, maybe one has started up?
;; 	  (server:start-and-wait *toppath*))
;;       (remote-conndat-set! runremote (rmt:get-connection-info *toppath* runremote)) ;; calls client:setup which calls client:setup-http
;;       (rmt:send-receive cmd rid params attemptnum: attemptnum)) ;; TODO: add back-off timeout as
;; 
;;      ;;DOT CASE10 [label="on homehost"];
;;      ;;DOT MUTEXLOCK -> CASE10 [label="server not required,\non homehost"]; {rank=same "case 10" CASE10};
;;      ;;DOT CASE10 -> "rmt:open-qry-close-locally";
;;      ;; all set up if get this far, dispatch the query
;;      ((and (not (remote-force-server runremote))
;; 	   (cdr (remote-hh-dat runremote))) ;; we are on homehost
;;       (mutex-unlock! *rmt-mutex*)
;;       (debug:print-info 12 *default-log-port* "rmt:send-receive, case 10")
;;       (rmt:open-qry-close-locally cmd (if rid rid 0) params))
;; 
;;      ;;DOT CASE11 [label="send_receive"];
;;      ;;DOT MUTEXLOCK -> CASE11 [label="else"]; {rank=same "case 11" CASE11};
;;      ;;DOT CASE11 -> "rmt:send-receive" [label="call failed"];
;;      ;;DOT CASE11 -> "RESULT" [label="call succeeded"];
;;      ;; not on homehost, do server query
;;      (else (extras-case-11 *default-log-port* runremote cmd params attemptnum rid)))))
;;     ;;DOT }
;; 
;; ;; bunch of small functions factored out of send-receive to make debug easier
;; ;;
;; 

;; (define (extras-case-11 *default-log-port* runremote cmd params attemptnum rid)
;;   ;; (mutex-unlock! *rmt-mutex*)
;;   (debug:print-info 12 *default-log-port* "rmt:send-receive, case  9")
;;   ;; (mutex-lock! *rmt-mutex*)
;;   (let* ((conninfo (remote-conndat runremote))
;; 	 (dat-in  (condition-case ;; handling here has
;; 			     ;; caused a lot of
;; 			     ;; problems. However it
;; 			     ;; is needed to deal with
;; 			     ;; attemtped
;; 			     ;; communication to
;; 			     ;; servers that have gone
;; 			     ;; away
;; 			     (http-transport:client-api-send-receive 0 runremote cmd params)
;; 			     ;; (http-transport:client-api-send-receive 0 conninfo cmd params runremote)
;; 			     ((servermismatch)  (vector #f "Server id mismatch" ))
;; 			     ((commfail)(vector #f "communications fail"))
;; 			     ((exn)(vector #f "other fail" (print-call-chain)))))
;; 	 (dat      (if (and (vector? dat-in) ;; ... check it is a correct size
;; 			    (> (vector-length dat-in) 1))
;; 		       dat-in
;; 		       (vector #f (conc "communications fail (type 2), dat-in=" dat-in))))
;; 	 (success  (if (vector? dat) (vector-ref dat 0) #f))
;; 	 (res      (if (vector? dat) (vector-ref dat 1) #f)))
;;     (if (and (vector? conninfo) (< 5 (vector-length conninfo)))
;; 	(remote-last-access-set! runremote (current-seconds)) ;; refresh access time
;; 	(begin
;; 	  (debug:print 0 *default-log-port* "INFO: Should not get here! conninfo=" conninfo)
;; 	  (set! conninfo #f)
;; 	  (http-transport:close-connections runremote)))
;;     (debug:print-info 13 *default-log-port* "rmt:send-receive, case  9. conninfo=" conninfo " dat=" dat " runremote = " runremote)
;;     (mutex-unlock! *rmt-mutex*)
;;     (if success ;; success only tells us that the transport was
;; 	;; successful, have to examine the data to see if
;; 	;; there was a detected issue at the other end
;; 	(extras-transport-succeded *default-log-port* *rmt-mutex* attemptnum runremote res params rid cmd)
;; 	(begin
;;            (debug:print-error 0 *default-log-port* " dat=" dat) 
;;            (extras-transport-failed *default-log-port* *rmt-mutex* attemptnum runremote cmd rid params))
;; 	)))
;; 
;; (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\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))
;; 
;; (define (rmt:open-qry-close-locally cmd run-id params #!key (remretries 5))
;;   (let* ((qry-is-write    (not (member cmd api:read-only-queries)))
;; 	 (db-file-path    (db:dbfile-path)) ;;  0))
;; 	 (dbstructs-local (db:setup #t))  ;; make-dbr:dbstruct path:  dbdir local: #t)))
;; 	 (read-only       (not (file-write-access? db-file-path)))
;; 	 (start           (current-milliseconds))
;; 	 (resdat          (if (not (and read-only qry-is-write))
;; 			      (let ((v (api:execute-requests dbstructs-local (vector (symbol->string cmd) params))))
;; 			;;	(handle-exceptions ;; there has been a long history of receiving strange errors from values returned by the client when things go wrong..
;; 			;;	 exn               ;;  This is an attempt to detect that situation and recover gracefully
;; 			;;	 (begin
;; 			;;	   (debug:print 0 *default-log-port* "ERROR: bad data from server " v " message: "  ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)
;; 			;;	   (vector #t '())) ;; should always get a vector but if something goes wrong return a dummy
;; 				 (if (and (vector? v)
;; 					  (> (vector-length v) 1))
;; 				     (let ((newvec (vector (vector-ref v 0)(vector-ref v 1))))
;; 				       newvec)           ;; by copying the vector while inside the error handler we should force the detection of a corrupted record
;; 				     (vector #t '()))) ;; )  ;; we could also check that the returned types are valid
;; 			      (vector #t '())))
;; 	 (success        (vector-ref resdat 0))
;; 	 (res            (vector-ref resdat 1))
;; 	 (duration       (- (current-milliseconds) start)))
;;     (if (and read-only qry-is-write)
;;         (debug:print 0 *default-log-port* "ERROR: attempt to write to read-only database ignored. cmd=" cmd))
;;     (if (not success)
;; 	(if (> remretries 0)
;; 	    (begin
;; 	      (debug:print-error 0 *default-log-port* "local query failed. Trying again.")
;; 	      (thread-sleep! (/ (random 5000) 1000)) ;; some random delay 
;; 	      (rmt:open-qry-close-locally cmd run-id params remretries: (- remretries 1)))
;; 	    (begin
;; 	      (debug:print-error 0 *default-log-port* "too many retries in rmt:open-qry-close-locally, giving up")
;; 	      #f))
;; 	(begin
;; 	  ;; (rmt:update-db-stats run-id cmd params duration)
;; 	  ;; mark this run as dirty if this was a write, the watchdog is responsible for syncing it
;; 	  (if qry-is-write
;; 	      (let ((start-time (current-seconds)))
;; 		(mutex-lock! *db-multi-sync-mutex*)
;; /		(set! *db-last-access* start-time)  ;; THIS IS PROBABLY USELESS? (we are on a client)
;;                 (mutex-unlock! *db-multi-sync-mutex*)))))
;;     res))
;; 
;; (define (rmt:send-receive-no-auto-client-setup runremote cmd run-id params)
;;   (let* ((run-id   (if run-id run-id 0))
;; 	 (res  	   (http-transport:client-api-send-receive run-id runremote cmd params)))
;;     (if (and res (vector-ref res 0))
;; 	(vector-ref res 1) ;;; YES!! THIS IS CORRECT!! CHANGE IT HERE, THEN CHANGE rmt:send-receive ALSO!!!
;; 	#f)))
;; 
;; ;;======================================================================
;; ;;
;; ;; A C T U A L   A P I   C A L L S  
;; ;;
;; ;;======================================================================
;; 
;; ;;======================================================================
;; ;;  S E R V E R










;; ;;======================================================================
;; 
;; (define (rmt:kill-server run-id)
;;   (rmt:send-receive 'kill-server run-id (list run-id)))
;; 
;; (define (rmt:start-server run-id)
;;   (rmt:send-receive 'start-server 0 (list run-id)))
;; 
;; ;;======================================================================
;; ;;  M I S C
;; ;;======================================================================
;; 
;; (define (rmt:login run-id)
;;   (rmt:send-receive 'login run-id (list *toppath* megatest-version (client:get-signature))))
;; 
;; ;; This login does no retries under the hood - it acts a bit like a ping.
;; ;; Deprecated for nmsg-transport.
;; ;;
;; (define (rmt:login-no-auto-client-setup runremote)
;;   (rmt:send-receive-no-auto-client-setup runremote 'login 0 (list *toppath* megatest-version (client:get-signature))))
;; 
;; ;; hand off a call to one of the db:queries statements
;; ;; added run-id to make looking up the correct db possible 
;; ;;
;; (define (rmt:general-call stmtname run-id . params)
;;   (rmt:send-receive 'general-call run-id (append (list stmtname run-id) params)))
;; 
;; 
;; ;; given a hostname, return a pair of cpu load and update time representing latest intelligence from tests running on that host
;; (define (rmt:get-latest-host-load hostname)
;;   (rmt:send-receive 'get-latest-host-load 0 (list hostname)))

















;; 
;; (define (rmt:sdb-qry qry val run-id)
;;   ;; add caching if qry is 'getid or 'getstr
;;   (rmt:send-receive 'sdb-qry run-id (list qry val)))
;; 
;; ;; NOT COMPLETED
;; (define (rmt:runtests user run-id testpatt params)
;;   (rmt:send-receive 'runtests run-id testpatt))
;; 
;; (define (rmt:get-run-record-ids  target run keynames test-patt)
;;   (rmt:send-receive 'get-run-record-ids #f (list target run keynames test-patt)))
;; 
;; (define (rmt:get-changed-record-ids since-time)
;;   (rmt:send-receive 'get-changed-record-ids #f (list since-time)) )
;; 
;; (define (rmt:drop-all-triggers)
;;      (rmt:send-receive 'drop-all-triggers #f '()))
;; 
;; (define (rmt:create-all-triggers)
;;      (rmt:send-receive 'create-all-triggers #f '()))
;; 
;; ;;======================================================================
;; ;;  T E S T   M E T A 
;; ;;======================================================================
;; 
;; (define (rmt:get-tests-tags)
;;   (rmt:send-receive 'get-tests-tags #f '()))
;; 
;; ;;======================================================================
;; ;;  K E Y S 
;; ;;======================================================================
;; 
;; ;; These require run-id because the values come from the run!
;; ;;
;; (define (rmt:get-key-val-pairs run-id)
;;   (rmt:send-receive 'get-key-val-pairs run-id (list run-id)))
;; 
;; (define (rmt:get-keys)
;;   (if *db-keys* *db-keys* 
;;      (let ((res (rmt:send-receive 'get-keys #f '())))
;;        (set! *db-keys* res)
;;        res)))
;; 
;; (define (rmt:get-keys-write) ;; dummy query to force server start
;;   (let ((res (rmt:send-receive 'get-keys-write #f '())))
;;     (set! *db-keys* res)
;;     res))
;; 
;; ;; we don't reuse run-id's (except possibly *after* a db cleanup) so it is safe
;; ;; to cache the resuls in a hash
;; ;;
;; (define (rmt:get-key-vals run-id)
;;   (or (hash-table-ref/default *keyvals* run-id #f)
;;       (let ((res (rmt:send-receive 'get-key-vals #f (list run-id))))
;;         (hash-table-set! *keyvals* run-id res)
;;         res)))
;; 
;; (define (rmt:get-targets)
;;   (rmt:send-receive 'get-targets #f '()))
;; 
;; (define (rmt:get-target run-id)
;;   (assert (number? run-id) "FATAL: Run id required.")
;;   (rmt:send-receive 'get-target run-id (list run-id)))
;; 
;; (define (rmt:get-run-times runpatt targetpatt)
;;   (rmt:send-receive 'get-run-times #f (list runpatt targetpatt ))) 
;; 
;; 
;; ;;======================================================================
;; ;;  T E S T S
;; ;;======================================================================
;; 
;; ;; Just some syntatic sugar
;; (define (rmt:register-test run-id test-name item-path)
;;   (assert (number? run-id) "FATAL: Run id required.")
;;   (rmt:general-call 'register-test run-id run-id test-name item-path))
;; 
;; (define (rmt:get-test-id run-id testname item-path)
;;   (assert (number? run-id) "FATAL: Run id required.")
;;   (rmt:send-receive 'get-test-id run-id (list run-id testname item-path)))
;; 
;; ;; run-id is NOT used
;; ;;
;; (define (rmt:get-test-info-by-id run-id test-id)
;;   (if (number? test-id)
;;       (rmt:send-receive 'get-test-info-by-id run-id (list run-id test-id))
;;       (begin
;; 	(debug:print 0 *default-log-port* "WARNING: Bad data handed to rmt:get-test-info-by-id run-id=" run-id ", test-id=" test-id)
;; 	(print-call-chain (current-error-port))
;; 	#f)))
;; 
;; (define (rmt:test-get-rundir-from-test-id run-id test-id)
;;   (rmt:send-receive 'test-get-rundir-from-test-id run-id (list run-id test-id)))
;; 
;; (define (rmt:open-test-db-by-test-id run-id test-id #!key (work-area #f))
;;   (assert (number? run-id) "FATAL: Run id required.")
;;   (let* ((test-path (if (string? work-area)
;; 			work-area
;; 			(rmt:test-get-rundir-from-test-id run-id test-id))))
;;     (debug:print 3 *default-log-port* "TEST PATH: " test-path)
;;     (open-test-db test-path)))
;; 
;; ;; WARNING: This currently bypasses the transaction wrapped writes system
;; (define (rmt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment)
;;   (assert (number? run-id) "FATAL: Run id required.")
;;   (rmt:send-receive 'test-set-state-status-by-id run-id (list run-id test-id newstate newstatus newcomment)))
;; 
;; (define (rmt:set-tests-state-status run-id testnames currstate currstatus newstate newstatus)
;;   (assert (number? run-id) "FATAL: Run id required.")
;;   (rmt:send-receive 'set-tests-state-status run-id (list run-id testnames currstate currstatus newstate newstatus)))
;; 
;; (define (rmt:get-tests-for-run run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode)
















;;   (assert (number? run-id) "FATAL: Run id required.")
;;   ;; (if (number? run-id)
;;   (rmt:send-receive 'get-tests-for-run run-id (list run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode)))
;;   ;;    (begin
;;   ;;	(debug:print-error 0 *default-log-port* "rmt:get-tests-for-run called with bad run-id=" run-id)
;;   ;;	(print-call-chain (current-error-port))
;;   ;;	'())))
;; 
;; (define (rmt:get-tests-for-run-state-status run-id testpatt last-update)
;;   (assert (number? run-id) "FATAL: Run id required.")
;;   (rmt:send-receive 'get-tests-for-run-state-status run-id (list run-id testpatt last-update)))
;; 

;; ;; get stuff via synchash 
;; (define (rmt:synchash-get run-id proc synckey keynum params)
;;   (assert (number? run-id) "FATAL: Run id required.")
;;   (rmt:send-receive 'synchash-get run-id (list run-id proc synckey keynum params)))
;; 
;; (define (rmt:get-tests-for-run-mindata run-id testpatt states status not-in)





;;   (assert (number? run-id) "FATAL: Run id required.")








;;   (rmt:send-receive 'get-tests-for-run-mindata run-id (list run-id testpatt states status not-in)))














;;   
;; ;; IDEA: Threadify these - they spend a lot of time waiting ...
;; ;;
;; (define (rmt:get-tests-for-runs-mindata run-ids testpatt states status not-in)
;;   (let ((multi-run-mutex (make-mutex))
;; 	(run-id-list (if run-ids
;; 			 run-ids
;; 			 (rmt:get-all-run-ids)))
;; 	(result      '()))
;;     (if (null? run-id-list)
;; 	'()
;; 	(let loop ((hed     (car run-id-list))
;; 		   (tal     (cdr run-id-list))
;; 		   (threads '()))
;; 	  (if (> (length threads) 5)
;; 	      (loop hed tal (filter (lambda (th)(not (member (thread-state th) '(terminated dead)))) threads))
;; 	      (let* ((newthread (make-thread
;; 				 (lambda ()
;; 				   (let ((res (rmt:send-receive 'get-tests-for-run-mindata hed (list hed testpatt states status not-in))))
;; 				     (if (list? res)
;; 					 (begin
;; 					   (mutex-lock! multi-run-mutex)
;; 					   (set! result (append result res))
;; 					   (mutex-unlock! multi-run-mutex))
;; 					 (debug:print-error 0 *default-log-port* "get-tests-for-run-mindata failed for run-id " hed ", testpatt " testpatt ", states " states ", status " status ", not-in " not-in))))
;; 				 (conc "multi-run-thread for run-id " hed)))
;; 		     (newthreads (cons newthread threads)))
;; 		(thread-start! newthread)
;; 		(thread-sleep! 0.05) ;; give that thread some time to start
;; 		(if (null? tal)
;; 		    newthreads
;; 		    (loop (car tal)(cdr tal) newthreads))))))



;;     result))
;; 
;; ;; ;; IDEA: Threadify these - they spend a lot of time waiting ...
;; ;; ;;
;; ;; (define (rmt:get-tests-for-runs-mindata run-ids testpatt states status not-in)


;; ;;   (let ((run-id-list (if run-ids
;; ;; 			 run-ids
;; ;; 			 (rmt:get-all-run-ids))))
;; ;;     (apply append (map (lambda (run-id)
;; ;; 			 (rmt:send-receive 'get-tests-for-run-mindata run-id (list run-ids testpatt states status not-in)))
;; ;; 		       run-id-list))))
;; 
;; (define (rmt:delete-test-records run-id test-id)
;;   (assert (number? run-id) "FATAL: Run id required.")
;;   (rmt:send-receive 'delete-test-records run-id (list run-id test-id)))
;; 
;; (define (rmt:test-set-state-status run-id test-id state status msg)
;;   (assert (number? run-id) "FATAL: Run id required.")
;;   (rmt:send-receive 'test-set-state-status run-id (list run-id test-id state status msg)))
;; 
;; (define (rmt:test-toplevel-num-items run-id test-name)
;;   (assert (number? run-id) "FATAL: Run id required.")
;;   (rmt:send-receive 'test-toplevel-num-items run-id (list run-id test-name)))
;; 
;; ;; (define (rmt:get-previous-test-run-record run-id test-name item-path)
;; ;;   (rmt:send-receive 'get-previous-test-run-record run-id (list run-id test-name item-path)))
;; 
;; (define (rmt:get-matching-previous-test-run-records run-id test-name item-path)
;;   (assert (number? run-id) "FATAL: Run id required.")
;;   (rmt:send-receive 'get-matching-previous-test-run-records run-id (list run-id test-name item-path)))
;; 
;; (define (rmt:test-get-logfile-info run-id test-name)
;;   (assert (number? run-id) "FATAL: Run id required.")
;;   (rmt:send-receive 'test-get-logfile-info run-id (list run-id test-name)))
;; 
;; (define (rmt:test-get-records-for-index-file run-id test-name)
;;   (assert (number? run-id) "FATAL: Run id required.")
;;   (rmt:send-receive 'test-get-records-for-index-file run-id (list run-id test-name)))
;; 
;; (define (rmt:get-testinfo-state-status run-id test-id)
;;   (assert (number? run-id) "FATAL: Run id required.")
;;   (rmt:send-receive 'get-testinfo-state-status run-id (list run-id test-id)))
;; 
;; (define (rmt:test-set-log! run-id test-id logf)
;;   (assert (number? run-id) "FATAL: Run id required.")
;;   (if (string? logf)(rmt:general-call 'test-set-log run-id logf test-id)))
;; 
;; (define (rmt:test-set-top-process-pid run-id test-id pid)
;;   (assert (number? run-id) "FATAL: Run id required.")
;;   (rmt:send-receive 'test-set-top-process-pid run-id (list run-id test-id pid)))
;; 
;; (define (rmt:test-get-top-process-pid run-id test-id)
;;   (assert (number? run-id) "FATAL: Run id required.")
;;   (rmt:send-receive 'test-get-top-process-pid run-id (list run-id test-id)))
;; 
;; (define (rmt:get-run-ids-matching-target keynames target res runname testpatt statepatt statuspatt)
;;   (rmt:send-receive 'get-run-ids-matching-target #f (list keynames target res runname testpatt statepatt statuspatt)))


;; 
;; ;; NOTE: This will open and access ALL run databases. 
;; ;;
;; (define (rmt:test-get-paths-matching-keynames-target-new keynames target res testpatt statepatt statuspatt runname)
;;   (let ((run-ids (rmt:get-run-ids-matching-target keynames target res runname testpatt statepatt statuspatt)))
;;     (apply append 
;; 	   (map (lambda (run-id)
;; 		  (rmt:send-receive 'test-get-paths-matching-keynames-target-new run-id (list run-id keynames target res testpatt statepatt statuspatt runname)))
;; 	   run-ids))))
;; 
;; (define (rmt:get-prereqs-not-met run-id waitons ref-test-name ref-item-path #!key (mode '(normal))(itemmaps #f))
;;   (assert (number? run-id) "FATAL: Run id required.")
;;   (rmt:send-receive 'get-prereqs-not-met run-id (list run-id waitons ref-test-name ref-item-path mode itemmaps)))
;; 
;; (define (rmt:get-count-tests-running-for-run-id run-id)
;;   (assert (number? run-id) "FATAL: Run id required.")
;;   (rmt:send-receive 'get-count-tests-running-for-run-id run-id (list run-id)))
;; 
;; (define (rmt:get-not-completed-cnt run-id)
;;   (assert (number? run-id) "FATAL: Run id required.")
;;   (rmt:send-receive 'get-not-completed-cnt run-id (list run-id)))
;; 
;; 
;; ;; Statistical queries
;; 
;; (define (rmt:get-count-tests-running run-id)
;;   (assert (number? run-id) "FATAL: Run id required.")
;;   (rmt:send-receive 'get-count-tests-running run-id (list run-id)))
;; 
;; (define (rmt:get-count-tests-running-for-testname run-id testname)
;;   (assert (number? run-id) "FATAL: Run id required.")
;;   (rmt:send-receive 'get-count-tests-running-for-testname run-id (list run-id testname)))
;; 
;; (define (rmt:get-count-tests-running-in-jobgroup run-id jobgroup)
;;   (assert (number? run-id) "FATAL: Run id required.")
;;   (rmt:send-receive 'get-count-tests-running-in-jobgroup run-id (list run-id jobgroup)))


;; 



;; ;; state and status are extra hints not usually used in the calculation

























;; ;;
;; (define (rmt:set-state-status-and-roll-up-items run-id test-name item-path state status comment)
;;   (assert (number? run-id) "FATAL: Run id required.")
;;   (rmt:send-receive 'set-state-status-and-roll-up-items run-id (list run-id test-name item-path state status comment)))
;; 
;; (define (rmt:set-state-status-and-roll-up-run run-id state status)
;;   (assert (number? run-id) "FATAL: Run id required.")
;;   (rmt:send-receive 'set-state-status-and-roll-up-run run-id (list run-id state status)))
;; 
;; 
;; (define (rmt:update-pass-fail-counts run-id test-name)

;;   (assert (number? run-id) "FATAL: Run id required.")
;;   (rmt:general-call 'update-pass-fail-counts run-id test-name test-name test-name))

;; 

;; (define (rmt:top-test-set-per-pf-counts run-id test-name)
;;   (assert (number? run-id) "FATAL: Run id required.")
;;   (rmt:send-receive 'top-test-set-per-pf-counts run-id (list run-id test-name)))
;; 
;; (define (rmt:get-raw-run-stats run-id)
;;   (assert (number? run-id) "FATAL: Run id required.")
;;   (rmt:send-receive 'get-raw-run-stats run-id (list run-id)))
;; 
;; (define (rmt:get-test-times runname target)
;;   (rmt:send-receive 'get-test-times #f (list runname target ))) 
;; 
;; ;;======================================================================
;; ;;  R U N S
;; ;;======================================================================
;; 
;; ;; BUG - LOOK AT HOW THIS WORKS!!!
;; ;;
;; (define (rmt:get-run-info run-id)
;;   (assert (number? run-id) "FATAL: Run id required.")
;;   (rmt:send-receive 'get-run-info #f (list run-id)))
;; 
;; (define (rmt:get-num-runs runpatt)
;;   (rmt:send-receive 'get-num-runs #f (list runpatt)))
;; 
;; (define (rmt:get-runs-cnt-by-patt runpatt targetpatt keys)
;;   (rmt:send-receive 'get-runs-cnt-by-patt #f (list runpatt  targetpatt keys)))
;; 


;; ;; Use the special run-id == #f scenario here since there is no run yet
;; (define (rmt:register-run keyvals runname state status user contour)
;;   (rmt:send-receive 'register-run #f (list keyvals runname state status user contour)))
;;     
;; (define (rmt:get-run-name-from-id run-id)
;;   (assert (number? run-id) "FATAL: Run id required.")
;;   (rmt:send-receive 'get-run-name-from-id #f (list run-id)))
;; 
;; (define (rmt:delete-run run-id)
;;   (rmt:send-receive 'delete-run #f (list run-id)))
;; 
;; (define (rmt:update-run-stats run-id stats)
;;   (rmt:send-receive 'update-run-stats #f (list run-id stats)))
;; 
;; (define (rmt:delete-old-deleted-test-records)
;;   (rmt:send-receive 'delete-old-deleted-test-records #f '()))
;; 
;; (define (rmt:get-runs runpatt count offset keypatts)
;;   (rmt:send-receive 'get-runs #f (list runpatt count offset keypatts)))
;; 
;; (define (rmt:simple-get-runs runpatt count offset target last-update)
;;   (rmt:send-receive 'simple-get-runs #f (list runpatt count offset target last-update)))
;; 
;; (define (rmt:get-all-run-ids)
;;   (rmt:send-receive 'get-all-run-ids #f '()))
;; 
;; (define (rmt:get-prev-run-ids run-id)
;;   (assert (number? run-id) "FATAL: Run id required.")
;;   (rmt:send-receive 'get-prev-run-ids #f (list run-id)))
;; 
;; (define (rmt:lock/unlock-run run-id lock unlock user)
;;   (assert (number? run-id) "FATAL: Run id required.")
;;   (rmt:send-receive 'lock/unlock-run #f (list run-id lock unlock user)))
;; 
;; ;; set/get status
;; (define (rmt:get-run-status run-id)
;;   (assert (number? run-id) "FATAL: Run id required.")
;;   (rmt:send-receive 'get-run-status #f (list run-id)))
;; 
;; (define (rmt:get-run-state run-id)
;;   (assert (number? run-id) "FATAL: Run id required.")
;;   (rmt:send-receive 'get-run-state #f (list run-id)))
;; 
;; 
;; (define (rmt:set-run-status run-id run-status #!key (msg #f))
;;   (assert (number? run-id) "FATAL: Run id required.")
;;   (rmt:send-receive 'set-run-status #f (list run-id run-status msg)))
;; 
;; (define (rmt:set-run-state-status run-id state status )







;;   (assert (number? run-id) "FATAL: Run id required.")
;;   (rmt:send-receive 'set-run-state-status #f (list run-id state status)))
;; 
;; (define (rmt:update-tesdata-on-repilcate-db old-lt new-lt)
;; (rmt:send-receive 'update-tesdata-on-repilcate-db #f (list old-lt new-lt)))
;; 
;; (define (rmt:update-run-event_time run-id)
;;   (assert (number? run-id) "FATAL: Run id required.")
;;   (rmt:send-receive 'update-run-event_time #f (list run-id)))
;; 
;; (define (rmt:get-runs-by-patt  keys runnamepatt targpatt offset limit fields last-runs-update  #!key  (sort-order "asc")) ;; fields of #f uses default
;;   (rmt:send-receive 'get-runs-by-patt #f (list keys runnamepatt targpatt offset limit fields last-runs-update sort-order)))
;; 
;; (define (rmt:find-and-mark-incomplete run-id ovr-deadtime)
;;   (assert (number? run-id) "FATAL: Run id required.")
;;   ;; (if (rmt:send-receive 'have-incompletes? run-id (list run-id ovr-deadtime))
;;   (rmt:send-receive 'mark-incomplete run-id (list run-id ovr-deadtime))) ;; )
;; 
;; (define (rmt:get-main-run-stats run-id)
;;   (assert (number? run-id) "FATAL: Run id required.")
;;   (rmt:send-receive 'get-main-run-stats #f (list run-id)))
;; 
;; (define (rmt:get-var varname)
;;   (rmt:send-receive 'get-var #f (list varname)))
;; 
;; (define (rmt:del-var varname)
;;   (rmt:send-receive 'del-var #f (list varname)))
;; 
;; (define (rmt:set-var varname value)
;;   (rmt:send-receive 'set-var #f (list varname value)))
;; 
;; (define (rmt:inc-var varname)
;;   (rmt:send-receive 'inc-var #f (list varname)))
;; 
;; (define (rmt:dec-var varname)
;;   (rmt:send-receive 'dec-var #f (list varname)))
;; 
;; (define (rmt:add-var varname value)
;;   (rmt:send-receive 'add-var #f (list varname value)))
;; 
;; ;;======================================================================
;; ;; M U L T I R U N   Q U E R I E S
;; ;;======================================================================
;; 
;; ;; Need to move this to multi-run section and make associated changes
;; (define (rmt:find-and-mark-incomplete-all-runs #!key (ovr-deadtime #f))
;;   (let ((run-ids (rmt:get-all-run-ids)))
;;     (for-each (lambda (run-id)
;; 	       (rmt:find-and-mark-incomplete run-id ovr-deadtime))
;; 	     run-ids)))
;; 
;; ;; get the previous record for when this test was run where all keys match but runname
;; ;; returns #f if no such test found, returns a single test record if found
;; ;; 
;; ;; Run this at the client end since we have to connect to multiple run-id dbs
;; ;;
;; (define (rmt:get-previous-test-run-record run-id test-name item-path)
;;   (let* ((keyvals (rmt:get-key-val-pairs run-id))
;; 	 (keys    (rmt:get-keys))
;; 	 (selstr  (string-intersperse  keys ","))
;; 	 (qrystr  (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND ")))
;;     (if (not keyvals)
;; 	#f
;; 	(let ((prev-run-ids (rmt:get-prev-run-ids run-id)))
;; 	  ;; for each run starting with the most recent look to see if there is a matching test
;; 	  ;; if found then return that matching test record
;; 	  (debug:print 4 *default-log-port* "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids)
;; 	  (if (null? prev-run-ids) #f
;; 	      (let loop ((hed (car prev-run-ids))
;; 			 (tal (cdr prev-run-ids)))
;; 		(let ((results (rmt:get-tests-for-run hed (conc test-name "/" item-path) '() '() ;; run-id testpatt states statuses
;; 						      #f #f #f               ;; offset limit not-in hide/not-hide
;; 						      #f #f #f #f 'normal))) ;; sort-by sort-order qryvals last-update mode
;; 		  (debug:print 4 *default-log-port* "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path ": " results)
;; 		  (if (and (null? results)
;; 			   (not (null? tal)))
;; 		      (loop (car tal)(cdr tal))
;; 		      (if (null? results) #f
;; 			  (car results))))))))))
;; 
;; (define (rmt:get-run-stats)
;;   (rmt:send-receive 'get-run-stats #f '()))
;; 
;; ;;======================================================================
;; ;;  S T E P S
;; ;;======================================================================
;; 
;; ;; Getting steps is more complicated.
;; ;;
;; ;; If given work area 
;; ;;  1. Find the testdat.db file
;; ;;  2. Open the testdat.db file and do the query
;; ;; If not given the work area
;; ;;  1. Do a remote call to get the test path
;; ;;  2. Continue as above
;; ;; 
;; ;;(define (rmt:get-steps-for-test run-id test-id)
;; ;;  (rmt:send-receive 'get-steps-data run-id (list test-id)))
;; 
;; (define (rmt:teststep-set-status! run-id test-id teststep-name state-in status-in comment logfile)
;;   (assert (number? run-id) "FATAL: Run id required.")
;;   (let* ((state     (items:check-valid-items "state" state-in))
;; 	 (status    (items:check-valid-items "status" status-in)))
;;     (if (or (not state)(not status))
;; 	(debug:print 3 *default-log-port* "WARNING: Invalid " (if status "status" "state")
;; 		     " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config"))
;;     (rmt:send-receive 'teststep-set-status! run-id (list run-id test-id teststep-name state-in status-in comment logfile))))
;; 
;; 
;; (define (rmt:delete-steps-for-test! run-id test-id)
;;   (assert (number? run-id) "FATAL: Run id required.")
;;   (rmt:send-receive 'delete-steps-for-test! run-id (list run-id test-id)))
;; 
;; (define (rmt:get-steps-for-test run-id test-id)
;;   (assert (number? run-id) "FATAL: Run id required.")
;;   (rmt:send-receive 'get-steps-for-test run-id (list run-id test-id)))
;; 
;; (define (rmt:get-steps-info-by-id run-id test-step-id)
;;   (assert (number? run-id) "FATAL: Run id required.")
;;   (rmt:send-receive 'get-steps-info-by-id #f (list run-id test-step-id)))
;; 
;; ;;======================================================================
;; ;;  T E S T   D A T A 
;; ;;======================================================================
;; 
;; (define (rmt:read-test-data run-id test-id categorypatt #!key (work-area #f)) 
;;   (assert (number? run-id) "FATAL: Run id required.")
;;   (rmt:send-receive 'read-test-data run-id (list run-id test-id categorypatt)))
;; 
;; (define (rmt:read-test-data-varpatt run-id test-id categorypatt varpatt #!key (work-area #f)) 
;;   (assert (number? run-id) "FATAL: Run id required.")
;;   (rmt:send-receive 'read-test-data-varpatt run-id (list run-id test-id categorypatt varpatt)))
;; 
;; (define (rmt:get-data-info-by-id run-id test-data-id)
;;   (assert (number? run-id) "FATAL: Run id required.")
;;    (rmt:send-receive 'get-data-info-by-id #f (list run-id test-data-id)))
;; 
;; (define (rmt:testmeta-add-record testname)
;;   (rmt:send-receive 'testmeta-add-record #f (list testname)))
;; 
;; (define (rmt:testmeta-get-record testname)
;;   (rmt:send-receive 'testmeta-get-record #f (list testname)))
;; 
;; (define (rmt:testmeta-update-field test-name fld val)
;;   (rmt:send-receive 'testmeta-update-field #f (list test-name fld val)))
;; 
;; (define (rmt:test-data-rollup run-id test-id status)
;;   (assert (number? run-id) "FATAL: Run id required.")
;;   (rmt:send-receive 'test-data-rollup run-id (list run-id test-id status)))
;; 
;; (define (rmt:csv->test-data run-id test-id csvdata)
;;   (assert (number? run-id) "FATAL: Run id required.")
;;   (rmt:send-receive 'csv->test-data run-id (list run-id test-id csvdata)))
;; 
;; ;;======================================================================
;; ;;  T A S K S
;; ;;======================================================================
;; 
;; (define (rmt:tasks-find-task-queue-records target run-name test-patt state-patt action-patt)
;;   (rmt:send-receive 'find-task-queue-records #f (list target run-name test-patt state-patt action-patt)))
;; 
;; (define (rmt:tasks-add action owner target runname testpatt params)
;;   (rmt:send-receive 'tasks-add #f (list action owner target runname testpatt params)))
;; 
;; (define (rmt:tasks-set-state-given-param-key param-key new-state)
;;   (rmt:send-receive 'tasks-set-state-given-param-key #f (list  param-key new-state)))
;; 
;; (define (rmt:tasks-get-last target runname)
;;   (rmt:send-receive 'tasks-get-last #f (list target runname)))
;; 
;; ;;======================================================================
;; ;; N O   S Y N C   D B 
;; ;;======================================================================
;; 
;; (define (rmt:no-sync-set var val)
;;   (rmt:send-receive 'no-sync-set #f `(,var ,val)))
;; 
;; (define (rmt:no-sync-get/default var default)
;;   (rmt:send-receive 'no-sync-get/default #f `(,var ,default)))
;; 
;; (define (rmt:no-sync-del! var)
;;   (rmt:send-receive 'no-sync-del! #f `(,var)))
;; 
;; (define (rmt:no-sync-get-lock keyname)
;;   (rmt:send-receive 'no-sync-get-lock #f `(,keyname)))
;; 
;; ;;======================================================================
;; ;; A R C H I V E S
;; ;;======================================================================
;; 
;; (define (rmt:archive-get-allocations  testname itempath dneeded)
;;   (rmt:send-receive 'archive-get-allocations #f (list testname itempath dneeded)))
;; 
;; (define (rmt:archive-register-block-name bdisk-id archive-path)
;;   (rmt:send-receive 'archive-register-block-name #f (list bdisk-id archive-path)))
;; 
;; (define (rmt:archive-allocate-testsuite/area-to-block block-id testsuite-name areakey)
;;   (rmt:send-receive 'archive-allocate-test-to-block #f (list  block-id testsuite-name areakey)))
;; 
;; (define (rmt:archive-register-disk bdisk-name bdisk-path df)
;;   (rmt:send-receive 'archive-register-disk #f (list bdisk-name bdisk-path df)))
;; 
;; (define (rmt:test-set-archive-block-id run-id test-id archive-block-id)
;;   (assert (number? run-id) "FATAL: Run id required.")
;;   (rmt:send-receive 'test-set-archive-block-id run-id (list run-id test-id archive-block-id)))
;; 
;; (define (rmt:test-get-archive-block-info archive-block-id)
;;   (rmt:send-receive 'test-get-archive-block-info #f (list archive-block-id)))
;; 
;; 
;; (define (rmtmod:calc-ro-mode runremote *toppath*)
;;   (if (and runremote
;; 	   (remote-ro-mode-checked runremote))
;;       (remote-ro-mode runremote)
;;       (let* ((mtcfgfile  (conc *toppath* "/megatest.config"))
;; 	     (ro-mode (not (file-write-access? mtcfgfile)))) ;; TODO: use dbstruct or runremote to figure this out in future
;; 	(if runremote
;; 	    (begin
;; 	      (remote-ro-mode-set! runremote ro-mode)
;; 	      (remote-ro-mode-checked-set! runremote #t)
;; 	      ro-mode)
;; 	    ro-mode))))
;; 
;; (define (extras-readonly-mode rmt-mutex log-port cmd params)
;;   (mutex-unlock! rmt-mutex)
;;   (debug:print-info 12 log-port "rmt:send-receive, case 3")
;;   (debug:print 0 log-port "WARNING: write transaction requested on a readonly area.  cmd="cmd" params="params)
;;   #f)
;; 
;; (define (extras-transport-failed *default-log-port* *rmt-mutex* attemptnum runremote cmd rid params)
;;   (debug:print 0 *default-log-port* "WARNING: communication failed. Trying again, try num: " attemptnum)
;;   (mutex-lock! *rmt-mutex*)
;;   (http-transport:close-connections runremote)
;;   (remote-server-url-set! runremote #f)
;;   (mutex-unlock! *rmt-mutex*)
;;   (debug:print-info 12 *default-log-port* "rmt:send-receive, case  9.1")
;;   (rmt:send-receive cmd rid params attemptnum: (+ attemptnum 1)))
;;   
;; (define (extras-transport-succeded *default-log-port* *rmt-mutex* attemptnum runremote res params rid cmd)
;;   (if (and (vector? res)
;; 	   (eq? (vector-length res) 2)
;; 	   (eq? (vector-ref res 1) 'overloaded)) ;; since we are
;; 						 ;; looking at the
;; 						 ;; data to carry the
;; 						 ;; error we'll use a
;; 						 ;; fairly obtuse
;; 						 ;; combo to minimise
;; 						 ;; the chances of
;; 						 ;; some sort of
;; 						 ;; collision.  this
;; 						 ;; is the case where
;; 						 ;; the returned data
;; 						 ;; is bad or the
;; 						 ;; server is
;; 						 ;; overloaded and we
;; 						 ;; want to ease off
;; 						 ;; the queries
;;       (let ((wait-delay (+ attemptnum (* attemptnum 10))))
;; 	(debug:print 0 *default-log-port* "WARNING: server is overloaded. Delaying " wait-delay " seconds and trying call again.")
;; 	(mutex-lock! *rmt-mutex*)
;; 	(http-transport:close-connections runremote)
;; 	(set! *runremote* #f) ;; force starting over
;; 	(mutex-unlock! *rmt-mutex*)
;; 	(thread-sleep! wait-delay)
;; 	(rmt:send-receive cmd rid params attemptnum: (+ attemptnum 1)))
;;       res)) ;; All good, return res
;; 
;; #;(set-functions rmt:send-receive                       remote-server-url-set!
;; 	       http-transport:close-connections	      remote-conndat-set!
;; 	       debug:print                            debug:print-info
;; 	       remote-ro-mode                         remote-ro-mode-set!
;; 	       remote-ro-mode-checked-set!            remote-ro-mode-checked)
;; 

;;     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 rmtmod))
(declare (uses commonmod))






(module rmtmod
	*
	





















































)

(declare (unit runs))
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
(declare (uses tests))
(declare (uses servermod))
(declare (uses mt))
(declare (uses archive))
;; (declare (uses filedb))

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

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

;; (require-extension (srfi 18) extras tcp s11n)
;; 
;; (use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest
;;      directory-utils posix-extras matchable utils)
;; 
;; (use spiffy uri-common intarweb http-client spiffy-request-vars)
;; 
;; (declare (unit server))
;; 
;; (declare (uses commonmod))
;; 
;; (declare (uses common))
;; (declare (uses db))
;; (declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
;; ;; (declare (uses synchash))
;; (declare (uses http-transport))
;; ;;(declare (uses rpc-transport))
;; (declare (uses launch))
;; ;; (declare (uses daemon))
;; 
;; (import commonmod)
;; 
;; (include "common_records.scm")
;; (include "db_records.scm")
;; 
;; (define (server:make-server-url hostport)
;;   (if (not hostport)
;;       #f
;;       (conc "http://" (car hostport) ":" (cadr hostport))))
;; 
;; (define  *server-loop-heart-beat* (current-seconds))
;; 
;; ;;======================================================================
;; ;; P K T S   S T U F F 
;; ;;======================================================================
;; 
;; ;; ???
;; 
;; ;;======================================================================
;; ;; P K T S   S T U F F 
;; ;;======================================================================
;; 
;; ;; ???
;; 
;; ;;======================================================================
;; ;; S E R V E R
;; ;;======================================================================
;; 
;; ;; Call this to start the actual server
;; ;;
;; 

;; ;;======================================================================
;; ;; S E R V E R   U T I L I T I E S 
;; ;;======================================================================
;; 
;; ;; Get the transport
;; (define (server:get-transport)
;;   (if *transport-type*
;;       *transport-type*
;;       (let ((ttype (string->symbol
;; 		    (or (args:get-arg "-transport")
;; 			(configf:lookup *configdat* "server" "transport")
;; 			"rpc"))))
;; 	(set! *transport-type* ttype)
;; 	ttype)))
;; 	    
;; ;; Generate a unique signature for this server
;; (define (server:mk-signature)
;;   (message-digest-string (md5-primitive) 
;; 			 (with-output-to-string
;; 			   (lambda ()
;; 			     (write (list (current-directory)
;;                                           (current-process-id)
;; 					  (argv)))))))
;; 
;; (define (server:get-client-signature)
;;   (if *my-client-signature* *my-client-signature*
;;       (let ((sig (server:mk-signature))) ;; clients re-use the server:mk-signature logic
;;         (set! *my-client-signature* sig)
;;         *my-client-signature*)))
;; 
;; (define (server:get-server-id)
;;   (if *server-id* *server-id*
;;       (let ((sig (server:mk-signature))) ;; clients re-use the server:mk-signature logic
;;         (set! *server-id* sig)
;;         *server-id*)))
;; 
;; ;; When using zmq this would send the message back (two step process)
;; ;; with spiffy or rpc this simply returns the return data to be returned
;; ;; 
;; (define (server:reply return-addr query-sig success/fail result)
;;   (debug:print-info 11 *default-log-port* "server:reply return-addr=" return-addr ", result=" result)
;;   ;; (send-message pubsock target send-more: #t)
;;   ;; (send-message pubsock 
;;   (case (server:get-transport)
;;     ((rpc)  (db:obj->string (vector success/fail query-sig result)))
;;     ((http) (db:obj->string (vector success/fail query-sig result)))
;;     ((fs)   result)
;;     (else 
;;      (debug:print-error 0 *default-log-port* "unrecognised transport type: " *transport-type*)
;;      result)))
;; 
;; ;; Given an area path,  start a server process    ### NOTE ### > file 2>&1 
;; ;; if the target-host is set 
;; ;; try running on that host
;; ;;   incidental: rotate logs in logs/ dir.
;; ;;
;; (define  (server:run areapath) ;; areapath is *toppath* for a given testsuite area
;;   (let* ((testsuite   (common:get-testsuite-name))
;; 	 (logfile     (conc areapath "/logs/server.log")) ;; -" curr-pid "-" target-host ".log"))
;; 	 (profile-mode (or (configf:lookup *configdat* "misc" "profilesw")
;; 			   ""))
;; 	 (cmdln (conc (common:get-megatest-exe)
;; 		      " -server - ";; (or target-host "-")
;; 		      (if (equal? (configf:lookup *configdat* "server" "daemonize") "yes")
;; 			  " -daemonize "
;; 			  "")
;; 		      ;; " -log " logfile
;; 		      " -m testsuite:" testsuite
;; 		      " " profile-mode
;; 		      )) ;; (conc " >> " logfile " 2>&1 &")))))
;; 	 (log-rotate  (make-thread common:rotate-logs  "server run, rotate logs thread")) ;; why are we rotating logs here? This is a sensitive location with a lot going on!?
;;          (load-limit  (configf:lookup-number *configdat* "jobtools" "max-server-start-load" default: 3.0)))
;;     ;; we want the remote server to start in *toppath* so push there
;;     (push-directory areapath)
;;     (debug:print 0 *default-log-port* "INFO: Trying to start server (" cmdln ") ...")
;;     (thread-start! log-rotate)
;;     
;;     ;; host.domain.tld match host?
;;     ;; (if (and target-host 
;;     ;; 	     ;; look at target host, is it host.domain.tld or ip address and does it 
;;     ;; 	     ;; match current ip or hostname
;;     ;; 	     (not (string-match (conc "("curr-host "|" curr-host"\\..*)") target-host))
;;     ;; 	     (not (equal? curr-ip target-host)))
;;     ;; 	(begin
;;     ;; 	  (debug:print-info 0 *default-log-port* "Starting server on " target-host ", logfile is " logfile)
;;     ;; 	  (setenv "TARGETHOST" target-host)))
;;     ;;   
;;     (setenv "TARGETHOST_LOGF" logfile)
;;     (thread-sleep! (/ (random 3000) 1000)) ;; add a random initial delay. It seems pretty common that many running tests request a server at the same time
;;     (debug:print 0 *default-log-port* "INFO: starting server at " (common:human-time))
;;     (system (conc "nbfake " cmdln))
;;     (unsetenv "TARGETHOST_LOGF")
;;     ;; (if (get-environment-variable "TARGETHOST")(unsetenv "TARGETHOST"))
;;     (thread-join! log-rotate)
;;     (pop-directory)))
;; 
;; ;; given a path to a server log return: host port startseconds server-id
;; ;; any changes to number of elements returned by this fuction will dirctly affect server:record->url,server:record->id,server:kill,server:get-num-alive which use match let 
;; ;; example of what it's looking for in the log file:
;; ;;     SERVER STARTED: 10.38.175.67:50216 AT 1616502350.0 server-id: 4907e90fc55c7a09694e3f658c639cf4 
;; 
;; (define (server:logf-get-start-info logf)
;;   (let ((server-rx    (regexp "^SERVER STARTED: (\\S+):(\\d+) AT ([\\d\\.]+) server-id: (\\S+) pid: (\\d+)")) ;; SERVER STARTED: host:port AT timesecs server id
;;         (dbprep-rx    (regexp "^SERVER: dbprep"))
;;         (dbprep-found 0)
;; 	(bad-dat      (list #f #f #f #f #f)))
;;     (handle-exceptions
;;      exn
;;      (begin
;;        ;; WARNING: this is potentially dangerous to blanket ignore the errors
;;        (if (file-exists? logf)
;; 	   (debug:print-info 2 *default-log-port* "Unable to get server info from "logf", exn=" exn))
;;        bad-dat) ;; no idea what went wrong, call it a bad server
;;      (with-input-from-file
;; 	 logf
;;        (lambda ()
;; 	 (let loop ((inl  (read-line))
;; 		    (lnum 0))
;; 	   (if (not (eof-object? inl))
;; 	       (let ((mlst (string-match server-rx inl))
;; 		     (dbprep (string-match dbprep-rx inl)))
;; 		 (if dbprep (set! dbprep-found 1))
;; 		 (if (not mlst)
;; 		     (if (< lnum 500) ;; give up if more than 500 lines of server log read
;; 			 (loop (read-line)(+ lnum 1))
;; 			 (begin 
;;                            (debug:print-info 0 *default-log-port* "Unable to get server info from first 500 lines of " logf )
;;                            bad-dat))
;; 		     (match mlst
;; 			    ((_ host port start server-id pid)
;; 			     (list host
;; 				   (string->number port)
;; 				   (string->number start)
;; 				   server-id
;; 				   (string->number pid)))
;; 			    (else
;; 			     (debug:print 0 *current-log-port* "ERROR: did not recognise SERVER line info "mlst)
;; 			     bad-dat))))
;; 	       (begin 
;; 		 (if dbprep-found
;; 		     (begin
;; 		       (debug:print-info 2 *default-log-port* "Server is in dbprep at " (common:human-time))
;; 		       (thread-sleep! 0.5)) ;; was 25 sec but that blocked things from starting?
;; 		     (debug:print-info 0 *default-log-port* "Unable to get server info from " logf " at " (seconds->time-string (current-seconds))))
;; 		 bad-dat))))))))
;; 
;; ;; ;; get a list of servers from the log files, with all relevant data
;; ;; ;; ( mod-time host port start-time pid )
;; ;; ;;
;; ;; (define (server:get-list areapath #!key (limit #f))
;; ;;   (let ((fname-rx    (regexp "^(|.*/)server-(\\d+)-(\\S+).log$"))
;; ;; 	(day-seconds (* 24 60 60)))
;; ;;     ;; if the directory exists continue to get the list
;; ;;     ;; otherwise attempt to create the logs dir and then
;; ;;     ;; continue
;; ;;     (if (if (directory-exists? (conc areapath "/logs"))
;; ;; 	    '()
;; ;; 	    (if (file-write-access? areapath)
;; ;; 		(begin
;; ;; 		  (condition-case
;; ;; 		   (create-directory (conc areapath "/logs") #t)
;; ;; 		   (exn (i/o file)(debug:print 0 *default-log-port* "ERROR: Cannot create directory at " (conc areapath "/logs")))
;; ;; 		   (exn ()(debug:print 0 *default-log-port* "ERROR: Unknown error attemtping to get server list. exn=" exn)))
;; ;; 		  (directory-exists? (conc areapath "/logs")))
;; ;; 		'()))
;; ;; 
;; ;;         ;; Get the list of server logs.
;; ;; 	(let* (
;; ;;                ;; For some reason, when I uncomment the below line, ext-tests sometimes starts 1000's of servers.
;; ;;                ;; (exiting-servers (system (conc "bash -c 'rm -f `grep -il exiting " areapath "/logs/server-*-*.log 2> /dev/null`'")))
;; ;;                (server-logs   (glob (conc areapath "/logs/server-*-*.log")))
;; ;; 	       (num-serv-logs (length server-logs)))
;; ;; 	  (if (or (null? server-logs) (= num-serv-logs 0))
;; ;;               (let ()
;; ;;                  (debug:print 2  *default-log-port* "There are no servers running at " (common:human-time))
;; ;; 	         '()
;; ;;               )
;; ;; 	      (let loop ((hed  (string-chomp (car server-logs)))
;; ;; 			 (tal  (cdr server-logs))
;; ;; 			 (res '()))
;; ;; 		(let* ((mod-time  (handle-exceptions
;; ;; 				   exn
;; ;; 				   (begin
;; ;; 				     (debug:print 0 *default-log-port* "server:get-list: failed to get modification time on " hed ", exn=" exn)
;; ;; 				     (current-seconds)) ;; 0
;; ;; 				   (file-modification-time hed))) ;; default to *very* old so log gets ignored if deleted
;; ;; 		       (down-time (- (current-seconds) mod-time))
;; ;; 		       (serv-dat  (if (or (< num-serv-logs 10)
;; ;; 				  	  (< down-time 900)) ;; day-seconds))
;; ;; 				      (server:logf-get-start-info hed)
;; ;; 				      '())) ;; don't waste time processing server files not touched in the 15 minutes if there are more than ten servers to look at
;; ;; 		       (serv-rec (cons mod-time serv-dat))
;; ;; 		       (fmatch   (string-match fname-rx hed))
;; ;; 		       (pid      (if fmatch (string->number (list-ref fmatch 2)) #f))
;; ;; 		       (new-res  (if (null? serv-dat)
;; ;; 				     res
;; ;; 				     (cons (append serv-rec (list pid)) res)))) ;; any changes to number of elements in new-res will dirctly affect server:record->url,server:record->id,server:kill,server:get-num-alive which uses match let 
;; ;; 		  (if (null? tal)
;; ;; 		      (if (and limit
;; ;; 			       (> (length new-res) limit))
;; ;; 			  new-res ;; (take new-res limit)  <= need intelligent sorting before this will work
;; ;; 			  new-res)
;; ;; 		      (loop (string-chomp (car tal)) (cdr tal) new-res)))))))))
;; 
;; #;(define (server:get-num-alive srvlst)
;;   (let ((num-alive 0))
;;     (for-each
;;      (lambda (server)
;;         (handle-exceptions
;;           exn
;;          (begin 
;;           (debug:print-info 0 *default-log-port*  "Unable to get server start-time and/or mod-time from " server ", exn=" exn))
;;        (match-let (((mod-time host port start-time server-id pid)
;; 		    server))
;; 	 (let* ((uptime  (- (current-seconds) mod-time))
;; 		(runtime (if start-time
;; 			     (- mod-time start-time)
;; 			     0)))
;; 	   (if (< uptime 5)(set! num-alive (+ num-alive 1)))))))
;;      srvlst)
;;     num-alive))
;; 
;; ;; ;; given a list of servers get a list of valid servers, i.e. at least
;; ;; ;; 10 seconds old, has started and is less than 1 hour old and is
;; ;; ;; active (i.e. mod-time < 10 seconds
;; ;; ;;
;; ;; ;; mod-time host port start-time pid
;; ;; ;;
;; ;; ;; sort by start-time descending. I.e. get the oldest first. Young servers will thus drop off
;; ;; ;; and servers should stick around for about two hours or so.
;; ;; ;;
;; ;; (define (server:get-best srvlst)
;; ;;   (let* ((nums (server:get-num-servers))
;; ;; 	 (now  (current-seconds))
;; ;; 	 (slst (sort
;; ;; 		(filter (lambda (rec)
;; ;; 			  (if (and (list? rec)
;; ;; 				   (> (length rec) 2))
;; ;; 			      (let ((start-time (list-ref rec 3))
;; ;; 				    (mod-time   (list-ref rec 0)))
;; ;; 				;; (print "start-time: " start-time " mod-time: " mod-time)
;; ;; 				(and start-time mod-time
;; ;; 				     (> (- now start-time) 0)    ;; been running at least 0 seconds
;; ;; 				     (< (- now mod-time)   16)   ;; still alive - file touched in last 16 seconds
;; ;; 				     (or (not (configf:lookup *configdat* "server" "runtime")) ;; skip if not set
;; ;; 					 (< (- now start-time)       
;; ;; 					    (+ (- (string->number (configf:lookup *configdat* "server" "runtime"))
;; ;; 					       180)
;; ;; 					    (random 360)))) ;; under one hour running time +/- 180
;; ;; 				     ))
;; ;; 			      #f))
;; ;; 			srvlst)
;; ;; 		(lambda (a b)
;; ;; 		  (< (list-ref a 3)
;; ;; 		     (list-ref b 3))))))
;; ;;     (if (> (length slst) nums)
;; ;; 	(take slst nums)
;; ;; 	slst)))
;; 
;; ;; ;; switch from server:get-list to server:get-servers-info
;; ;; ;;
;; ;; (define (server:get-first-best areapath)
;; ;;   (let ((srvrs (server:get-best (server:get-list areapath))))
;; ;;     (if (and srvrs
;; ;; 	     (not (null? srvrs)))
;; ;; 	(car srvrs)
;; ;; 	#f)))
;; ;; 
;; ;; (define (server:get-rand-best areapath)
;; ;;   (let ((srvrs (server:get-best (server:get-list areapath))))
;; ;;     (if (and (list? srvrs)
;; ;; 	     (not (null? srvrs)))
;; ;; 	(let* ((len (length srvrs))
;; ;; 	       (idx (random len)))
;; ;; 	  (list-ref srvrs idx))
;; ;; 	#f)))
;; 
;; (define (server:record->id servr)
;;   (handle-exceptions
;;    exn
;;    (begin 
;;      (debug:print-info 0 *default-log-port*  "Unable to get server id from " servr ", exn=" exn)     
;;    #f)
;;   (match-let (((host port start-time server-id pid)
;; 	       servr))
;;     (if server-id
;; 	server-id
;; 	#f))))
;; 
;; (define (server:record->url servr)
;;   (handle-exceptions
;;    exn
;;    (begin 
;;      (debug:print-info 0 *default-log-port*  "Unable to get server url from " servr ", exn=" exn)     
;;    #f)
;;   (match-let (((host port start-time server-id pid)
;; 	       servr))
;;     (if (and host port)
;; 	(conc host ":" port)
;; 	#f))))
;; 
;; 
;; ;; if server-start-last exists, and wasn't old enough, wait <idle time> + 1, then call this function recursively until it is old enough.
;; ;; if it is old enough, overwrite it and wait 0.25 seconds.
;; ;; if it then has the wrong server key, wait <idle time> + 1 and call this function recursively.
;; ;;
;; #;(define (server:wait-for-server-start-last-flag areapath)
;;   (let* ((start-flag (conc areapath "/logs/server-start-last"))
;; 	 ;;; THIS INTERACTS WITH [server] timeout. Suggest using 0.1 or above for timeout (6 seconds)
;; 	 (idletime    (configf:lookup-number *configdat* "server" "idletime" default: 4))
;; 	 (server-key (conc (get-host-name) "-" (current-process-id))))
;;     (if (file-exists? start-flag)
;; 	(let* ((fmodtime (file-modification-time start-flag))
;; 	       (delta    (- (current-seconds) fmodtime))
;; 	       (old-enough   (> delta idletime))
;;                (new-server-key ""))
;;           ;; write start-flag file, wait 0.25s, then if previously the start-flag file was older than <idletime> seconds, and the new file still has the same server key as you just wrote, return #t.
;; 	  ;; the intention is to make sure nfs can read the file we just wrote, and make sure it was written by us, and not another process.
;;            (if (and old-enough
;; 		    (begin
;;                       (debug:print-info 2 *default-log-port* "Writing " start-flag)
;; 		      (with-output-to-file start-flag (lambda () (print server-key)))
;; 		      (thread-sleep! 0.25)
;; 		      (set! new-server-key (with-input-from-file start-flag (lambda () (read-line))))
;; 		      (equal? server-key new-server-key)))
;; 	       #t
;;                ;; If either of the above conditions is not true, print a "Gating server start" message, wait <idle-time> + 1, then call this function recursively. 
;; 	       (begin
;; 		 (debug:print-info 0 *default-log-port* "Gating server start, last start: "
;; 				   (seconds->time-string fmodtime) ", time since last start: " delta ", required idletime: " idletime ", gating reason:" (if old-enough "another job started a server" "too soon to start another server"))
;; 		 
;; 		 (thread-sleep! ( + 1 idletime))
;; 		 (server:wait-for-server-start-last-flag areapath)))))))
;; 
;; ;; oldest server alive determines host then choose random of youngest
;; ;; five servers on that host
;; ;;
;; (define (server:get-servers-info areapath)
;;   ;; (assert *toppath* "FATAL: server:get-servers-info called before *toppath* has been set.")
;;   (let* ((servinfodir (server:get-servinfo-dir areapath))) ;; (conc *toppath*"/.servinfo")))
;;     (if (not (file-exists? servinfodir))
;; 	(create-directory servinfodir))
;;     (let* ((allfiles    (glob (conc servinfodir"/*")))
;; 	   (res         (make-hash-table)))
;;       (for-each
;;        (lambda (f)
;; 	 (let* ((hostport  (pathname-strip-directory f))
;; 		(serverdat (server:logf-get-start-info f)))
;; 	   (match serverdat
;; 	     ((host port start server-id pid)
;; 	      (if (and host port start server-id pid)
;; 		  (hash-table-set! res hostport serverdat)
;; 		  (debug:print-info 2 *default-log-port* "bad server info for "f": "serverdat)))
;; 	     (else
;; 	      (debug:print-info 2 *default-log-port* "bad server info for "f": "serverdat)))))
;;        allfiles)
;;       res)))
;; 
;; ;; check the .servinfo directory, are there other servers running on this
;; ;; or another host?
;; ;;
;; ;; returns #t => ok to start another server
;; ;;         #f => not ok to start another server
;; ;;
;; (define (server:minimal-check areapath)
;;   (server:clean-up-old areapath)
;;   (let* ((srvdir      (server:get-servinfo-dir areapath)) ;; (conc areapath"/.servinfo"))
;; 	 (servrs      (glob (conc srvdir"/*")))
;; 	 (thishostip  (server:get-best-guess-address (get-host-name)))
;; 	 (thisservrs  (glob (conc srvdir"/"thishostip":*")))
;; 	 (homehostinf (server:choose-server areapath 'homehost))
;; 	 (havehome    (car homehostinf))
;; 	 (wearehome   (cdr homehostinf)))
;;     (debug:print-info 0 *default-log-port* thishostip", have homehost: "havehome", we are homehost: "wearehome
;; 		      ", numservers: "(length thisservrs))
;;     (cond
;;      ((not havehome) #t) ;; no homehost yet, go for it
;;      ((and havehome wearehome (< (length thisservrs) 20)) #t) ;; we are home and less than 20 servers, ok to start another
;;      ((and havehome (not wearehome)) #f)     ;; we are not the home host
;;      ((and havehome wearehome (>= (length thisservrs) 20)) #f) ;; have enough running
;;      (else
;;       (debug:print 0 *default-log-port* "WARNING: Unrecognised scenario, servrs="servrs", thishostip="thishostip", thisservrs="thisservrs)
;;       #t))))
;; 	 
;; 
;; (define server-last-start 0)
;; 
;; 
;; ;; oldest server alive determines host then choose random of youngest
;; ;; five servers on that host
;; ;;
;; ;; mode:
;; ;;   best - get best server (random of newest five)
;; ;;   home - get home host based on oldest server
;; ;;   info - print info
;; (define (server:choose-server areapath #!optional (mode 'best))
;;   ;; age is current-starttime
;;   ;; find oldest alive
;;   ;;   1. sort by age ascending and ping until good
;;   ;; find alive rand from youngest
;;   ;;   1. sort by age descending
;;   ;;   2. take five
;;   ;;   3. check alive, discard if not and repeat
;;   ;; first we clean up old server files
;;   (server:clean-up-old areapath)
;;   (let* ((since-last (- (current-seconds) server-last-start))
;;         (server-start-delay 10))     
;;     (if ( < (- (current-seconds) server-last-start) 10 )
;;       (begin
;;         (debug:print 2 *default-log-port* "server:choose-server: seconds since last server start: " (- (current-seconds) server-last-start))
;;         (debug:print 2 *default-log-port* "server:choose-server: last server start less than " server-start-delay " seconds ago. Sleeping " server-start-delay " seconds")
;;         (thread-sleep! server-start-delay)

;;       )
;;       (debug:print 2 *default-log-port* "server:choose-server: seconds since last server start: " (- (current-seconds) server-last-start))


;;     )
;;   )
;;   (let* ((serversdat  (server:get-servers-info areapath))
;; 	 (servkeys    (hash-table-keys serversdat))
;; 	 (by-time-asc (if (not (null? servkeys)) ;; NOTE: Oldest is last
;; 			  (sort servkeys ;; list of "host:port"
;; 				(lambda (a b)
;; 				  (>= (list-ref (hash-table-ref serversdat a) 2)
;; 				      (list-ref (hash-table-ref serversdat b) 2))))
;; 			  '())))
;;     (debug:print 2 *default-log-port* "server:choose-server: serversdat: " serversdat)
;;     (debug:print 2 *default-log-port* "server:choose-server: servkeys: " servkeys)
;;     (if (not (null? by-time-asc))
;; 	(let* ((oldest     (last by-time-asc))
;; 	       (oldest-dat (hash-table-ref serversdat oldest))
;; 	       (host       (list-ref oldest-dat 0))
;; 	       (all-valid  (filter (lambda (x)
;; 				     (equal? host (list-ref (hash-table-ref serversdat x) 0)))
;; 				   by-time-asc))
;; 	       (best-ten  (lambda ()
;; 			     (if (> (length all-valid) 11)
;; 				 (take (drop-right all-valid 1) 10) ;; remove the oldest from consideration so it can age out
;; 				 (if (> (length all-valid) 8)
;; 				     (drop-right all-valid 1)
;; 				     all-valid))))
;; 	       (names->dats (lambda (names)
;; 			      (map (lambda (x)
;; 				     (hash-table-ref serversdat x))
;; 				   names)))
;; 	       (am-home?    (lambda ()
;; 			      (let* ((currhost (get-host-name))
;; 				     (bestadrs (server:get-best-guess-address currhost)))
;; 				(or (equal? host currhost)
;; 				    (equal? host bestadrs))))))
;; 	  (case mode
;; 	    ((info)
;; 	     (print "oldest: "oldest-dat", selected host: "host", all-valid: "all-valid)
;; 	     (print "youngest: "(hash-table-ref serversdat (car all-valid))))
;; 	    ((home)     host)
;; 	    ((homehost) (cons host (am-home?))) ;; shut up old code
;; 	    ((home?)    (am-home?))
;; 	    ((best-ten)(names->dats (best-ten)))
;; 	    ((all-valid)(names->dats all-valid))
;; 	    ((best)     (let* ((best-ten (best-ten))
;; 			       (len       (length best-ten)))
;; 			  (hash-table-ref serversdat (list-ref best-ten (random len)))))
;; 	    ((count)(length all-valid))
;; 	    (else
;; 	     (debug:print 0 *default-log-port* "ERROR: invalid command "mode)
;; 	     #f)))
;; 	(begin
;; 	  (server:run areapath)
;;           (set! server-last-start (current-seconds))
;; 	  ;; (thread-sleep! 3)
;; 	  (case mode
;; 	    ((homehost) (cons #f #f))
;; 	    (else	#f))))))
;; 
;; (define (server:get-servinfo-dir areapath)
;;   (let* ((spath (conc areapath"/.servinfo")))
;;     (if (not (file-exists? spath))
;; 	(create-directory spath #t))
;;     spath))
;; 
;; (define (server:clean-up-old areapath)
;;   ;; any server file that has not been touched in ten minutes is effectively dead
;;   (let* ((sfiles (glob (conc (server:get-servinfo-dir areapath)"/*"))))
;;     (for-each
;;      (lambda (sfile)
;;        (let* ((modtime (handle-exceptions
;; 			   exn
;; 			 (begin
;; 			   (debug:print 0 *default-log-port* "WARNING: failed to get modification file for "sfile)
;; 			   (current-seconds))
;; 			 (file-modification-time sfile))))
;; 	 (if (and (number? modtime)
;; 		  (> (- (current-seconds) modtime)
;; 		     600))
;; 	     (begin
;; 	       (debug:print 0 *default-log-port* "WARNING: found old server info file "sfile", removing it.")
;; 	       (handle-exceptions
;; 		   exn
;; 		 (debug:print 0 *default-log-port* "WARNING: failed to delete old server info file "sfile)
;; 		 (delete-file sfile))))))
;;      sfiles)))
;; 
;; ;; would like to eventually get rid of this
;; ;;
;; (define (common:on-homehost?)
;;   (server:choose-server *toppath* 'home?))
;; 
;; ;; kind start up of server, wait before allowing another server for a given
;; ;; area to be launched
;; ;;
;; (define (server:kind-run areapath)
;;   ;; look for $MT_RUN_AREA_HOME/logs/server-start-last
;;   ;; and wait for it to be at least <server idletime> seconds old
;;   ;; (server:wait-for-server-start-last-flag areapath)
;;   (let loop ()
;;     (if (> (alist-ref 'adj-proc-load (common:get-normalized-cpu-load #f)) 2)
;; 	(begin
;; 	  (if (common:low-noise-print 30 "our-host-load")
;; 	      (debug:print 0 *default-log-port* "WARNING: system load is high, waiting to start server."))
;; 	  (loop))))
;;   (if (< (server:choose-server areapath 'count) 20)
;;       (server:run areapath))
;;   #;(if (not (server:check-if-running areapath)) ;; why try if there is already a server running?
;;       (let* ((lock-file    (conc areapath "/logs/server-start.lock")))
;; 	(let* ((start-flag (conc areapath "/logs/server-start-last")))
;; 	  (common:simple-file-lock-and-wait lock-file expire-time: 25)
;; 	  (debug:print-info  2 *default-log-port* "server:kind-run: touching " start-flag)
;; 	  (system (conc "touch " start-flag)) ;; lazy but safe
;; 	  (server:run areapath)
;; 	  (thread-sleep! 20) ;; don't release the lock for at least a few seconds. And allow time for the server startup to get to "SERVER STARTED".
;; 	  (common:simple-file-release-lock lock-file)))
;;       (debug:print-info 0 *default-log-port* "Found server already running. NOT trying to start another.")))
;; 
;; ;; this one seems to be the general entry point
;; ;;
;; (define (server:start-and-wait areapath #!key (timeout 60))
;;   (let ((give-up-time (+ (current-seconds) timeout)))
;;     (let loop ((server-info (server:check-if-running areapath))
;; 	       (try-num    0))
;;       (if (or server-info
;; 	      (> (current-seconds) give-up-time)) ;; server-url will be #f if no server available.
;; 	  (server:record->url server-info)
;; 	  (let* ( (servers (server:choose-server areapath 'all-valid))
;;                 (num-ok (if servers (length (server:choose-server areapath 'all-valid)) 0)))
;; 	    (if (and (> try-num 0)  ;; first time through simply wait a little while then try again
;; 		     (< num-ok 1))  ;; if there are no decent candidates for servers then try starting a new one
;; 		(server:run areapath))
;; 	    (thread-sleep! 5)
;; 	    (loop (server:check-if-running areapath)
;; 		  (+ try-num 1)))))))
;; 
;; (define (server:get-num-servers #!key (numservers 2))
;;   (let ((ns (string->number
;; 	     (or (configf:lookup *configdat* "server" "numservers") "notanumber"))))
;;     (or ns numservers)))
;; 
;; ;; no longer care if multiple servers are started by accident. older servers will drop off in time.
;; ;;
;; (define (server:check-if-running areapath) ;;  #!key (numservers "2"))
;;   (let* ((ns            (server:get-num-servers)) ;; get the setting the for maximum number of servers allowed
;; 	 (servers       (server:choose-server areapath 'best-ten))) ;; (server:get-best (server:get-list areapath))))
;;     (if (or (and servers
;; 		 (null? servers))
;; 	    (not servers))
;; 	    ;; (and (list? servers)
;; 	    ;;	 (< (length servers) (+ 1 (random ns))))) ;; somewhere between 1 and numservers
;;         #f
;;         (let loop ((hed (car servers))
;;                    (tal (cdr servers)))
;;           (let ((res (server:check-server hed)))
;;             (if res
;;                 hed
;;                 (if (null? tal)
;;                     #f
;;                     (loop (car tal)(cdr tal)))))))))
;; 
;; ;; ping the given server
;; ;;
;; (define (server:check-server server-record)
;;   (let* ((server-url (server:record->url server-record))
;;          (server-id  (server:record->id server-record)) 
;;          (res        (server:ping server-url server-id)))
;;     (if res
;;         server-url
;; 	#f)))
;; 
;; (define (server:kill servr)
;;   (handle-exceptions
;;     exn
;;     (begin 
;;       (debug:print-info 0 *default-log-port*  "Unable to get host and/or port from " servr ", exn=" exn)     
;;     #f)
;;   (match-let (((mod-time hostname port start-time server-id pid)
;; 	       servr))
;;     (tasks:kill-server hostname pid))))
;; 
;; ;; 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.
;; ;;
;; (define (server:ping host:port server-id #!key (do-exit #f))
;;   (let* ((host-port (cond
;; 		     ((string? host:port)
;; 		      (let ((slst (string-split   host:port ":")))
;; 			(if (eq? (length slst) 2)
;; 			    (list (car slst)(string->number (cadr slst)))
;; 			    #f)))
;; 		     (else
;; 		      #f))))
;;     (cond
;;      ((and (list? host-port)
;; 	   (eq? (length host-port) 2))
;;       (let* ((myrunremote (make-remote))
;; 	     (iface       (car host-port))
;; 	     (port        (cadr host-port))
;; 	     (server-dat  (client:connect iface port server-id myrunremote))
;; 	     (login-res   (rmt:login-no-auto-client-setup myrunremote)))
;; 	(if (and (list? login-res)
;; 		 (car login-res))
;; 	    (begin
;; 	      ;; (print "LOGIN_OK")
;; 	      (if do-exit (exit 0))
;; 	      #t)
;; 	    (begin
;; 	      ;; (print "LOGIN_FAILED")
;; 	      (if do-exit (exit 1))
;; 	      #f))))
;;      (else 
;;       (if host:port
;; 	  (debug:print 0 *default-log-port*  "ERROR: bad host:port "host:port))
;;       (if do-exit
;; 	  (exit 1)
;; 	  #f)))))
;; 
;; ;; 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)))
;; 
;; ;; timeout is hms string: 1h 5m 3s, default is 1 minute
;; ;; This is currently broken. Just use the number of hours with no unit.
;; ;; Default is 60 seconds.
;; ;;
;; (define (server:expiration-timeout)
;;   (let ((tmo (configf:lookup *configdat* "server" "timeout")))
;;     (if (and (string? tmo)
;; 	     (common:hms-string->seconds tmo)) ;; BUG: hms-string->seconds is broken, if given "10" returns 0. Also, it doesn't belong in this logic unless the string->number is changed below
;;         (* 3600 (string->number tmo))
;; 	600)))
;; 
;; (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)))) ".")))
;; 
;; ;; (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))))
;; 
;; ;; moving this here as it needs access to db and cannot be in common.
;; ;;
;; 

;; (define (server:get-bruteforce-syncer dbstruct #!key (fork-to-background #f) (persist-until-sync #f))
;;   (debug:print "WARNING: bruteforce-syncer is called but has been disabled!")
;;   (lambda ()
;;     (debug:print "WARNING: bruteforce-syncer is called but has been disabled!"))
;;   #;(let* ((sqlite-exe   (or (get-environment-variable "MT_SQLITE3_EXE"))) ;; defined in cfg.sh
;;          (sync-log     (or (args:get-arg "-sync-log") (conc *toppath* "/logs/sync-" (current-process-id) "-" (get-host-name) ".log")))
;; 	 (tmp-area     (common:get-db-tmp-area))
;; 	 (tmp-db       (conc tmp-area "/megatest.db"))
;; 	 (staging-file (conc *toppath* "/.megatest.db"))
;; 	 (mtdbfile     (conc *toppath* "/megatest.db"))
;; 	 (lockfile     (common:get-sync-lock-filepath))
;;          (sync-cmd-core     (conc sqlite-exe" " tmp-db " .dump | "sqlite-exe" " staging-file "&>"sync-log))
;;          (sync-cmd     (if fork-to-background 
;;                            (conc "/usr/bin/env NBFAKE_LOG="*toppath*"/logs/last-server-sync-"(current-process-id)".log nbfake \""sync-cmd-core" && /bin/mv -f " staging-file " " mtdbfile" \"")
;;                            sync-cmd-core))
;;          (default-min-intersync-delay 2)
;; 	 (min-intersync-delay (configf:lookup-number *configdat* "server" "minimum-intersync-delay" default: default-min-intersync-delay))
;;          (default-duty-cycle 0.1)
;;          (duty-cycle   (configf:lookup-number *configdat* "server" "sync-duty-cycle" default: default-duty-cycle))
;;          (last-sync-seconds 10) ;; we will adjust this to a measurement and delay last-sync-seconds * (1 - duty-cycle)
;;          (calculate-off-time (lambda (work-duration duty-cycle)
;;                                   (* (/ (- 1 duty-cycle) duty-cycle) last-sync-seconds)))
;;          (off-time min-intersync-delay) ;; adjusted in closure below.
;;          (do-a-sync
;;           (lambda ()
;;             (BB> "Start do-a-sync with fork-to-background="fork-to-background" persist-until-sync="persist-until-sync)
;;             (let* ((finalres
;;                     (let retry-loop ((num-tries 0))
;;                          (if (common:simple-file-lock lockfile)
;; 	                     (begin
;;                                (cond
;;                                 ((not (or fork-to-background persist-until-sync))
;;                                  (debug:print 0 *default-log-port* "INFO: syncer thread sleeping for max of (server.minimum-intersync-delay="min-intersync-delay
;;                                               " , off-time="off-time" seconds ]")
;;                                  (thread-sleep! (max off-time min-intersync-delay)))
;;                                 (else
;;                                  (debug:print 0 *default-log-port* "INFO: syncer thread NOT sleeping ; maybe time-to-exit...")))
;; 
;;                                (if (not (configf:lookup *configdat* "server" "disable-db-snapshot"))
;;                                    (common:snapshot-file mtdbfile subdir: ".db-snapshot"))
;; 		               (delete-file* staging-file)
;; 		               (let* ((start-time (current-milliseconds))
;;                                       (res (system sync-cmd))
;;                                       (dbbackupfile (conc mtdbfile ".backup"))
;;                                       (res2 
;;                                        (cond
;;                                         ((eq? 0 res )
;;                                          (handle-exceptions








;;                                             exn
;;                                             #f
;;                                          (if (file-exists? dbbackupfile)
;; 		                           (delete-file* dbbackupfile)
;;                                          )
;;                                          (if (eq? 0 (file-size sync-log))
;;                                              (delete-file* sync-log))
;; 		                         (system (conc "/bin/mv " staging-file " " mtdbfile))
;;                                          
;;                                          (set! last-sync-seconds (/ (- (current-milliseconds) start-time) 1000))
;;                                          (set! off-time (calculate-off-time
;;                                                          last-sync-seconds
;;                                                          (cond
;;                                                           ((and (number? duty-cycle) (> duty-cycle 0) (< duty-cycle 1))
;;                                                            duty-cycle)
;;                                                           (else
;;                                                            (debug:print 0 *default-log-port* "WARNING: ["(common:human-time)"] server.sync-duty-cycle is invalid.  Should be a number between 0 and 1, but "duty-cycle" was specified.  Using default value: "default-duty-cycle)
;;                                                            default-duty-cycle))))
;;                                          
;;                                          (debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] pid="(current-process-id)" SYNC took "last-sync-seconds" sec")
;;                                          (debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] pid="(current-process-id)" SYNC took "last-sync-seconds" sec ; with duty-cycle of "duty-cycle" off time is now "off-time)
;;                                          'sync-completed))
;;                                         (else
;;                                          (system (conc "/bin/cp "sync-log" "sync-log".fail"))
;;                                          (debug:print 0 *default-log-port* "ERROR: ["(common:human-time)"] Sync failed. See log at "sync-log".fail")
;;                                          (if (file-exists? (conc mtdbfile ".backup"))
;;                                              (system (conc "/bin/cp "mtdbfile ".backup " mtdbfile)))
;;                                          #f))))
;;                                  (common:simple-file-release-lock lockfile)
;;                                  (BB> "released lockfile: " lockfile)
;;                                  (when (common:file-exists? lockfile)
;;                                    (BB> "DID NOT ACTUALLY RELEASE LOCKFILE"))
;;                                  res2) ;; end let
;;                                );; end begin
;;                              ;; else
;;                              (cond
;;                               (persist-until-sync
;;                                (thread-sleep! 1)
;;                                (debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] pid="(current-process-id)" other SYNC in progress; we're in a fork-to-background so we need to succeed.  Let's wait a jiffy and and try again. num-tries="num-tries" (waiting for lockfile="lockfile" to disappear)")
;;                                (retry-loop (add1 num-tries)))
;;                               (else
;;                                (thread-sleep! (max off-time (+ last-sync-seconds min-intersync-delay)))
;;                                (debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] pid="(current-process-id)" other SYNC in progress; not syncing.")
;;                                'parallel-sync-in-progress))
;;                              ) ;; end if got lockfile

;;                          )
;;                     ))
;;               (BB> "End do-a-sync with fork-to-background="fork-to-background" persist-until-sync="persist-until-sync" and result="finalres)
;;               finalres)
;;             ) ;; end lambda
;;           ))
;;     do-a-sync))
;; 
;; 

;; Copyright 2006-2023, 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 servermod))
(declare (uses artifacts))

(use md5 message-digest posix typed-records extras)

(module servermod
*

(import scheme
	chicken

	extras
	md5
	message-digest
	ports
	posix
	srfi-18

	typed-records
	data-structures

	artifacts
	)

(defstruct srv
  (areapath #f)
  (host     #f)
  (pid      #f)
  (type     #f)
  (dir      #f)
  (incoming #f)
  (dbstruct #f)
  (handler  #f)
  (obj-to-str #f)
  (str-to-obj #f)
  )

;; nearly every process in Megatest (if write access) starts a server so it
;; can receive messages to exit on request
;; servers have a type, mtserve, dboard, runner, execute? TOO COMPLICATED.

;; one server per run db file would be ideal.

;; mtrah/.servers/<host>.<pid>/incoming/*.artifact
;;                            |        `attic
;;                            |
;;                            `outgoing/<clienthost>.<clientpid>/*.artifact
;;                            |                                 `attic
;;                            `<tcp|http|nmsg|?>.host:port

;; on exit processes clean up. only mtserv or dboard clean up abandoned records?

;; IDEA: All requests could go into one directory instead of server specific directory - need locking
;;       don't get multiple processing of arfs

;; server:setup          - setup the directory
;; server:launch         - start a new mtserve process, possibly
;;                         using a launcher
;; server:run            - run the long running thread that monitors
;;                         the .server area
;; server:exit           - shutdown the server and exit
;; server:handle-request - take incoming request, process it, send response
;;                         back via best or fastest available transport

;; call this with handler that takes dbstruct cmd and params after doing server:setup
;; and before starting server:run
;;
(define (server:set-handler srvdat handler)
  (srv-handler-set! srvdat handler))

;; set up the server area and return a server struct
;; NOTE: This will need to be gated by write-access
;;
(define (server:setup areapath)
  (let* ((srvdat (make-srv
		  areapath: areapath
		  host:     (get-host-name) ;; likely need to replace with ip address
		  pid:      (current-process-id)
		  ))
	 (srvdir (conc areapath"/.server/"(get-host.pid srvdat))))
    (srv-dir-set! srvdat srvdir)
    (srv-incoming-set! srvdat (conc srvdir"/incoming"))
    (create-directory srvdir #t)
    (for-each (lambda (d)
		(create-directory (conc srvdir"/"d)))
	      '("incoming" "responses"))
    srvdat))

(define *server-keep-running* #f)

;; to cleanly shut the server down set *server-keep-running* to #f
;;
(define (server:run srvdat)
  ;; create server arf
  ;; put arf in srvdat-dir
  ;; forever
  ;;    scan incoming dir
  ;;    foreach arf
  ;;       bundle into with-transaction, no-transaction
  ;;    foreach bundle
  ;;       process the request
  ;;       create results arf and write it to clients dir
  ;;       remove in-arf from incoming
  (let* ((areapath  (srv-areapath srvdat))
	 (srvinfod  (server:get-servinfo-dir areapath))
	 (myarf     (srv->alist srvdat))
	 (myuuid    (write-alist->artifact srvinfod myarf ptype: 'S))
	 (arf-fname (get-artifact-fname srvinfod myuuid))
	 (dbstruct  (srv-dbstruct srvdat)))
    (set! *server-keep-running* #t)
    (let loop ()
      (let* ((start (current-milliseconds))
	     (res   (server:process-incoming srvdat))
	     (delta (- (current-milliseconds) start)))
	(thread-sleep! (if (> delta 500)
			   0.1
			   0.9))
	(if (or (> res 0) ;; res is the number of requests that were found and processed
		*server-keep-running*)
	    (loop))))))

;; read arfs from incoming, process them and put result arfs in proper dirs
;; return number requests found and processed
;;
(define	(server:process-incoming srvdat)
  (let* ((srvdir (srv-dir srvdat))
	 (indir  (srv-incoming srvdat))
	 (arfs   (glob (conc indir"/*.artifacts")))
	 (handler (srv-handler srvdat))
	 (obj->string (srv-obj-to-str srvdat))
	 (dbstruct (srv-dbstruct srvdat)))
    (let loop ((rem arfs))
      (if (not (null? arfs))
	  (let* ((arf  (car rem))
		 (dat  (read-artifact->alist arf))
		 (ruuid (alist-ref 'Z dat))
		 (host (alist-ref 'h dat))
		 (pid  (alist-ref 'i dat))
		 (dest (conc srvdir"/"host"."pid"/responses"))
		 (cmd  (alist-ref 'c dat))
		 (params (alist-ref 'p dat))
		 (res  (handler dbstruct cmd params))
		 (narf `((r . ,(obj->string res))
			 (P . ,ruuid))))
	    (delete-file arf) ;; add ability to save in bundles in archive area
	    (write-alist->artifact dest narf ptype: 'Q)
	    (loop (cdr rem)))))
    (length arfs)))
	  
;; start a server process (NOT start server in this process)
;;
;; maybe check load before calling this?
(define (server:launch areapath)
  (let* ((logd (conc areapath"/logs"))
	 (logf (conc logd"/from-"(get-host.pid #f)".log")))
    (if (not (file-exists? logd))(create-directory logd #t))
    (setenv "NBFAKE_LOG" logf)
    (system (conc "nbfake mtserve -start-dir "areapath))))
    
;;======================================================================
;; OLD SERVER STUFF BELOW HERE
;;======================================================================

;; ;; servers start by setting up fs transport
;; ;; and put a flag file for that ASAP.
;; ;; they then set up tcp and put a flag file for
;; ;; that 
;; ;;
;; (define *client-server-id* #f)
;; 
;; ;; oldest server alive determines host then choose random of youngest
;; ;; five servers on that host
;; ;;
;; ;; mode:
;; ;;   best - get best server (random of newest five)
;; ;;   home - get home host based on oldest server
;; ;;   info - print info
;; (define (server:choose-server areapath #!optional (mode 'best))
;;   ;; age is current-starttime
;;   ;; find oldest alive
;;   ;;   1. sort by age ascending and ping until good
;;   ;; find alive rand from youngest
;;   ;;   1. sort by age descending
;;   ;;   2. take five
;;   ;;   3. check alive, discard if not and repeat
;;   ;; first we clean up old server files
;;   (server:clean-up-old areapath)
;; ;;  (let* ((since-last (- (current-seconds) server-last-start))
;; ;;         (server-start-delay 10))     
;; ;;    (if ( < (- (current-seconds) server-last-start) 10 )
;; ;;	(begin
;; ;;          (debug:print 2 *default-log-port* "server:choose-server: seconds since last server start: " (- (current-seconds) server-last-start))
;; ;;          (debug:print 2 *default-log-port* "server:choose-server: last server start less than " server-start-delay " seconds ago. Sleeping " server-start-delay " seconds")
;; ;;          (thread-sleep! server-start-delay)
;; ;;	  )
;; ;;	(debug:print 2 *default-log-port* "server:choose-server: seconds since last server start: " (- (current-seconds) server-last-start))
;; ;;	)
;;   (let* ((serversdat  (server:get-servers-info areapath))
;; 	 (servkeys    (hash-table-keys serversdat))
;; 	 (by-time-asc (if (not (null? servkeys)) ;; NOTE: Oldest is last
;; 			  (sort servkeys ;; list of "host:port"
;; 				(lambda (a b)
;; 				  (>= (list-ref (hash-table-ref serversdat a) 2)
;; 				      (list-ref (hash-table-ref serversdat b) 2))))
;; 			  '())))
;;     (debug:print 2 *default-log-port* "server:choose-server: serversdat: " serversdat)
;;     (debug:print 2 *default-log-port* "server:choose-server: servkeys: " servkeys)
;;     (if (not (null? by-time-asc))
;; 	(let* ((oldest     (last by-time-asc))
;; 	       (oldest-dat (hash-table-ref serversdat oldest))
;; 	       (host       (list-ref oldest-dat 0))
;; 	       (all-valid  (filter (lambda (x)
;; 				     (equal? host (list-ref (hash-table-ref serversdat x) 0)))
;; 				   by-time-asc))
;; 	       (best-ten  (lambda ()
;; 			    (if (> (length all-valid) 11)
;; 				(take (drop-right all-valid 1) 10) ;; remove the oldest from consideration so it can age out
;; 				(if (> (length all-valid) 8)
;; 				    (drop-right all-valid 1)
;; 				    all-valid))))
;; 	       (names->dats (lambda (names)
;; 			      (map (lambda (x)
;; 				     (hash-table-ref serversdat x))
;; 				   names)))
;; 	       (am-home?    (lambda ()
;; 			      (let* ((currhost (get-host-name))
;; 				     (bestadrs (server:get-best-guess-address currhost)))
;; 				(or (equal? host currhost)
;; 				    (equal? host bestadrs))))))
;; 	  (case mode
;; 	    ((info)
;; 	     (print "oldest: "oldest-dat", selected host: "host", all-valid: "all-valid)
;; 	     (print "youngest: "(hash-table-ref serversdat (car all-valid))))
;; 	    ((home)     host)
;; 	    ((homehost) (cons host (am-home?))) ;; shut up old code
;; 	    ((home?)    (am-home?))
;; 	    ((best-ten)(names->dats (best-ten)))
;; 	    ((all-valid)(names->dats all-valid))
;; 	    ((best)     (let* ((best-ten (best-ten))
;; 			       (len       (length best-ten)))
;; 			  (hash-table-ref serversdat (list-ref best-ten (random len)))))
;; 	    ((count)(length all-valid))
;; 	    (else
;; 	     (debug:print 0 *default-log-port* "ERROR: invalid command "mode)
;; 	     #f)))
;; 	(begin
;; 	  (server:run areapath)
;;           (set! server-last-start (current-seconds))
;; 	  ;; (thread-sleep! 3)
;; 	  (case mode
;; 	    ((homehost) (cons #f #f))
;; 	    (else	#f))))))
 
;;======================================================================
;; S E R V E R   U T I L I T I E S 
;;======================================================================

(define (server:get-servinfo-dir areapath)
  (let* ((spath (conc areapath"/.servinfo")))
    (if (not (file-exists? spath))
	(create-directory spath #t))
    spath))

;; ;; Generate a unique signature for this server
;; (define (mk-signature)
;;   (message-digest-string (md5-primitive) 
;; 			 (with-output-to-string
;; 			   (lambda ()
;; 			     (write (list (current-directory)
;;                                           (current-process-id)
;; 					  (argv)))))))
;; 
;; (define (server:clean-up-old areapath)
;;   ;; any server file that has not been touched in ten minutes is effectively dead
;;   (let* ((sfiles (glob (conc (server:get-servinfo-dir areapath)"/*"))))
;;     (for-each
;;      (lambda (sfile)
;;        (let* ((modtime (handle-exceptions
;; 			   exn
;; 			 (begin
;; 			   (debug:print 0 *default-log-port* "WARNING: failed to get modification file for "sfile)
;; 			   (current-seconds))
;; 			 (file-modification-time sfile))))
;; 	 (if (and (number? modtime)
;; 		  (> (- (current-seconds) modtime)
;; 		     600))
;; 	     (begin
;; 	       (debug:print 0 *default-log-port* "WARNING: found old server info file "sfile", removing it.")
;; 	       (handle-exceptions
;; 		   exn
;; 		 (debug:print 0 *default-log-port* "WARNING: failed to delete old server info file "sfile)
;; 		 (delete-file sfile))))))
;;      sfiles)))
;; 
;; (define (get-client-server-id)
;;   (if *client-server-id* *client-server-id*
;;       (let ((sig (mk-signature))) ;; clients re-use the server:mk-signature logic
;;         (set! *client-server-id* sig)
;;         *client-server-id*)))

;; if srvdat is #f calculate host.pid
(define (get-host.pid srvdat)
  (if srvdat
      (conc (srv-host srvdat)"."(srv-pid srvdat))
      (conc (get-host-name)"."(current-process-id))))

;; ;; ;; When using zmq this would send the message back (two step process)
;; ;; ;; with spiffy or rpc this simply returns the return data to be returned
;; ;; ;; 
;; ;; (define (server:reply return-addr query-sig success/fail result)
;; ;;   (debug:print-info 11 *default-log-port* "server:reply return-addr=" return-addr ", result=" result)
;; ;;   ;; (send-message pubsock target send-more: #t)
;; ;;   ;; (send-message pubsock 
;; ;;   (case (server:get-transport)
;; ;;     ((rpc)  (db:obj->string (vector success/fail query-sig result)))
;; ;;     ((http) (db:obj->string (vector success/fail query-sig result)))
;; ;;     ((fs)   result)
;; ;;     (else 
;; ;;      (debug:print-error 0 *default-log-port* "unrecognised transport type: " *transport-type*)
;; ;;      result)))
;; ;; 
;; ;; ;; Given an area path,  start a server process    ### NOTE ### > file 2>&1 
;; ;; ;; if the target-host is set 
;; ;; ;; try running on that host
;; ;; ;;   incidental: rotate logs in logs/ dir.
;; ;; ;;
;; ;; (define  (server:run areapath) ;; areapath is *toppath* for a given testsuite area
;; ;;   (let* ((testsuite   (common:get-testsuite-name))
;; ;; 	 (logfile     (conc areapath "/logs/server.log")) ;; -" curr-pid "-" target-host ".log"))
;; ;; 	 (profile-mode (or (configf:lookup *configdat* "misc" "profilesw")
;; ;; 			   ""))
;; ;; 	 (cmdln (conc (common:get-megatest-exe)
;; ;; 		      " -server - ";; (or target-host "-")
;; ;; 		      (if (equal? (configf:lookup *configdat* "server" "daemonize") "yes")
;; ;; 			  " -daemonize "
;; ;; 			  "")
;; ;; 		      ;; " -log " logfile
;; ;; 		      " -m testsuite:" testsuite
;; ;; 		      " " profile-mode
;; ;; 		      )) ;; (conc " >> " logfile " 2>&1 &")))))
;; ;; 	 (log-rotate  (make-thread common:rotate-logs  "server run, rotate logs thread")) ;; why are we rotating logs here? This is a sensitive location with a lot going on!?
;; ;;          (load-limit  (configf:lookup-number *configdat* "jobtools" "max-server-start-load" default: 3.0)))
;; ;;     ;; we want the remote server to start in *toppath* so push there
;; ;;     (push-directory areapath)
;; ;;     (debug:print 0 *default-log-port* "INFO: Trying to start server (" cmdln ") ...")
;; ;;     (thread-start! log-rotate)
;; ;;     
;; ;;     ;; host.domain.tld match host?
;; ;;     ;; (if (and target-host 
;; ;;     ;; 	     ;; look at target host, is it host.domain.tld or ip address and does it 
;; ;;     ;; 	     ;; match current ip or hostname
;; ;;     ;; 	     (not (string-match (conc "("curr-host "|" curr-host"\\..*)") target-host))
;; ;;     ;; 	     (not (equal? curr-ip target-host)))
;; ;;     ;; 	(begin
;; ;;     ;; 	  (debug:print-info 0 *default-log-port* "Starting server on " target-host ", logfile is " logfile)
;; ;;     ;; 	  (setenv "TARGETHOST" target-host)))
;; ;;     ;;   
;; ;;     (setenv "TARGETHOST_LOGF" logfile)
;; ;;     (thread-sleep! (/ (random 3000) 1000)) ;; add a random initial delay. It seems pretty common that many running tests request a server at the same time
;; ;;     (debug:print 0 *default-log-port* "INFO: starting server at " (common:human-time))
;; ;;     (system (conc "nbfake " cmdln))
;; ;;     (unsetenv "TARGETHOST_LOGF")
;; ;;     ;; (if (get-environment-variable "TARGETHOST")(unsetenv "TARGETHOST"))
;; ;;     (thread-join! log-rotate)
;; ;;     (pop-directory)))
;; ;; 
;; ;; ;; given a path to a server log return: host port startseconds server-id
;; ;; ;; any changes to number of elements returned by this fuction will dirctly affect server:record->url,server:record->id,server:kill,server:get-num-alive which use match let 
;; ;; ;; example of what it's looking for in the log file:
;; ;; ;;     SERVER STARTED: 10.38.175.67:50216 AT 1616502350.0 server-id: 4907e90fc55c7a09694e3f658c639cf4 
;; ;; 
;; ;; (define (server:logf-get-start-info logf)
;; ;;   (let ((server-rx    (regexp "^SERVER STARTED: (\\S+):(\\d+) AT ([\\d\\.]+) server-id: (\\S+) pid: (\\d+)")) ;; SERVER STARTED: host:port AT timesecs server id
;; ;;         (dbprep-rx    (regexp "^SERVER: dbprep"))
;; ;;         (dbprep-found 0)
;; ;; 	(bad-dat      (list #f #f #f #f #f)))
;; ;;     (handle-exceptions
;; ;;      exn
;; ;;      (begin
;; ;;        ;; WARNING: this is potentially dangerous to blanket ignore the errors
;; ;;        (if (file-exists? logf)
;; ;; 	   (debug:print-info 2 *default-log-port* "Unable to get server info from "logf", exn=" exn))
;; ;;        bad-dat) ;; no idea what went wrong, call it a bad server
;; ;;      (with-input-from-file
;; ;; 	 logf
;; ;;        (lambda ()
;; ;; 	 (let loop ((inl  (read-line))
;; ;; 		    (lnum 0))
;; ;; 	   (if (not (eof-object? inl))
;; ;; 	       (let ((mlst (string-match server-rx inl))
;; ;; 		     (dbprep (string-match dbprep-rx inl)))
;; ;; 		 (if dbprep (set! dbprep-found 1))
;; ;; 		 (if (not mlst)
;; ;; 		     (if (< lnum 500) ;; give up if more than 500 lines of server log read
;; ;; 			 (loop (read-line)(+ lnum 1))
;; ;; 			 (begin 
;; ;;                            (debug:print-info 0 *default-log-port* "Unable to get server info from first 500 lines of " logf )
;; ;;                            bad-dat))
;; ;; 		     (match mlst
;; ;; 			    ((_ host port start server-id pid)
;; ;; 			     (list host
;; ;; 				   (string->number port)
;; ;; 				   (string->number start)
;; ;; 				   server-id
;; ;; 				   (string->number pid)))
;; ;; 			    (else
;; ;; 			     (debug:print 0 *current-log-port* "ERROR: did not recognise SERVER line info "mlst)
;; ;; 			     bad-dat))))
;; ;; 	       (begin 
;; ;; 		 (if dbprep-found
;; ;; 		     (begin
;; ;; 		       (debug:print-info 2 *default-log-port* "Server is in dbprep at " (common:human-time))
;; ;; 		       (thread-sleep! 0.5)) ;; was 25 sec but that blocked things from starting?
;; ;; 		     (debug:print-info 0 *default-log-port* "Unable to get server info from " logf " at " (seconds->time-string (current-seconds))))
;; ;; 		 bad-dat))))))))
;; ;; 
;; ;; ;; ;; get a list of servers from the log files, with all relevant data
;; ;; ;; ;; ( mod-time host port start-time pid )
;; ;; ;; ;;
;; ;; ;; (define (server:get-list areapath #!key (limit #f))
;; ;; ;;   (let ((fname-rx    (regexp "^(|.*/)server-(\\d+)-(\\S+).log$"))
;; ;; ;; 	(day-seconds (* 24 60 60)))
;; ;; ;;     ;; if the directory exists continue to get the list
;; ;; ;;     ;; otherwise attempt to create the logs dir and then
;; ;; ;;     ;; continue
;; ;; ;;     (if (if (directory-exists? (conc areapath "/logs"))
;; ;; ;; 	    '()
;; ;; ;; 	    (if (file-write-access? areapath)
;; ;; ;; 		(begin
;; ;; ;; 		  (condition-case
;; ;; ;; 		   (create-directory (conc areapath "/logs") #t)
;; ;; ;; 		   (exn (i/o file)(debug:print 0 *default-log-port* "ERROR: Cannot create directory at " (conc areapath "/logs")))
;; ;; ;; 		   (exn ()(debug:print 0 *default-log-port* "ERROR: Unknown error attemtping to get server list. exn=" exn)))
;; ;; ;; 		  (directory-exists? (conc areapath "/logs")))
;; ;; ;; 		'()))
;; ;; ;; 
;; ;; ;;         ;; Get the list of server logs.
;; ;; ;; 	(let* (
;; ;; ;;                ;; For some reason, when I uncomment the below line, ext-tests sometimes starts 1000's of servers.
;; ;; ;;                ;; (exiting-servers (system (conc "bash -c 'rm -f `grep -il exiting " areapath "/logs/server-*-*.log 2> /dev/null`'")))
;; ;; ;;                (server-logs   (glob (conc areapath "/logs/server-*-*.log")))
;; ;; ;; 	       (num-serv-logs (length server-logs)))
;; ;; ;; 	  (if (or (null? server-logs) (= num-serv-logs 0))
;; ;; ;;               (let ()
;; ;; ;;                  (debug:print 2  *default-log-port* "There are no servers running at " (common:human-time))
;; ;; ;; 	         '()
;; ;; ;;               )
;; ;; ;; 	      (let loop ((hed  (string-chomp (car server-logs)))
;; ;; ;; 			 (tal  (cdr server-logs))
;; ;; ;; 			 (res '()))
;; ;; ;; 		(let* ((mod-time  (handle-exceptions
;; ;; ;; 				   exn
;; ;; ;; 				   (begin
;; ;; ;; 				     (debug:print 0 *default-log-port* "server:get-list: failed to get modification time on " hed ", exn=" exn)
;; ;; ;; 				     (current-seconds)) ;; 0
;; ;; ;; 				   (file-modification-time hed))) ;; default to *very* old so log gets ignored if deleted
;; ;; ;; 		       (down-time (- (current-seconds) mod-time))
;; ;; ;; 		       (serv-dat  (if (or (< num-serv-logs 10)
;; ;; ;; 				  	  (< down-time 900)) ;; day-seconds))
;; ;; ;; 				      (server:logf-get-start-info hed)
;; ;; ;; 				      '())) ;; don't waste time processing server files not touched in the 15 minutes if there are more than ten servers to look at
;; ;; ;; 		       (serv-rec (cons mod-time serv-dat))
;; ;; ;; 		       (fmatch   (string-match fname-rx hed))
;; ;; ;; 		       (pid      (if fmatch (string->number (list-ref fmatch 2)) #f))
;; ;; ;; 		       (new-res  (if (null? serv-dat)
;; ;; ;; 				     res
;; ;; ;; 				     (cons (append serv-rec (list pid)) res)))) ;; any changes to number of elements in new-res will dirctly affect server:record->url,server:record->id,server:kill,server:get-num-alive which uses match let 
;; ;; ;; 		  (if (null? tal)
;; ;; ;; 		      (if (and limit
;; ;; ;; 			       (> (length new-res) limit))
;; ;; ;; 			  new-res ;; (take new-res limit)  <= need intelligent sorting before this will work
;; ;; ;; 			  new-res)
;; ;; ;; 		      (loop (string-chomp (car tal)) (cdr tal) new-res)))))))))
;; ;; 
;; ;; #;(define (server:get-num-alive srvlst)
;; ;;   (let ((num-alive 0))
;; ;;     (for-each
;; ;;      (lambda (server)
;; ;;         (handle-exceptions
;; ;;           exn
;; ;;          (begin 
;; ;;           (debug:print-info 0 *default-log-port*  "Unable to get server start-time and/or mod-time from " server ", exn=" exn))
;; ;;        (match-let (((mod-time host port start-time server-id pid)
;; ;; 		    server))
;; ;; 	 (let* ((uptime  (- (current-seconds) mod-time))
;; ;; 		(runtime (if start-time
;; ;; 			     (- mod-time start-time)
;; ;; 			     0)))
;; ;; 	   (if (< uptime 5)(set! num-alive (+ num-alive 1)))))))
;; ;;      srvlst)
;; ;;     num-alive))
;; ;; 
;; ;; ;; ;; given a list of servers get a list of valid servers, i.e. at least
;; ;; ;; ;; 10 seconds old, has started and is less than 1 hour old and is
;; ;; ;; ;; active (i.e. mod-time < 10 seconds
;; ;; ;; ;;
;; ;; ;; ;; mod-time host port start-time pid
;; ;; ;; ;;
;; ;; ;; ;; sort by start-time descending. I.e. get the oldest first. Young servers will thus drop off
;; ;; ;; ;; and servers should stick around for about two hours or so.
;; ;; ;; ;;
;; ;; ;; (define (server:get-best srvlst)
;; ;; ;;   (let* ((nums (server:get-num-servers))
;; ;; ;; 	 (now  (current-seconds))
;; ;; ;; 	 (slst (sort
;; ;; ;; 		(filter (lambda (rec)
;; ;; ;; 			  (if (and (list? rec)
;; ;; ;; 				   (> (length rec) 2))
;; ;; ;; 			      (let ((start-time (list-ref rec 3))
;; ;; ;; 				    (mod-time   (list-ref rec 0)))
;; ;; ;; 				;; (print "start-time: " start-time " mod-time: " mod-time)
;; ;; ;; 				(and start-time mod-time
;; ;; ;; 				     (> (- now start-time) 0)    ;; been running at least 0 seconds
;; ;; ;; 				     (< (- now mod-time)   16)   ;; still alive - file touched in last 16 seconds
;; ;; ;; 				     (or (not (configf:lookup *configdat* "server" "runtime")) ;; skip if not set
;; ;; ;; 					 (< (- now start-time)       
;; ;; ;; 					    (+ (- (string->number (configf:lookup *configdat* "server" "runtime"))
;; ;; ;; 					       180)
;; ;; ;; 					    (random 360)))) ;; under one hour running time +/- 180
;; ;; ;; 				     ))
;; ;; ;; 			      #f))
;; ;; ;; 			srvlst)
;; ;; ;; 		(lambda (a b)
;; ;; ;; 		  (< (list-ref a 3)
;; ;; ;; 		     (list-ref b 3))))))
;; ;; ;;     (if (> (length slst) nums)
;; ;; ;; 	(take slst nums)
;; ;; ;; 	slst)))
;; ;; 
;; ;; ;; ;; switch from server:get-list to server:get-servers-info
;; ;; ;; ;;
;; ;; ;; (define (server:get-first-best areapath)
;; ;; ;;   (let ((srvrs (server:get-best (server:get-list areapath))))
;; ;; ;;     (if (and srvrs
;; ;; ;; 	     (not (null? srvrs)))
;; ;; ;; 	(car srvrs)
;; ;; ;; 	#f)))
;; ;; ;; 
;; ;; ;; (define (server:get-rand-best areapath)
;; ;; ;;   (let ((srvrs (server:get-best (server:get-list areapath))))
;; ;; ;;     (if (and (list? srvrs)
;; ;; ;; 	     (not (null? srvrs)))
;; ;; ;; 	(let* ((len (length srvrs))
;; ;; ;; 	       (idx (random len)))
;; ;; ;; 	  (list-ref srvrs idx))
;; ;; ;; 	#f)))
;; ;; 
;; ;; (define (server:record->id servr)
;; ;;   (handle-exceptions
;; ;;    exn
;; ;;    (begin 
;; ;;      (debug:print-info 0 *default-log-port*  "Unable to get server id from " servr ", exn=" exn)     
;; ;;    #f)
;; ;;   (match-let (((host port start-time server-id pid)
;; ;; 	       servr))
;; ;;     (if server-id
;; ;; 	server-id
;; ;; 	#f))))
;; ;; 
;; ;; (define (server:record->url servr)
;; ;;   (handle-exceptions
;; ;;    exn
;; ;;    (begin 
;; ;;      (debug:print-info 0 *default-log-port*  "Unable to get server url from " servr ", exn=" exn)     
;; ;;    #f)
;; ;;   (match-let (((host port start-time server-id pid)
;; ;; 	       servr))
;; ;;     (if (and host port)
;; ;; 	(conc host ":" port)
;; ;; 	#f))))
;; ;; 
;; ;; 
;; ;; ;; if server-start-last exists, and wasn't old enough, wait <idle time> + 1, then call this function recursively until it is old enough.
;; ;; ;; if it is old enough, overwrite it and wait 0.25 seconds.
;; ;; ;; if it then has the wrong server key, wait <idle time> + 1 and call this function recursively.
;; ;; ;;
;; ;; #;(define (server:wait-for-server-start-last-flag areapath)
;; ;;   (let* ((start-flag (conc areapath "/logs/server-start-last"))
;; ;; 	 ;;; THIS INTERACTS WITH [server] timeout. Suggest using 0.1 or above for timeout (6 seconds)
;; ;; 	 (idletime    (configf:lookup-number *configdat* "server" "idletime" default: 4))
;; ;; 	 (server-key (conc (get-host-name) "-" (current-process-id))))
;; ;;     (if (file-exists? start-flag)
;; ;; 	(let* ((fmodtime (file-modification-time start-flag))
;; ;; 	       (delta    (- (current-seconds) fmodtime))
;; ;; 	       (old-enough   (> delta idletime))
;; ;;                (new-server-key ""))
;; ;;           ;; write start-flag file, wait 0.25s, then if previously the start-flag file was older than <idletime> seconds, and the new file still has the same server key as you just wrote, return #t.
;; ;; 	  ;; the intention is to make sure nfs can read the file we just wrote, and make sure it was written by us, and not another process.
;; ;;            (if (and old-enough
;; ;; 		    (begin
;; ;;                       (debug:print-info 2 *default-log-port* "Writing " start-flag)
;; ;; 		      (with-output-to-file start-flag (lambda () (print server-key)))
;; ;; 		      (thread-sleep! 0.25)
;; ;; 		      (set! new-server-key (with-input-from-file start-flag (lambda () (read-line))))
;; ;; 		      (equal? server-key new-server-key)))
;; ;; 	       #t
;; ;;                ;; If either of the above conditions is not true, print a "Gating server start" message, wait <idle-time> + 1, then call this function recursively. 
;; ;; 	       (begin
;; ;; 		 (debug:print-info 0 *default-log-port* "Gating server start, last start: "
;; ;; 				   (seconds->time-string fmodtime) ", time since last start: " delta ", required idletime: " idletime ", gating reason:" (if old-enough "another job started a server" "too soon to start another server"))
;; ;; 		 
;; ;; 		 (thread-sleep! ( + 1 idletime))
;; ;; 		 (server:wait-for-server-start-last-flag areapath)))))))
;; ;; 
;; ;; ;; oldest server alive determines host then choose random of youngest
;; ;; ;; five servers on that host
;; ;; ;;
;; ;; (define (server:get-servers-info areapath)
;; ;;   ;; (assert *toppath* "FATAL: server:get-servers-info called before *toppath* has been set.")
;; ;;   (let* ((servinfodir (server:get-servinfo-dir areapath))) ;; (conc *toppath*"/.servinfo")))
;; ;;     (if (not (file-exists? servinfodir))
;; ;; 	(create-directory servinfodir))
;; ;;     (let* ((allfiles    (glob (conc servinfodir"/*")))
;; ;; 	   (res         (make-hash-table)))
;; ;;       (for-each
;; ;;        (lambda (f)
;; ;; 	 (let* ((hostport  (pathname-strip-directory f))
;; ;; 		(serverdat (server:logf-get-start-info f)))
;; ;; 	   (match serverdat
;; ;; 	     ((host port start server-id pid)
;; ;; 	      (if (and host port start server-id pid)
;; ;; 		  (hash-table-set! res hostport serverdat)
;; ;; 		  (debug:print-info 2 *default-log-port* "bad server info for "f": "serverdat)))
;; ;; 	     (else
;; ;; 	      (debug:print-info 2 *default-log-port* "bad server info for "f": "serverdat)))))
;; ;;        allfiles)
;; ;;       res)))
;; ;; 
;; ;; ;; check the .servinfo directory, are there other servers running on this
;; ;; ;; or another host?
;; ;; ;;
;; ;; ;; returns #t => ok to start another server
;; ;; ;;         #f => not ok to start another server
;; ;; ;;
;; ;; (define (server:minimal-check areapath)
;; ;;   (server:clean-up-old areapath)
;; ;;   (let* ((srvdir      (server:get-servinfo-dir areapath)) ;; (conc areapath"/.servinfo"))
;; ;; 	 (servrs      (glob (conc srvdir"/*")))
;; ;; 	 (thishostip  (server:get-best-guess-address (get-host-name)))
;; ;; 	 (thisservrs  (glob (conc srvdir"/"thishostip":*")))
;; ;; 	 (homehostinf (server:choose-server areapath 'homehost))
;; ;; 	 (havehome    (car homehostinf))
;; ;; 	 (wearehome   (cdr homehostinf)))
;; ;;     (debug:print-info 0 *default-log-port* thishostip", have homehost: "havehome", we are homehost: "wearehome
;; ;; 		      ", numservers: "(length thisservrs))
;; ;;     (cond
;; ;;      ((not havehome) #t) ;; no homehost yet, go for it
;; ;;      ((and havehome wearehome (< (length thisservrs) 20)) #t) ;; we are home and less than 20 servers, ok to start another
;; ;;      ((and havehome (not wearehome)) #f)     ;; we are not the home host
;; ;;      ((and havehome wearehome (>= (length thisservrs) 20)) #f) ;; have enough running
;; ;;      (else
;; ;;       (debug:print 0 *default-log-port* "WARNING: Unrecognised scenario, servrs="servrs", thishostip="thishostip", thisservrs="thisservrs)
;; ;;       #t))))
;; ;; 	 
;; ;; 
;; ;; (define server-last-start 0)
;; ;; 
;; ;; 
;; ;; ;; oldest server alive determines host then choose random of youngest
;; ;; ;; five servers on that host
;; ;; ;;
;; ;; ;; mode:
;; ;; ;;   best - get best server (random of newest five)
;; ;; ;;   home - get home host based on oldest server
;; ;; ;;   info - print info
;; ;; (define (server:choose-server areapath #!optional (mode 'best))
;; ;;   ;; age is current-starttime
;; ;;   ;; find oldest alive
;; ;;   ;;   1. sort by age ascending and ping until good
;; ;;   ;; find alive rand from youngest
;; ;;   ;;   1. sort by age descending
;; ;;   ;;   2. take five
;; ;;   ;;   3. check alive, discard if not and repeat
;; ;;   ;; first we clean up old server files
;; ;;   (server:clean-up-old areapath)
;; ;;   (let* ((since-last (- (current-seconds) server-last-start))
;; ;;         (server-start-delay 10))     
;; ;;     (if ( < (- (current-seconds) server-last-start) 10 )
;; ;;       (begin
;; ;;         (debug:print 2 *default-log-port* "server:choose-server: seconds since last server start: " (- (current-seconds) server-last-start))
;; ;;         (debug:print 2 *default-log-port* "server:choose-server: last server start less than " server-start-delay " seconds ago. Sleeping " server-start-delay " seconds")
;; ;;         (thread-sleep! server-start-delay)
;; ;;       )
;; ;;       (debug:print 2 *default-log-port* "server:choose-server: seconds since last server start: " (- (current-seconds) server-last-start))
;; ;;     )
;; ;;   )
;; ;;   (let* ((serversdat  (server:get-servers-info areapath))
;; ;; 	 (servkeys    (hash-table-keys serversdat))
;; ;; 	 (by-time-asc (if (not (null? servkeys)) ;; NOTE: Oldest is last
;; ;; 			  (sort servkeys ;; list of "host:port"
;; ;; 				(lambda (a b)
;; ;; 				  (>= (list-ref (hash-table-ref serversdat a) 2)
;; ;; 				      (list-ref (hash-table-ref serversdat b) 2))))
;; ;; 			  '())))
;; ;;     (debug:print 2 *default-log-port* "server:choose-server: serversdat: " serversdat)
;; ;;     (debug:print 2 *default-log-port* "server:choose-server: servkeys: " servkeys)
;; ;;     (if (not (null? by-time-asc))
;; ;; 	(let* ((oldest     (last by-time-asc))
;; ;; 	       (oldest-dat (hash-table-ref serversdat oldest))
;; ;; 	       (host       (list-ref oldest-dat 0))
;; ;; 	       (all-valid  (filter (lambda (x)
;; ;; 				     (equal? host (list-ref (hash-table-ref serversdat x) 0)))
;; ;; 				   by-time-asc))
;; ;; 	       (best-ten  (lambda ()
;; ;; 			     (if (> (length all-valid) 11)
;; ;; 				 (take (drop-right all-valid 1) 10) ;; remove the oldest from consideration so it can age out
;; ;; 				 (if (> (length all-valid) 8)
;; ;; 				     (drop-right all-valid 1)
;; ;; 				     all-valid))))
;; ;; 	       (names->dats (lambda (names)
;; ;; 			      (map (lambda (x)
;; ;; 				     (hash-table-ref serversdat x))
;; ;; 				   names)))
;; ;; 	       (am-home?    (lambda ()
;; ;; 			      (let* ((currhost (get-host-name))
;; ;; 				     (bestadrs (server:get-best-guess-address currhost)))
;; ;; 				(or (equal? host currhost)
;; ;; 				    (equal? host bestadrs))))))
;; ;; 	  (case mode
;; ;; 	    ((info)
;; ;; 	     (print "oldest: "oldest-dat", selected host: "host", all-valid: "all-valid)
;; ;; 	     (print "youngest: "(hash-table-ref serversdat (car all-valid))))
;; ;; 	    ((home)     host)
;; ;; 	    ((homehost) (cons host (am-home?))) ;; shut up old code
;; ;; 	    ((home?)    (am-home?))
;; ;; 	    ((best-ten)(names->dats (best-ten)))
;; ;; 	    ((all-valid)(names->dats all-valid))
;; ;; 	    ((best)     (let* ((best-ten (best-ten))
;; ;; 			       (len       (length best-ten)))
;; ;; 			  (hash-table-ref serversdat (list-ref best-ten (random len)))))
;; ;; 	    ((count)(length all-valid))
;; ;; 	    (else
;; ;; 	     (debug:print 0 *default-log-port* "ERROR: invalid command "mode)
;; ;; 	     #f)))
;; ;; 	(begin
;; ;; 	  (server:run areapath)
;; ;;           (set! server-last-start (current-seconds))
;; ;; 	  ;; (thread-sleep! 3)
;; ;; 	  (case mode
;; ;; 	    ((homehost) (cons #f #f))
;; ;; 	    (else	#f))))))
;; ;; 
;; ;; (define (server:get-servinfo-dir areapath)
;; ;;   (let* ((spath (conc areapath"/.servinfo")))
;; ;;     (if (not (file-exists? spath))
;; ;; 	(create-directory spath #t))
;; ;;     spath))
;; ;; 
;; ;; (define (server:clean-up-old areapath)
;; ;;   ;; any server file that has not been touched in ten minutes is effectively dead
;; ;;   (let* ((sfiles (glob (conc (server:get-servinfo-dir areapath)"/*"))))
;; ;;     (for-each
;; ;;      (lambda (sfile)
;; ;;        (let* ((modtime (handle-exceptions
;; ;; 			   exn
;; ;; 			 (begin
;; ;; 			   (debug:print 0 *default-log-port* "WARNING: failed to get modification file for "sfile)
;; ;; 			   (current-seconds))
;; ;; 			 (file-modification-time sfile))))
;; ;; 	 (if (and (number? modtime)
;; ;; 		  (> (- (current-seconds) modtime)
;; ;; 		     600))
;; ;; 	     (begin
;; ;; 	       (debug:print 0 *default-log-port* "WARNING: found old server info file "sfile", removing it.")
;; ;; 	       (handle-exceptions
;; ;; 		   exn
;; ;; 		 (debug:print 0 *default-log-port* "WARNING: failed to delete old server info file "sfile)
;; ;; 		 (delete-file sfile))))))
;; ;;      sfiles)))
;; ;; 
;; ;; ;; would like to eventually get rid of this
;; ;; ;;
;; ;; (define (common:on-homehost?)
;; ;;   (server:choose-server *toppath* 'home?))
;; ;; 
;; ;; ;; kind start up of server, wait before allowing another server for a given
;; ;; ;; area to be launched
;; ;; ;;
;; ;; (define (server:kind-run areapath)
;; ;;   ;; look for $MT_RUN_AREA_HOME/logs/server-start-last
;; ;;   ;; and wait for it to be at least <server idletime> seconds old
;; ;;   ;; (server:wait-for-server-start-last-flag areapath)
;; ;;   (let loop ()
;; ;;     (if (> (alist-ref 'adj-proc-load (common:get-normalized-cpu-load #f)) 2)
;; ;; 	(begin
;; ;; 	  (if (common:low-noise-print 30 "our-host-load")
;; ;; 	      (debug:print 0 *default-log-port* "WARNING: system load is high, waiting to start server."))
;; ;; 	  (loop))))
;; ;;   (if (< (server:choose-server areapath 'count) 20)
;; ;;       (server:run areapath))
;; ;;   #;(if (not (server:check-if-running areapath)) ;; why try if there is already a server running?
;; ;;       (let* ((lock-file    (conc areapath "/logs/server-start.lock")))
;; ;; 	(let* ((start-flag (conc areapath "/logs/server-start-last")))
;; ;; 	  (common:simple-file-lock-and-wait lock-file expire-time: 25)
;; ;; 	  (debug:print-info  2 *default-log-port* "server:kind-run: touching " start-flag)
;; ;; 	  (system (conc "touch " start-flag)) ;; lazy but safe
;; ;; 	  (server:run areapath)
;; ;; 	  (thread-sleep! 20) ;; don't release the lock for at least a few seconds. And allow time for the server startup to get to "SERVER STARTED".
;; ;; 	  (common:simple-file-release-lock lock-file)))
;; ;;       (debug:print-info 0 *default-log-port* "Found server already running. NOT trying to start another.")))
;; ;; 
;; ;; ;; this one seems to be the general entry point
;; ;; ;;
;; ;; (define (server:start-and-wait areapath #!key (timeout 60))
;; ;;   (let ((give-up-time (+ (current-seconds) timeout)))
;; ;;     (let loop ((server-info (server:check-if-running areapath))
;; ;; 	       (try-num    0))
;; ;;       (if (or server-info
;; ;; 	      (> (current-seconds) give-up-time)) ;; server-url will be #f if no server available.
;; ;; 	  (server:record->url server-info)
;; ;; 	  (let* ( (servers (server:choose-server areapath 'all-valid))
;; ;;                 (num-ok (if servers (length (server:choose-server areapath 'all-valid)) 0)))
;; ;; 	    (if (and (> try-num 0)  ;; first time through simply wait a little while then try again
;; ;; 		     (< num-ok 1))  ;; if there are no decent candidates for servers then try starting a new one
;; ;; 		(server:run areapath))
;; ;; 	    (thread-sleep! 5)
;; ;; 	    (loop (server:check-if-running areapath)
;; ;; 		  (+ try-num 1)))))))
;; ;; 
;; ;; (define (server:get-num-servers #!key (numservers 2))
;; ;;   (let ((ns (string->number
;; ;; 	     (or (configf:lookup *configdat* "server" "numservers") "notanumber"))))
;; ;;     (or ns numservers)))
;; ;; 
;; ;; ;; no longer care if multiple servers are started by accident. older servers will drop off in time.
;; ;; ;;
;; ;; (define (server:check-if-running areapath) ;;  #!key (numservers "2"))
;; ;;   (let* ((ns            (server:get-num-servers)) ;; get the setting the for maximum number of servers allowed
;; ;; 	 (servers       (server:choose-server areapath 'best-ten))) ;; (server:get-best (server:get-list areapath))))
;; ;;     (if (or (and servers
;; ;; 		 (null? servers))
;; ;; 	    (not servers))
;; ;; 	    ;; (and (list? servers)
;; ;; 	    ;;	 (< (length servers) (+ 1 (random ns))))) ;; somewhere between 1 and numservers
;; ;;         #f
;; ;;         (let loop ((hed (car servers))
;; ;;                    (tal (cdr servers)))
;; ;;           (let ((res (server:check-server hed)))
;; ;;             (if res
;; ;;                 hed
;; ;;                 (if (null? tal)
;; ;;                     #f
;; ;;                     (loop (car tal)(cdr tal)))))))))
;; ;; 
;; ;; ;; ping the given server
;; ;; ;;
;; ;; (define (server:check-server server-record)
;; ;;   (let* ((server-url (server:record->url server-record))
;; ;;          (server-id  (server:record->id server-record)) 
;; ;;          (res        (server:ping server-url server-id)))
;; ;;     (if res
;; ;;         server-url
;; ;; 	#f)))
;; ;; 
;; ;; (define (server:kill servr)
;; ;;   (handle-exceptions
;; ;;     exn
;; ;;     (begin 
;; ;;       (debug:print-info 0 *default-log-port*  "Unable to get host and/or port from " servr ", exn=" exn)     
;; ;;     #f)
;; ;;   (match-let (((mod-time hostname port start-time server-id pid)
;; ;; 	       servr))
;; ;;     (tasks:kill-server hostname pid))))
;; ;; 
;; ;; ;; 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.
;; ;; ;;
;; ;; (define (server:ping host:port server-id #!key (do-exit #f))
;; ;;   (let* ((host-port (cond
;; ;; 		     ((string? host:port)
;; ;; 		      (let ((slst (string-split   host:port ":")))
;; ;; 			(if (eq? (length slst) 2)
;; ;; 			    (list (car slst)(string->number (cadr slst)))
;; ;; 			    #f)))
;; ;; 		     (else
;; ;; 		      #f))))
;; ;;     (cond
;; ;;      ((and (list? host-port)
;; ;; 	   (eq? (length host-port) 2))
;; ;;       (let* ((myrunremote (make-remote))
;; ;; 	     (iface       (car host-port))
;; ;; 	     (port        (cadr host-port))
;; ;; 	     (server-dat  (client:connect iface port server-id myrunremote))
;; ;; 	     (login-res   (rmt:login-no-auto-client-setup myrunremote)))
;; ;; 	(if (and (list? login-res)
;; ;; 		 (car login-res))
;; ;; 	    (begin
;; ;; 	      ;; (print "LOGIN_OK")
;; ;; 	      (if do-exit (exit 0))
;; ;; 	      #t)
;; ;; 	    (begin
;; ;; 	      ;; (print "LOGIN_FAILED")
;; ;; 	      (if do-exit (exit 1))
;; ;; 	      #f))))
;; ;;      (else 
;; ;;       (if host:port
;; ;; 	  (debug:print 0 *default-log-port*  "ERROR: bad host:port "host:port))
;; ;;       (if do-exit
;; ;; 	  (exit 1)
;; ;; 	  #f)))))
;; ;; 
;; ;; ;; 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)))
;; ;; 
;; ;; ;; timeout is hms string: 1h 5m 3s, default is 1 minute
;; ;; ;; This is currently broken. Just use the number of hours with no unit.
;; ;; ;; Default is 60 seconds.
;; ;; ;;
;; ;; (define (server:expiration-timeout)
;; ;;   (let ((tmo (configf:lookup *configdat* "server" "timeout")))
;; ;;     (if (and (string? tmo)
;; ;; 	     (common:hms-string->seconds tmo)) ;; BUG: hms-string->seconds is broken, if given "10" returns 0. Also, it doesn't belong in this logic unless the string->number is changed below
;; ;;         (* 3600 (string->number tmo))
;; ;; 	600)))
;; ;; 
;; ;; (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)))) ".")))
;; ;; 
;; ;; ;; (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))))
;; ;; 
;; ;; ;; moving this here as it needs access to db and cannot be in common.
;; ;; ;;
;; ;; 
;; ;; (define (server:get-bruteforce-syncer dbstruct #!key (fork-to-background #f) (persist-until-sync #f))
;; ;;   (debug:print "WARNING: bruteforce-syncer is called but has been disabled!")
;; ;;   (lambda ()
;; ;;     (debug:print "WARNING: bruteforce-syncer is called but has been disabled!"))
;; ;;   #;(let* ((sqlite-exe   (or (get-environment-variable "MT_SQLITE3_EXE"))) ;; defined in cfg.sh
;; ;;          (sync-log     (or (args:get-arg "-sync-log") (conc *toppath* "/logs/sync-" (current-process-id) "-" (get-host-name) ".log")))
;; ;; 	 (tmp-area     (common:get-db-tmp-area))
;; ;; 	 (tmp-db       (conc tmp-area "/megatest.db"))
;; ;; 	 (staging-file (conc *toppath* "/.megatest.db"))
;; ;; 	 (mtdbfile     (conc *toppath* "/megatest.db"))
;; ;; 	 (lockfile     (common:get-sync-lock-filepath))
;; ;;          (sync-cmd-core     (conc sqlite-exe" " tmp-db " .dump | "sqlite-exe" " staging-file "&>"sync-log))
;; ;;          (sync-cmd     (if fork-to-background 
;; ;;                            (conc "/usr/bin/env NBFAKE_LOG="*toppath*"/logs/last-server-sync-"(current-process-id)".log nbfake \""sync-cmd-core" && /bin/mv -f " staging-file " " mtdbfile" \"")
;; ;;                            sync-cmd-core))
;; ;;          (default-min-intersync-delay 2)
;; ;; 	 (min-intersync-delay (configf:lookup-number *configdat* "server" "minimum-intersync-delay" default: default-min-intersync-delay))
;; ;;          (default-duty-cycle 0.1)
;; ;;          (duty-cycle   (configf:lookup-number *configdat* "server" "sync-duty-cycle" default: default-duty-cycle))
;; ;;          (last-sync-seconds 10) ;; we will adjust this to a measurement and delay last-sync-seconds * (1 - duty-cycle)
;; ;;          (calculate-off-time (lambda (work-duration duty-cycle)
;; ;;                                   (* (/ (- 1 duty-cycle) duty-cycle) last-sync-seconds)))
;; ;;          (off-time min-intersync-delay) ;; adjusted in closure below.
;; ;;          (do-a-sync
;; ;;           (lambda ()
;; ;;             (BB> "Start do-a-sync with fork-to-background="fork-to-background" persist-until-sync="persist-until-sync)
;; ;;             (let* ((finalres
;; ;;                     (let retry-loop ((num-tries 0))
;; ;;                          (if (common:simple-file-lock lockfile)
;; ;; 	                     (begin
;; ;;                                (cond
;; ;;                                 ((not (or fork-to-background persist-until-sync))
;; ;;                                  (debug:print 0 *default-log-port* "INFO: syncer thread sleeping for max of (server.minimum-intersync-delay="min-intersync-delay
;; ;;                                               " , off-time="off-time" seconds ]")
;; ;;                                  (thread-sleep! (max off-time min-intersync-delay)))
;; ;;                                 (else
;; ;;                                  (debug:print 0 *default-log-port* "INFO: syncer thread NOT sleeping ; maybe time-to-exit...")))
;; ;; 
;; ;;                                (if (not (configf:lookup *configdat* "server" "disable-db-snapshot"))
;; ;;                                    (common:snapshot-file mtdbfile subdir: ".db-snapshot"))
;; ;; 		               (delete-file* staging-file)
;; ;; 		               (let* ((start-time (current-milliseconds))
;; ;;                                       (res (system sync-cmd))
;; ;;                                       (dbbackupfile (conc mtdbfile ".backup"))
;; ;;                                       (res2 
;; ;;                                        (cond
;; ;;                                         ((eq? 0 res )
;; ;;                                          (handle-exceptions
;; ;;                                             exn
;; ;;                                             #f
;; ;;                                          (if (file-exists? dbbackupfile)
;; ;; 		                           (delete-file* dbbackupfile)
;; ;;                                          )
;; ;;                                          (if (eq? 0 (file-size sync-log))
;; ;;                                              (delete-file* sync-log))
;; ;; 		                         (system (conc "/bin/mv " staging-file " " mtdbfile))
;; ;;                                          
;; ;;                                          (set! last-sync-seconds (/ (- (current-milliseconds) start-time) 1000))
;; ;;                                          (set! off-time (calculate-off-time
;; ;;                                                          last-sync-seconds
;; ;;                                                          (cond
;; ;;                                                           ((and (number? duty-cycle) (> duty-cycle 0) (< duty-cycle 1))
;; ;;                                                            duty-cycle)
;; ;;                                                           (else
;; ;;                                                            (debug:print 0 *default-log-port* "WARNING: ["(common:human-time)"] server.sync-duty-cycle is invalid.  Should be a number between 0 and 1, but "duty-cycle" was specified.  Using default value: "default-duty-cycle)
;; ;;                                                            default-duty-cycle))))
;; ;;                                          
;; ;;                                          (debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] pid="(current-process-id)" SYNC took "last-sync-seconds" sec")
;; ;;                                          (debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] pid="(current-process-id)" SYNC took "last-sync-seconds" sec ; with duty-cycle of "duty-cycle" off time is now "off-time)
;; ;;                                          'sync-completed))
;; ;;                                         (else
;; ;;                                          (system (conc "/bin/cp "sync-log" "sync-log".fail"))
;; ;;                                          (debug:print 0 *default-log-port* "ERROR: ["(common:human-time)"] Sync failed. See log at "sync-log".fail")
;; ;;                                          (if (file-exists? (conc mtdbfile ".backup"))
;; ;;                                              (system (conc "/bin/cp "mtdbfile ".backup " mtdbfile)))
;; ;;                                          #f))))
;; ;;                                  (common:simple-file-release-lock lockfile)
;; ;;                                  (BB> "released lockfile: " lockfile)
;; ;;                                  (when (common:file-exists? lockfile)
;; ;;                                    (BB> "DID NOT ACTUALLY RELEASE LOCKFILE"))
;; ;;                                  res2) ;; end let
;; ;;                                );; end begin
;; ;;                              ;; else
;; ;;                              (cond
;; ;;                               (persist-until-sync
;; ;;                                (thread-sleep! 1)
;; ;;                                (debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] pid="(current-process-id)" other SYNC in progress; we're in a fork-to-background so we need to succeed.  Let's wait a jiffy and and try again. num-tries="num-tries" (waiting for lockfile="lockfile" to disappear)")
;; ;;                                (retry-loop (add1 num-tries)))
;; ;;                               (else
;; ;;                                (thread-sleep! (max off-time (+ last-sync-seconds min-intersync-delay)))
;; ;;                                (debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] pid="(current-process-id)" other SYNC in progress; not syncing.")
;; ;;                                'parallel-sync-in-progress))
;; ;;                              ) ;; end if got lockfile
;; ;;                          )
;; ;;                     ))
;; ;;               (BB> "End do-a-sync with fork-to-background="fork-to-background" persist-until-sync="persist-until-sync" and result="finalres)
;; ;;               finalres)
;; ;;             ) ;; end lambda
;; ;;           ))
;; ;;     do-a-sync))
;; ;; 
;; ;; 

)

(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking format)
(import (prefix sqlite3 sqlite3:))

(declare (unit tasks))
(declare (uses dbfile))
(declare (uses db))
(declare (uses rmtmod))
(declare (uses common))
(declare (uses pgdb))

(import dbfile)
;; (import pgdb) ;; pgdb is a module

(include "task_records.scm")

(use srfi-1 posix srfi-69 srfi-18 regex defstruct)

(use trace)
;; (trace-call-sites #t)

(declare (uses margs))
(declare (uses rmtmod))
(declare (uses common))
;; (declare (uses megatest-version))

(include "megatest-version.scm")
(include "megatest-fossil-hash.scm")
(include "db_records.scm")

(import (prefix sqlite3 sqlite3:))
(import (prefix base64 base64:))

(declare (unit tdb))
(declare (uses common))
(declare (uses keys))
(declare (uses ods))
(declare (uses clientmod))
(declare (uses mt))
(declare (uses db))

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

(declare (uses tdb))
(declare (uses common))
(declare (uses commonmod))
;; (declare (uses dcommon)) ;; needed for the steps processing
(declare (uses items))
(declare (uses runconfig))
;; (declare (uses sdb))
(declare (uses servermod))
;;(declare (uses stml2))

(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp directory-utils)
(import (prefix sqlite3 sqlite3:))
(import commonmod)
(require-library stml)

(declare (unit tree))
(declare (uses margs))
(declare (uses launch))
;; (declare (uses megatest-version))
(declare (uses gutils))
(declare (uses db))
;; (declare (uses server))
;; (declare (uses synchash))
(declare (uses dcommon))

(include "megatest-version.scm")
(include "common_records.scm")
(include "db_records.scm")
(include "key_records.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/>.

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

(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)
				    -10)) ;; ten 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