Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -587,13 +587,12 @@ ;; 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")) @@ -923,15 +922,21 @@ ;;====================================================================== ;; Server? Start up here. ;; (if (args:get-arg "-server") - (let ((tl (launch:setup))) + (let* ((run-id (args:get-arg-number "-run-id")) + (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. ;; Index: tcp-transportmod.scm ================================================================== --- tcp-transportmod.scm +++ tcp-transportmod.scm @@ -46,11 +46,12 @@ srfi-18 srfi-4 srfi-69 stack typed-records - tcp6 + tcp-server + tcp commonmod debugprint ) @@ -74,27 +75,31 @@ port dbfname ) (defstruct tt-srv - ;; server related + ;; server related + (areapath #f) (host #f) (port #f) (conn #f) (cleanup-proc #f) - socket - thread - host-port + (handler #f) ;; receives data and responds + (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 @@ -133,36 +138,91 @@ (define (tt:sync-dbs ttdat) #f) ;; start the listener and start responding to requests ;; -(define (tt:start-server ttdat dbfname) +;; NOTE: organise by dbfname, not run-id so we don't need +;; to pull in more modules +;; +(define (tt:start-server areapath dbfname handler) ;; is there already a server for this dbfile? Then exit. - (let* ((servers (tt:find-server ttdat dbfname))) - (if (not (null? servers)) + (let* ((ttdat (make-tt-srv areapath: areapath)) + ;; (dbfname (dbmod:run-id->dbfname run-id)) + (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) - #f) + (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 + ))) (define (tt:keep-running ttdat dbfile) - #f) + ;; verfiy conn for ready + ;; listener socket has been started by this stage + (debug:print 0 *default-log-port* "INFO: Got here!!!!")) + +;; ;; 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) @@ -223,10 +283,11 @@ ;; ;; 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)