Megatest

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

GUISRCF = dashboard-context-menu.scm dashboard-tests.scm		\
          dashboard-guimonitor.scm gutils.scm dcommon.scm tree.scm	\
          vg.scm

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

mofiles/apimod.o : mofiles/servermod.o
mofiles/apimod.o : mofiles/tasksmod.o
mofiles/archivemod.o : mofiles/launchmod.o
mofiles/archivemod.o : mofiles/servermod.o
mofiles/bigmod.o : mofiles/configfmod.o
mofiles/bigmod.o : mofiles/dbmod.o
mofiles/bigmod.o : mofiles/rmtmod.o
mofiles/clientmod.o : mofiles/servermod.o
mofiles/commonmod.o : mofiles/configfmod.o
mofiles/commonmod.o : mofiles/debugprint.o
mofiles/commonmod.o : mofiles/hostinfo.o
mofiles/commonmod.o : mofiles/itemsmod.o
mofiles/commonmod.o : mofiles/keysmod.o
mofiles/commonmod.o : mofiles/mtargs.o
mofiles/commonmod.o : mofiles/mtver.o

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

# include makefile.inc

TCMTOBJS = \
	api.o \
	archive.o \
	cgisetup/models/pgdb.o \
	client.o \
	common.o \
	configf.o \
	db.o \
	env.o \
	http-transport.o \
	items.o \
	keys.o \

	if  csi -ne '(import mysql-client)';then \
           echo "(import mysql-client)(hash-table-set! *available-db* 'mysql #t)" >> altdb.scm; \
	fi
	if csi -ne '(import postgresql)';then \
	   echo "(import postgresql)(hash-table-set! *available-db* 'postgresql #t)" >> altdb.scm;\
	fi

portlogger-example : portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o mt.o ods.o portlogger.o process.o rmt.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o
	csc $(CSCOPTS) portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o mt.o ods.o portlogger.o process.o rmt.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o

buildmanual:
	cd docs/manual && make

targets:
	@grep : Makefile | perl -ne '/^([A-Za-z0-9_-]+):/ && print "$$1\n"'

	dbmod
	debugprint
	tasksmod
	servermod
	matchable
	
	)

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

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




    (if (equal? key "nokey") ;; *server-id*) ;; TODO - get real key involved
	(begin
	  (set! *api-process-request-count* (+ *api-process-request-count* 1))
	  (let* ((res (api:execute-requests dbstruct cmd params))) 
	    (debug:print 0 *default-log-port* "res:" res)
	    #;(if (not success)
		(debug:print 0 *default-log-port* "ERROR: success flag is #f for " cmd " with params " params))
	    (if (> *api-process-request-count* *max-api-process-requests*)
		(set! *max-api-process-requests* *api-process-request-count*))
	    (set! *api-process-request-count* (- *api-process-request-count* 1))
	    (sexpr->string res)))

	(begin
	  (debug:print 0 *default-log-port*   "Server refused to process request. Sever id mismatch. recived " key " expected:  " *server-id* ".\nOther arguments recived: cmd=" cmd " params = " params) 
	  (sexpr->string (conc "Server refused to process request server-id mismatch: " key ", " *server-id*))))))

)

;; (declare (uses db))
;; (declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
;; 
;; (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)

(define *db-cache-path*       #f)
(define *db-with-db-mutex*    (make-mutex))
(define *db-api-call-time*    (make-hash-table)) ;; hash of command => (list of times)
;; no sync db
(define *no-sync-db*          #f)

;; SERVER
(define *my-client-signature* #f)
(define *transport-type*    'http)             ;; override with [server] transport http|rpc|nmsg
;; replaced by *rmt:remote*
;; (define *runremote*         #f)                ;; if set up for server communication this will hold <host port>
;; (define *max-cache-size*    0)
(define *logged-in-clients* (make-hash-table))
(define *server-id*         #f)
(define *server-info*       #f)  ;; good candidate for easily convert to non-global
;; (define *time-to-exit*      #f)
(define *server-run*        #t)
(define *run-id*            #f)
(define *server-kind-run*   (make-hash-table))
(define *home-host*         #f)
;; (define *total-non-write-delay* 0)

(define (string->sexpr instr)
  (handle-exceptions
   exn
   (begin
     (debug:print 0 *default-log-port* "ERROR: string->sexpr bad input \""instr"\"")
     #f)

   (with-input-from-string instr
     (lambda ()(read)))))




)

#!/bin/bash

(killall mtest -v;sleep 1;killall mtest -v -9;rm -f tests/simplerun/.db/* tests/simplerun/logs/* tests/basicserver.log) &
ck5 make -j install &&
wait  &&
ck5 make unit

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

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

(declare (unit rmtmod))

(declare (uses apimod))
(declare (uses clientmod))
(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses dbmod))
(declare (uses debugprint))
(declare (uses itemsmod))
(declare (uses mtargs))
(declare (uses mtver))

	chicken.port
	chicken.pretty-print
	chicken.process
	chicken.process-context
	chicken.process-context.posix
	chicken.sort
	chicken.string

	chicken.tcp	chicken.random
	chicken.time
	chicken.time.posix
	(prefix sqlite3 sqlite3:)
	
	directory-utils
	http-client
	intarweb
	matchable
	md5
	message-digest
	(prefix base64 base64:)
	(prefix sqlite3 sqlite3:)
	regex
	s11n
	spiffy
	spiffy-directory-listing
	spiffy-request-vars
	srfi-1
	srfi-13
	srfi-18
	srfi-69
	stack
	system-information

	typed-records
	uri-common
	z3
       
	apimod
	clientmod
	commonmod
	configfmod
	dbmod
	debugprint
	itemsmod
	mtver
	pgdb

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

;; info about me as a server
;;
(defstruct servdat
  (host #f)
  (port #f)
  (uuid #f)

  (apath    #f)
  (dbname   #f)
  (fullname #f)
  (hostport #f)
  (ipaddr   #f)
  (port     #f)
  (srvpkt   #f)

  (lastmsg  0)
  (expires  0))











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

;; replaces *runremote*
(define *rmt:remote* (make-rmt:remote))

			   (thread-sleep! 4)
			   (rmt:open-main-connection remote apath) ;; TODO: Add limit to number of tries
			   )))
    (if the-srv ;; yes, we have a server, now try connecting to it
	(let* ((srv-addr (server-address the-srv))
	       (ipaddr   (alist-ref 'ipaddr the-srv))
	       (port     (alist-ref 'port   the-srv))

	       (fullpath (db:dbname->path apath dbname))
	       (srvready (server-ready? ipaddr port fullpath)))
	  (if srvready
	      (begin
		(hash-table-set! (rmt:remote-conns remote)
				 dbname ;; fullpath ;; yes, I'd prefer it to be fullpath - FIXME later
				 (make-rmt:conn
				  apath:   apath
				  dbname:  dbname
				  fullname: fullpath
				  hostport: srv-addr
				  ipaddr: ipaddr
				  port: port
				  srvpkt: the-srv

				  lastmsg: (current-seconds)
				  expires: (+ (current-seconds) 60) ;; this needs to be gathered during the ping
				  ))
		#t)
	      (start-main-srv)))
	(start-main-srv))))

	   (if (list? res) ;; server has been registered and the info was returned. pass it on.
	       res
	       (begin
		 (debug:print-info 0 *default-log-port* "Unexpected result: " res)
		 res)))))))))

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


;; Defaults to current area
;;
(define (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f))
  (if (not *rmt:remote*)(set! *rmt:remote* (make-rmt:remote)))
  (let* ((apath *toppath*)
	 (conns *rmt:remote*)
	 (dbname (db:run-id->dbname rid)))
    (rmt:general-open-connection conns apath dbname)
    (rmt:send-receive-real conns apath dbname cmd params)))








;; db is at apath/.db/dbname, rid is an intermediary solution and will be removed
;; sometime in the future
;;
(define (rmt:send-receive-real remote apath dbname cmd params)
  (let* ((conn (rmt:get-conn remote apath dbname)))
    (assert conn "FATAL: rmt:send-receive-real called without the needed channels opened")


    (let* ((payload (sexpr->string params))
	   (res      (with-input-from-request
		      (rmt:conn->uri conn "api")
		      `((params . ,payload)
			(cmd    . ,cmd)
			(key    . "nokey"))



		      read-string)))

      (if (string? res)
	  (string->sexpr res)
	  res))))



;; db is at apath/.db/dbname, rid is an intermediary solution and will be removed
;; sometime in the future.
;;
;; Purpose - call the main.db server and request a server be started
;; for the given area path and dbname
;;
(define (rmt:send-receive-server-start remote apath dbname)
  (let* ((conn (rmt:get-conn remote apath dbname)))
    (assert conn "FATAL: Unable to connect to db "apath"/"dbname)
    (let* ((res      (with-input-from-request
		      (rmt:conn->uri conn "api") 
		      `((params . (,apath ,dbname)))
		      read-string)))
      (string->sexpr res))))

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

  (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 *my-client-signature*)))

;; rmt:login-no-auto-client-setup
;; rmt:send-receive-no-auto-client-setup

;; hand off a call to one of the db:queries statements
;; added run-id to make looking up the correct db possible 
;;

			      (if (bdat-task-db *bdat*)    ;; TODO: Check that this is correct for task db
				  (let ((db (cdr (bdat-task-db *bdat*))))
				    (if (sqlite3:database? db)
					(begin
					  (sqlite3:interrupt! db)
					  (sqlite3:finalize! db #t)
					  (bdat-task-db-set! *bdat* #f)))))
                              (http-client#close-idle-connections!)
                              (if (not (eq? *default-log-port* (current-error-port)))
                                  (close-output-port *default-log-port*))
			      (set! *default-log-port* (current-error-port))) "Cleanup db exit thread"))
	  (th2 (make-thread (lambda ()
			      (debug:print 4 *default-log-port* "Attempting clean exit. Please be patient and wait a few seconds...")
			      (if no-hurry
                                  (begin

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

;; 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))
  (server-ready? host port "nokey yet"))

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

(define (http-transport:make-server-url hostport)
  (if (not hostport)

;; NOTE: http-transport:launch is the entry point
;;          -> http-transport:run
;;             -> http-transport:try-start-server -> http-transport:try-start-server (until success)

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

(define (http-handle-api dbstruct $)
  (if (api-proc)







      ((api-proc) dbstruct $) ;; ($) => alist








      'no-api-proc-set))


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

    ;; 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"))
				   (debug:print 0 *default-log-port* "In api request $=" $)
				   (send-response ;; the $ is the request vars proc
				    body: (http-handle-api *dbstruct-db* $)
				    headers: '((content-type text/plain)))
				   (set! *db-last-access* (current-seconds)))
				  ((equal? (uri-path (request-uri (current-request))) 
					   '(/ "ping"))
				   (send-response body: (conc *toppath*"/"(args:get-arg "-db"))
						  headers: '((content-type text/plain))))
				  ((equal? (uri-path (request-uri (current-request))) 
					   '(/ "loop-test"))
				   (send-response body: (alist-ref 'data ($))
						  headers: '((content-type text/plain))))
				  ((equal? (uri-path (request-uri (current-request))) 
					   '(/ ""))
				   (send-response body: ((http-get-function 'http-transport:main-page))))
				  ((equal? (uri-path (request-uri (current-request))) 
					   '(/ "json_api"))
				   (send-response body: ((http-get-function 'http-transport:main-page))))
				  ((equal? (uri-path (request-uri (current-request))) 
					   '(/ "runs"))
				   (send-response body: ((http-get-function '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-get-function 'http-transport:show-jquery))
						  headers: '((content-type application/javascript))))
                                  ((equal? (uri-path (request-uri (current-request))) 
					   '(/ "test_log"))
				   (send-response body: ((http-get-function 'http-transport:html-test-log) $) 
						  headers: '((content-type text/HTML))))    
                                  ((equal? (uri-path (request-uri (current-request))) 
					   '(/ "dashboard"))
				   (send-response body: ((http-get-function 'http-transport:html-dboard) $)
						  headers: '((content-type text/HTML)))) 
				  (else (continue))))))))
    (http-transport:try-start-server ipaddrstr start-port)))

;; This is recursively run by http-transport:run until sucessful, it then runs until server is stopped
;;
(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)))
	;; any error in following steps will result in a retry
    (if *server-info*
	(begin
	  (servdat-host-set! *server-info* ipaddrstr)
	  (servdat-port-set! *server-info* portnum)
	  (servdat-status-set! *server-info* 'trying-port)
	  (servdat-trynum-set! *server-info* (+ (servdat-trynum *server-info*) 1)))



























	(set! *server-info* (make-servdat host: ipaddrstr port: portnum)))
    (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
		(print "ERROR: Tried and tried but could not start the server"))))
	;; any error in following steps will result in a retry
	(if *server-info*
	    (servdat-status-set! *server-info* 'starting)
	    (set! *server-info* (make-servdat host: ipaddrstr port: 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-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))

  (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.052)
	      (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-idle-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*)))

;; 	      (debug:print-error 0 *default-log-port* " closing connection failed with error: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn))
;; 	    (close-connection! api-dat)
;;             ;;(close-idle-connections!)
;; 	    #t))
;; 	#f)))


(define (make-http-transport:server-dat)(make-vector 6))
(define (http-transport:server-dat-get-iface         vec)    (vector-ref  vec 0))
(define (http-transport:server-dat-get-port          vec)    (vector-ref  vec 1))
(define (http-transport:server-dat-get-api-uri       vec)    (vector-ref  vec 2))
(define (http-transport:server-dat-get-api-url       vec)    (vector-ref  vec 3))
(define (http-transport:server-dat-get-api-req       vec)    (vector-ref  vec 4))
(define (http-transport:server-dat-get-last-access   vec)    (vector-ref  vec 5))
;(define (http-transport:server-dat-get-socket        vec)    (vector-ref  vec 6))
(define (http-transport:server-dat-get-server-id     vec)    (vector-ref  vec 6))

(define (http-transport:server-dat-make-url vec)
  (if (and (http-transport:server-dat-get-iface vec)
	   (http-transport:server-dat-get-port  vec))
      (conc "http://" 
	    (http-transport:server-dat-get-iface vec)
	    ":"
	    (http-transport:server-dat-get-port  vec))
      #f))

(define (http-transport:server-dat-update-last-access vec)
  (if (vector? vec)
      (vector-set! vec 5 (current-seconds))
      (begin
	(print-call-chain (current-error-port))
	(debug:print-error 0 *default-log-port* "call to http-transport:server-dat-update-last-access with non-vector!!"))))

;; initialize servdat for client side, setup needed parameters
;; pass in #f as sdat-in to create sdat
;;
#;(define (servdat-init sdat-in iface port uuid)
  (let* ((sdat (or sdat-in (make-servdat))))
    

(define (get-lock-db sdat dbfile)
  (let* ((dbh (db:open-run-db dbfile db:initialize-db))
	 (res (db:get-iam-server-lock dbh dbfile)))
    (sqlite3:finalize! dbh)
    res))


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

(define (register-server pkts-dir pkt-spec host port servkey ipaddr dbpath)
  (let* ((pkt-dat `((host    . ,host)
		    (port    . ,port)
		    (servkey . ,servkey)
		    (pid     . ,(current-process-id))
		    (ipaddr  . ,ipaddr)
		    (dbpath  . ,dbpath)))

	 all-pkt-files)))

(define (server-address srv-pkt)
  (conc (alist-ref 'host srv-pkt) ":"
	(alist-ref 'port srv-pkt)))
	
(define (server-ready? host port key) ;; server-address is host:port
  ;; ping the server and ask it

  ;; if it ready
  ;; (let* ((sdat (servdat-init #f host port #f)))


  ;;   (http-transport:send-receive sdat "abc" 'ping '())))


  (let* ((res (with-input-from-request
	       (conc "http://"host":"port"/ping") ;; returns *toppath*/dbname
	       #f
	       read-string)))


    (if (equal? res key)
	#t



	(begin
	  (debug:print-info 0 *default-log-port* "server-ready? key="key", received="res)
	  #f))))
	      
(define (loop-test host port data) ;; server-address is host:port
  ;; ping the server and ask it
  ;; if it ready
  ;; (let* ((sdat (servdat-init #f host port #f)))
  ;;   (http-transport:send-receive sdat "abc" 'ping '())))
  (let* ((payload (sexpr->string data))
	 (res     (with-input-from-request
		   (conc "http://"host":"port"/loop-test")
		   `((data . ,payload))
		   read-string)))
    (string->sexpr res)))


	      
; from the pkts return servers associated with dbpath
;; NOTE: Only one can be alive - have to check on each
;;       in the list of pkts returned
;;
(define (get-viable-servers serv-pkts dbpath)
  (let loop ((tail serv-pkts)

  (let loop ((tail serv-pkts))
    (if (null? tail)
	#f
	(let* ((spkt  (car tail))
	       (host  (alist-ref 'ipaddr spkt))
	       (port  (alist-ref 'port spkt))
	       (dbpth (alist-ref 'dbpath spkt))

	       (addr  (server-address spkt)))
	  (if (server-ready? host port (conc apath"/"dbpth))
	      spkt
	      (loop (cdr tail)))))))

;; am I the "first" in line server? I.e. my D card is smallest
;; use Z card as tie breaker
;;
(define (get-best-candidate serv-pkts dbpath)

	      ;;
	      (servdat-uuid-set! sdat
				 (register-server
				  pkts-dir *srvpktspec*
				  (get-host-name)
				  (servdat-port sdat) server-key
				  (servdat-host sdat) db-file))
	      
	      ;; now read pkts and see if we are a contender
	      (let* ((all-pkts     (get-all-server-pkts pkts-dir *srvpktspec*))
		     (viables      (get-viable-servers all-pkts db-file))
		     (best-srv     (get-best-candidate viables db-file))
		     (best-srv-key (if best-srv (alist-ref 'servkey best-srv) #f)))
		(debug:print 0 *default-log-port* "best-srv-key: "best-srv-key", server-key: "server-key)
		;; am I the best-srv, compare server-keys to know
		(if (equal? best-srv-key server-key)
		    (if (get-lock-db sdat db-file) ;; (db:get-iam-server-lock *dbstruct-db* *toppath* run-id)
			(begin
			  (debug:print 0 *default-log-port* "I'm the server!")

			  (servdat-dbfile-set! sdat db-file)
			  (servdat-status-set! sdat 'db-locked))
			(begin
			  (debug:print 0 *default-log-port* "I'm not the server, exiting.")
			  (bdat-time-to-exit-set! *bdat* #t)
			  (thread-sleep! 0.2)
			  (exit)))

	  (thread-sleep! 0.25)
	  (loop curr-host curr-port (+ tries 1)))
	 ((or (not (equal? last-host curr-host))
	      (not (equal? last-port curr-port)))
	  (debug:print-info 0 *default-log-port* "WARNING: interface changed, refreshing iface and port info")
	  (thread-sleep! 0.25)
	  (loop curr-host curr-port (+ tries 1)))
	 ((< (- (current-seconds) stime) 3) ;; keep up the looping until at least 3 seconds have passed
	  (thread-sleep! 1)
	  (loop curr-host curr-port (+ tries 1)))
	 (else
	  (if (not *server-id*)(set! *server-id* (server:mk-signature)))
	  (servdat-status-set! *server-info* 'interface-stable)
	  (debug:print 0 *default-log-port*
		       "SERVER STARTED: " curr-host
		       ":" curr-port
		       " AT " (current-seconds) " server-id: " *server-id*
		       " with "(servdat-trynum *server-info*)" port changes")
	  (flush-output *default-log-port*)
	  #t))))))

;; 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 dbname) 
  ;; if none running or if > 20 seconds since 
  ;; server last used then start shutdown
  ;; This thread waits for the server to come alive
  (debug:print-info 0 *default-log-port* "Starting the sync-back, keep alive thread in server")

  (let* ((server-start-time (current-seconds))
	 (pkts-dir          (get-pkts-dir))
	 (server-key        (server:mk-signature))
	 (is-main           (equal? (args:get-arg "-db") ".db/main.db"))
	 (last-access       0)
	 (server-timeout    (server:expiration-timeout)))
    ;; main and run db servers have both got wait logic (could/should merge it)

    (if is-main
	(http-transport:wait-for-server pkts-dir dbname server-key)
	(http-transport:wait-for-stable-interface))
    ;; this is our forever loop
    (let* ((iface             (servdat-host *server-info*))
	   (port              (servdat-port *server-info*)))
      (let loop ((count         0)

;; Call this to start the actual server
;;
;; all routes though here end in exit ...
;;
;; This is the point at which servers are started
;;
(define (rmt:server-launch dbname)
  ;;(let* ((tmp-area            (common:get-db-tmp-area))
  ;;       (server-start        (conc tmp-area "/.server-start"))
  ;;       (server-started      (conc tmp-area "/.server-started"))
  ;;       (start-time          (common:lazy-modification-time server-start))
  ;;       (started-time        (common:lazy-modification-time server-started))
  ;;       (server-starting     (< start-time started-time)) ;; if start-time is less than started-time then a server is still starting
  ;;       (start-time-old      (> (- (current-seconds) start-time) 5))
  (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 dbname)
			     "Keep running"))))
    (thread-start! th2)
    (thread-sleep! 0.252) ;; give the server time to settle before starting the keep-running monitor.
    (thread-start! th3)
    (set! *didsomething* #t)
    (thread-join! th2)
    (exit)))
	    



;; 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)))
        (set! *my-client-signature* sig)
        *my-client-signature*)))





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


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

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

;;       (server:release-sync-lock)
;;       (server:have-sync-lock?))
;;      (else #f))))



)

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

(import rmtmod trace http-client apimod dbmod
	launchmod)

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


 )

(test #f #t (rmt:remote? (let ((r (make-rmt:remote)))
			   (set! *rmt:remote* r)
			   r)))
(test #f #f (rmt:get-conn *rmt:remote* *toppath* ".db/main.db"))
(test #f #f (rmt:find-main-server *toppath* ".db/main.db"))
(test #f #t (rmt:open-main-connection *rmt:remote* *toppath*))
(pp (hash-table->alist (rmt:remote-conns *rmt:remote*)))
(test #f #t (rmt:conn? (rmt:get-conn *rmt:remote* *toppath* ".db/main.db")))

(define *main*  (rmt:get-conn *rmt:remote* *toppath* ".db/main.db"))

(for-each (lambda (tdat)
	    (test #f tdat (loop-test (rmt:conn-ipaddr *main*)
				     (rmt:conn-port *main*) tdat)))
	  (list 'a
		'(a "b" 123 1.23 )))
(test #f #t (number? (rmt:send-receive 'ping #f 'hello)))

(define *db* (db:setup #f))

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


(test #f 'server-started (api:execute-requests *db* 'get-server (list *toppath* ".db/2.db")))
(set! *dbstruct-db* #f)



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

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

      (close-input-port inp)
      res)))

;; read data from tmp file or create if not exists
;; if exists regen in background
;;
(define (tests:lazy-dot testrecords  outtype sizex sizey)
  (let ((dfile (conc "/tmp/." (current-user-name) "-" (server:mk-signature) ".dot"))
	(fname (conc "/tmp/." (current-user-name) "-" (server:mk-signature) ".dotdat")))
    (tests:write-dot-file testrecords dfile sizex sizey)
    (if (common:file-exists? fname)
	(let ((res (with-input-from-file fname
		     (lambda ()
		       (read-lines)))))
	  (system (conc "env -i PATH=$PATH dot -T " outtype " < " dfile " > " fname "&"))
	  res)

;; (defstruct vg:lib     comps)
;; (defstruct vg:comp    objs name file)
;; ;; extents caches extents calculated on draw
;; ;; proc is called on draw and takes the obj itself as a parameter
;; ;; attrib is an alist of parameters
;; (defstruct vg:obj     type pts fill-color text line-color call-back angle font attrib extents proc)
;; (defstruct vg:inst    libname compname theta xoff yoff scalex scaley mirrx mirry call-back cache)
;; (defstruct vg:drawing libs insts scalex scaley xoff yoff cnv cache) ;; libs: hash of name->lib, insts: hash of instname->inst


;; inits
;;
(define (vg:comp-new)
  (make-vg:comp objs: '() name: #f file: #f))

(define (vg:lib-new)