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 \
            servermod.scm clientmod.scm rmtmod.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

# ftail.scm rmtmod.scm commonmod.scm removed

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

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

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

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

(declare (unit servermod))

(module servermod
*

)

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