Megatest

;;     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.tcp	chicken.random
	chicken.random
	chicken.time
	chicken.time.posix
	(prefix sqlite3 sqlite3:)
	
	directory-utils
	http-client
	intarweb
	;; http-client
	;; intarweb
	matchable
	md5
	message-digest
	(prefix base64 base64:)
	(prefix sqlite3 sqlite3:)
	regex
	s11n
	spiffy
	spiffy-directory-listing
	spiffy-request-vars
	;; spiffy
	;; spiffy-directory-listing
	;; spiffy-request-vars
	srfi-1
	srfi-13
	srfi-18
	srfi-69
	stack
	system-information
	tcp6
	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) 
;; (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)
  (srvkey   #f)
  (lastmsg  0)
  (expires  0))
  (expires  0)
  (inport   #f)
  (outport  #f))

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

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

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

			   ;; srv not ready, delay a little and try again
			   (api:run-server-process apath dbname)
			   (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))
	       (ipaddr   (alist-ref 'ipaddr  the-srv))
	       (port     (alist-ref 'port    the-srv))
	       (srvkey   (alist-ref 'servkey the-srv))
	       (fullpath (db:dbname->path apath dbname))
	       (srvready (server-ready? ipaddr port fullpath)))
	       (srvready (server-ready? ipaddr port srvkey)))
	  (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
				  srvkey: srvkey ;; generated by rmt:get-signature on the server side
				  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)))

#;(define (rmt:send-receive-setup conn)
  (if (not (rmt:conn-inport conn))
      (let-values (((i o) (tcp-connect (rmt:conn-ipaddr conn)
				       (rmt:conn-port conn))))
	(rmt:conn-inport-set! conn i)
	(rmt:conn-outport-set! conn o))))
  
;; 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))))
    (pp (rmt:conn->alist conn))
    ;; (rmt:send-receive-setup conn)
    (let-values (((i o) (tcp-connect (rmt:conn-ipaddr conn)
				     (rmt:conn-port conn))))
      (let* ((key     #f)
	     (payload `((cmd    . ,cmd)
			(key    . ,(rmt:conn-srvkey conn))
			(params . ,params)))
	     (res      (begin
			 (write payload o) ;; (rmt:conn-outport conn))
			 (with-input-from-port
			     i ;; (rmt:conn-inport conn)
			   read))))
	(close-input-port i)
	(close-output-port o)
	res))))
;;  (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: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:send-receive 'login run-id (list *toppath* megatest-version *my-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!)
                              #;(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.
;;       in the same process as the server. 
;;
(define (server:ping host port server-id #!key (do-exit #f))
  (server-ready? host port "nokey yet"))
  (server-ready? host port server-id))

;;======================================================================
;; 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 (rmt:launch-server hostn port)
   (if *server-info*
	(begin
	  (servdat-host-set! *server-info* hostn)
	  (servdat-port-set! *server-info* port)
	  (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)))
   (let* ((l        (tcp-listen port))
	 (dbstruct #f))
    (let-values (((i o) (tcp-accept l)))
      ;; (write-line "Hello!" o)
      (let loop ((indat (read i)))
	(let* ((res (api:process-request dbstruct indat)))
	  (case res
	    ((quit)
	     (close-input-port i)
	     (close-output-port o))
	    (else
	     (write res o))))))))

(define (http-transport:run hostn)
  ;; Configurations for server
  (tcp-buffer-size 2048)
  (max-connections 2048) 
(define (rmt: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))
	 (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)
    (debug:print-info 0 *default-log-port* "portlogger recommended port: " 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-port-set! *server-info* port)
	  (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: port)))
    (let* ((l        (rmt:try-start-server ipaddrstr port)))
      (let oloop ()
	(let-values (((i o) (tcp-accept l)))
	  ;; (write-line "Hello!" o)
	  (let loop ((indat (read i)))
	    (if (eof-object? indat)
		(begin
		  (close-input-port i)
		  (close-output-port o)
		  (oloop))
		(let* ((res (api:process-request *dbstruct-db* indat)))
		  (set! *db-last-access* (current-seconds))
		  (write res o)
		  (loop (read i))))))))
    (let* ((portnum (servdat-port *server-info*)))
      (portlogger:open-run-close portlogger:set-port portnum "released")
      (debug:print 1 *default-log-port* "INFO: server has been stopped"))))

(define (rmt:try-start-server ipaddrstr portnum)
  (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
      (set! *server-info* (make-servdat host: ipaddrstr port: portnum)))
  (debug:print-info 0 *default-log-port* "rmt: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)
  (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)
	   (rmt: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))
   (tcp-listen 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*
	    (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!)))
			       "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
  (let-values (((i o)(handle-exceptions
		      exn
		      (values #f #f)
		      (tcp-connect host port))))
    (if (and i o)
	(begin
	  (write `((cmd . ping)
		   (key . ,key)
		   (params . ())) o)
	  (let ((res (with-input-from-port i
	       (conc "http://"host":"port"/ping") ;; returns *toppath*/dbname
	       #f
	       read-string)))
    (if (equal? res key)
		       read)))
	    (close-output-port o)
	    (close-input-port i)
	    res))
	#t
	(begin
	  (debug:print-info 0 *default-log-port* "server-ready? key="key", received="res)
;; 	    (if (string? res)
;; 		(string->sexpr res)
;; 		res)))
	(begin ;; connection failed
	  (debug:print-info 0 *default-log-port* "Server at "host":"port" is not responding.")
	  #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)))
 	      
;; (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))
;;   #f
;;   )
	      
; from the pkts return servers associated with dbpath
;; NOTE: Only one can be alive - have to check on each
;;       in the list of pkts returned
;;
(define (get-viable-servers serv-pkts dbpath)
  (let loop ((tail serv-pkts)

  (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))
	       (srvkey (alist-ref 'Z spkt)) ;; (alist-ref 'srvkey spkt))
	       (addr  (server-address spkt)))
	  (if (server-ready? host port (conc apath"/"dbpth))
	  (if (server-ready? host port srvkey)
	      spkt
	      (loop (cdr tail)))))))

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

	      ;;
	      (servdat-uuid-set! sdat
				 (register-server
				  pkts-dir *srvpktspec*
				  (get-host-name)
				  (servdat-port sdat) server-key
				  (servdat-host sdat) db-file))
	      
	      ;; (set! *my-signature* (servdat-uuid sdat)) ;; replace with Z, no, stick with proper key
	      ;; now read pkts and see if we are a contender
	      (let* ((all-pkts     (get-all-server-pkts pkts-dir *srvpktspec*))
		     (viables      (get-viable-servers all-pkts db-file))
		     (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

			  (bdat-time-to-exit-set! *bdat* #t)
			  (thread-sleep! 0.2)
			  (exit)))
		    (begin
		      (debug:print 0 *default-log-port*
				   "Keys do not match "best-srv-key", "server-key", exiting.")
		      (bdat-time-to-exit-set! *bdat* #t)
		      (delete-file* (conc (get-pkts-dir *toppath*)
					  "/" (servdat-uuid *server-info*)
					  ".pkt")) ;; remove immediately instead of waiting for on-exit
		      (thread-sleep! 0.2)
		      (exit)))
		sdat))
	    (begin ;; sdat not yet contains server info
	      (debug:print-info 0 *default-log-port* "Still waiting, last-sdat=" last-sdat)
	      (sleep 4)
	      (if (> (- (current-seconds) start-time) 120) ;; been waiting for two minutes

	  (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)
	 ((< (- (current-seconds) stime) 1) ;; keep up the looping until at least 3 seconds have passed
	  (thread-sleep! 0.5)
	  (loop curr-host curr-port (+ tries 1)))
	 (else
	  (if (not *server-id*)(set! *server-id* (server:mk-signature)))
	  (rmt:get-signature) ;; sets *my-signature* as side effect
	  (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*
		       " AT " (current-seconds) " server signature: " *my-signature*
		       " 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) 
(define (rmt:keep-running dbname) 
  ;; if none running or if > 20 seconds since 
  ;; server last used then start shutdown
  ;; This thread waits for the server to come alive
  (debug:print-info 0 *default-log-port* "Starting the sync-back, keep alive thread in server")

  (let* ((server-start-time (current-seconds))
	 (pkts-dir          (get-pkts-dir))
	 (server-key        (server:mk-signature))
	 (server-key        (rmt:get-signature)) ;; This servers key
	 (is-main           (equal? (args:get-arg "-db") ".db/main.db"))
	 (last-access       0)
	 (server-timeout    (server:expiration-timeout)))
    ;; 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))

;; 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"))
			     (rmt: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)
			     (rmt:keep-running dbname)
			     "Keep running"))))
    (thread-start! th2)
    (thread-sleep! 0.252) ;; give the server time to settle before starting the keep-running monitor.
    (thread-start! th3)
    (set! *didsomething* #t)
    (thread-join! th2)
    (exit)))
	    
;; Generate a unique signature for this server
(define (server:mk-signature)
  (exit))

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

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

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

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


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



)

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


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