Megatest

;; this segment will run launch:setup only if -log is not set. This is fairly safe as servers are not
;; manually started and thus should never be started in a non-megatest area. Thus no need to handle situation
;; where (launch:setup) returns #f?
;;
(if (or (args:get-arg "-log")(args:get-arg "-server")) ;; redirect the log always when a server
    (handle-exceptions
	exn
	(begin
	  (print "ERROR: Failed to switch to log output. " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)
      (begin
	(print "ERROR: Failed to switch to log output. " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn))
	  )
      (let* ((tl   (or (args:get-arg "-log")(launch:setup)))   ;; run launch:setup if -server, ensure we do NOT run launch:setup if -log specified
	     (logf (or (args:get-arg "-log") ;; use -log unless we are a server, then craft a logfile name
		       (conc tl "/logs/server-" (current-process-id) "-" (get-host-name) ".log")))
	     (oup  (open-logfile logf)))
	(if (not (args:get-arg "-log"))
	    (hash-table-set! args:arg-hash "-log" logf)) ;; fake out future queries of -log
	(debug:print-info 0 *default-log-port* "Sending log output to " logf)

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

;; Server? Start up here.
;;
(if (args:get-arg "-server")
    (let* ((run-id (args:get-arg-number "-run-id"))
    (let ((tl        (launch:setup)))
	   (tl        (launch:setup)))
      (case (rmt:transport-mode)
	((http)(http-transport:launch))
	((tcp) (tt:start-server tl))
	(else (debug:print 0 "ERROR: rmt:transport-mode value not recognised "(rmt:transport-mode))))
	((tcp)
	 (if run-id
	     (tt:start-server tl (dbmod:run-id->dbfname run-id))
	     (begin
	       (debug:print 0 *default-log-port* "ERROR: transport mode is tcp - -run-id is required.")
	       (exit 1))))
	(else (debug:print 0 *default-log-port* "ERROR: rmt:transport-mode value not recognised "(rmt:transport-mode))))
      (set! *didsomething* #t)))

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

	  regex-case
	  srfi-1
	  srfi-18
	  srfi-4
	  srfi-69
	  stack
	  typed-records
	  tcp-server
	  tcp6
	  tcp
	  
	  commonmod
	  debugprint
	)

;;======================================================================
;; client

(defstruct tt-conn
  host
  port
  dbfname
)

(defstruct tt-srv
    ;; server related
  ;; server related
  (areapath     #f)
  (host         #f)
  (port         #f)
  (conn         #f)
  (cleanup-proc #f)
  (handler      #f) ;; receives data and responds
  socket
  thread
  host-port
  (socket       #f)
  (thread       #f)
  (host-port    #f)
  (cmd-thread   #f)
  )

(define (tt:make-remote areapath)
  (make-tt area: areapath))

(define (tt:client-connect-to-server ttdat)
  #f)

;; client side handler
;;
(define (tt:handler runremote cmd rid params attemptnum area-dat areapath readonly-mode dbfname)
  ;; NOTE: areapath is passed in and in tt struct. We'll use passed in value for now.
  (let* ((conn (hash-table-ref/default (tt-conns runremote) dbfname #f)))
    (if conn
	;; have connection, call the server
	(let* ((res (tt:send-receive runremote conn cmd rid params)))
	  (cond

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

(define (tt:sync-dbs ttdat)
  #f)

;; start the listener and start responding to requests
;;
;; NOTE: organise by dbfname, not run-id so we don't need
;;       to pull in more modules
;;
(define (tt:start-server ttdat dbfname)
(define (tt:start-server areapath dbfname handler)
  ;; is there already a server for this dbfile? Then exit.
  (let* ((ttdat  (make-tt-srv areapath: areapath))
	 ;; (dbfname (dbmod:run-id->dbfname run-id))
  (let* ((servers (tt:find-server ttdat dbfname)))
    (if (not (null? servers))
	 (servers (tt:find-server ttdat dbfname)))
    (tt-srv-handler-set! ttdat handler)
    (if (null? servers)
	(begin
	  (tt:start-tcp-server ttdat) ;; start the tcp-server which applies handler to incoming data
	  (tt:keep-running ttdat dbfname))
	(begin
	  (debug:print 0 *default-log-port* "INFO: found server(s) already running for db "dbfname", "(string-intersperse servers ",")" Exiting.")
	  (exit))
	(begin
	  (tt:start-tcp-server ttdat)
	  (tt:keep-running ttdat dbfname)))))
	  (exit)))))

((make-tcp-server 
  (tcp-listen 6504) 
  (lambda () 
    (write-line (seconds->string (current-seconds)))))
 #t)

;; find a port and start tcp-server
;;
(define (tt:start-tcp-server ttdat)
  (setup-listener ttdat)
  (let* ((socket   (tt-srv-socket ttdat))
	 (handler  (tt-srv-handler    ttdat)))
    ((make-tcp-server socket handler)
     #t ;; yes, send error messages to std-err
  #f)
     )))

(define (tt:keep-running ttdat dbfile)
  ;; verfiy conn for ready
  ;; listener socket has been started by this stage
  (debug:print 0 *default-log-port* "INFO: Got here!!!!"))
  #f)

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

(define (tt:shutdown-server ttdat)
  (let* ((cleanproc (tt-srv-cleanup-proc ttdat)))
    (if cleanproc (cleanproc))
    ;; close up ports here
    #f))
    (tcp-close (tt-srv-socket ttdat)) ;; close up ports here
    ))

(define (wait-and-close uconn)
  (thread-join! (tt-srv-cmd-thread uconn))
  (tcp-close (tt-srv-socket uconn)))
;; (define (wait-and-close uconn)
;;   (thread-join! (tt-srv-cmd-thread uconn))
;;   (tcp-close (tt-srv-socket uconn)))

;; return servid
;; side-effects:
;;   ttdat-cleanup-proc is populated with function to remove the serverinfo file
(define (tt:create-server-registration-file ttdat dbfname)
  (let* ((areapath (tt-areapath ttdat))
	 (servdir  (tt:get-servinfo-dir areapath))

;; my port, address, hostname, pid etc.
;; return #f if fail to find a port to allocate.
;;
;;  if udata-in is #f create the record
;;  if there is already a serv-listener return the udata
;;
(define (setup-listener uconn #!optional (port 4242))
  (assert (tt-srv? uconn) "FATAL: setup-listener called with wrong struct "uconn)
  (handle-exceptions
   exn
   (if (< port 65535)
       (setup-listener uconn (+ port 1))
       #f)
   (connect-listener uconn port)))