Index: fs-transport.scm ================================================================== --- fs-transport.scm +++ fs-transport.scm @@ -13,11 +13,12 @@ (use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest) (import (prefix sqlite3 sqlite3:)) (use spiffy uri-common intarweb http-client spiffy-request-vars) -(tcp-buffer-size 2048) +;;(tcp-buffer-size 2048) +(BB> "HEY TURNING OFF tcp-buffer-size TO TEST FOR RPC SIDE EFFECT> TURN BACK ON BEFORE PRODUCTION") (declare (unit fs-transport)) (declare (uses common)) (declare (uses db)) Index: http-transport.scm ================================================================== --- http-transport.scm +++ http-transport.scm @@ -14,11 +14,15 @@ ;; (import (prefix sqlite3 sqlite3:)) (use spiffy uri-common intarweb http-client spiffy-request-vars intarweb spiffy-directory-listing) ;; Configurations for server -(tcp-buffer-size 2048) + +(tcp-buffer-size 2048) ;; this interferes with rpc ; compensating in rpc-transport... so far so good + + + (max-connections 2048) (declare (unit http-transport)) (declare (uses common)) Index: rpc-transport.scm ================================================================== --- rpc-transport.scm +++ rpc-transport.scm @@ -123,13 +123,26 @@ ;;====================================================================== ;; start of publish-procedure section ;;====================================================================== (rpc:publish-procedure! 'server:login server:login) ;; this allows client to validate it is the same megatest instance as the server. No security here, just making sure we're in the right room. - (rpc:publish-procedure! 'testing (lambda () "Just testing")) + (BB> "published 'testing") + (rpc:publish-procedure! + 'testing + (lambda () + (BB> "Current-peer=["(rpc:current-peer)"]") + (BB> "published rpc proc 'testing was invoked") + "Just testing")) - ;; BB: BBTODO: publish procedure to receive request from client's rpc:send-receive/rpc-transport:client-api-send-receive call + ;; procedure to receive arbitrary API request from client's rpc:send-receive/rpc-transport:client-api-send-receive + (rpc:publish-procedure! 'rpc-transport:autoremote rpc-transport:autoremote) + ;; can use this to run most anything at the remote + (rpc:publish-procedure! + 'remote:run + (lambda (procstr . params) + (server:autoremote procstr params))) + ;;====================================================================== ;; end of publish-procedure section ;;====================================================================== @@ -155,42 +168,56 @@ ;; It is our handle on the listening tcp port ;; We will attach this to our rpc server with rpc:make-server in thread th1 . (rpc:listener (rpc-transport:find-free-port-and-open start-port)) (th1 (make-thread (lambda () - ((rpc:make-server rpc:listener) #t)) + (BB> "+++ before rpc:make-server "rpc:listener) + ;;(cute (rpc:make-server rpc:listener) "rpc:server") + ((rpc:make-server rpc:listener) #t) + (BB> "--- after rpc:make-server")) "rpc:server")) - - ;; (cute (rpc:make-server rpc:listener) "rpc:server") - ;; 'rpc:server)) - (hostname (if (string=? "-" hostn) + + + (hostname (if (string=? "-" hostn) (get-host-name) hostn)) (ipaddrstr (if (string=? "-" hostn) (server:get-best-guess-address hostname) ;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".") #f)) (portnum (let ((res (rpc:default-server-port))) (BB> "rpc:default-server-port="res" rpc-listener-port="*rpc-listener-port*) res)) (host:port (conc (if ipaddrstr ipaddrstr hostname) ":" portnum))) ;; if rpc found it needed a different port than portlogger provided, keep portlogger in the loop. - (when (not (equal? start-port portnum)) - (BB> "portlogger proffered "start-port" but rpc grabbed "portnum) - (portlogger:open-run-close portlogger:set-port start-port "released") - (portlogger:open-run-close portlogger:take-port portnum)) + ;; (when (not (equal? start-port portnum)) + ;; (BB> "portlogger proffered "start-port" but rpc grabbed "portnum) + ;; (portlogger:open-run-close portlogger:set-port start-port "released") + ;; (portlogger:open-run-close portlogger:take-port portnum)) + + (tasks:bb-server-set-interface-port server-id ipaddrstr portnum) + ;;============================================================ ;; activate thread th1 to attach opened tcp port to rpc server ;;============================================================= (BB> "Got here before thread start of rpc listener") (thread-start! th1) - - (BB> "started rpc server thread th1="th1) + (set! db *inmemdb*) -o (tasks:bb-server-set-interface-port server-id ipaddrstr portnum) + (debug:print 0 *default-log-port* "Server started on " host:port) + (thread-sleep! 8) + (BB> "before self test") + (if (rpc-transport:self-test run-id ipaddrstr portnum) + (BB> "Pass self-test.") + (begin + (print "Error: rpc listener did not pass self test. Shutting down.") + (exit))) + (BB> "after self test") + + (on-exit (lambda () (rpc-transport:server-shutdown server-id rpc:listener from-on-exit: #t))) ;; check again for running servers for this run-id in case one has snuck in since we checked last in rpc-transport:launch (if (not (equal? server-id (tasks:bb-server-am-i-the-server? run-id)));; try to ensure no double registering of servers @@ -319,33 +346,60 @@ (define (rpc-transport:find-free-port-and-open port #!key ) (handle-exceptions exn (begin (print "Failed to bind to port " (rpc:default-server-port) ", trying next port") - (rpc-transport:find-free-port-and-open (+ port 1))) + (rpc-transport:find-free-port-and-open (add1 port))) (rpc:default-server-port port) (set! *rpc-listener-port* port) ;; a bit paranoid about rpc:default-server-port parameter not changing across threads (as params are wont to do). keeping this global in my back pocket in case this causes problems (set! *rpc-listener-port-bind-timestamp* (current-milliseconds)) ;; may want to test how long it has been since the last bind attempt happened... (tcp-read-timeout 240000) + (tcp-buffer-size 0) ;; gotta do this because http-transport undoes it. (BB> "rpc-transport> attempting to bind tcp port "port) - (tcp-listen (rpc:default-server-port) 10000))) + (tcp-listen (rpc:default-server-port) 10000) + ;;(tcp-listen (rpc:default-server-port) ) + )) (define (rpc-transport:ping run-id host port) (handle-exceptions exn (begin (print "SERVER_NOT_FOUND") (exit 1)) (let ((login-res ((rpc:procedure 'server:login host port) *toppath*))) - (if (and (list? login-res) - (car login-res)) + (if login-res (begin (print "LOGIN_OK") (exit 0)) (begin (print "LOGIN_FAILED") (exit 1)))))) + +(define (rpc-transport:self-test run-id host port) + (BB> "SELF TEST RPC ... *toppath*="*toppath*) + (BB> "local: [" (server:login *toppath*) "]") + ;(handle-exceptions + ;exn + ;(begin + ; (BB> "SERVER_NOT_FOUND") + ; #f) + (tcp-buffer-size 0) ;; gotta do this because http-transport undoes it. + (let* ((testing-res ((rpc:procedure 'testing host port))) + (login-res ((rpc:procedure 'server:login host port) *toppath*)) + (res (and login-res (equal? testing-res "Just testing")))) + + (BB> "testing-res = >"testing-res"<") + (BB> "login-res = >"testing-res"<") + (if login-res + (begin + (BB> "LOGIN_OK") + #t) + (begin + (BB> "LOGIN_FAILED") + #f)) + (BB> "self test res="res) + res));) (define (rpc-transport:client-setup run-id #!key (remtries 10)) (if *runremote* (begin (debug:print-error 0 *default-log-port* "Attempt to connect to server but already connected") Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -264,19 +264,19 @@ ;; Client will call this procedure on the server via the low-level transport (http/rpc/etc) to verify its toppath matches the server's toppath. ;; A true result means client and server are associated with same megatest instance, share the same megatest.config, etc...) A false result means the client should not talk to this server. (define (server:login toppath) - (lambda (toppath) - (set! *last-db-access* (current-seconds)) - (if (equal? *toppath* toppath) - (begin - ;; (debug:print-info 2 *default-log-port* "login successful") - #t) - (begin - ;; (debug:print-info 2 *default-log-port* "login failed") - #f)))) + (set! *last-db-access* (current-seconds)) + (BB> "server:login ours="*toppath*" theirs="toppath) + (if (equal? *toppath* toppath) + (begin + ;; (debug:print-info 2 *default-log-port* "login successful") + #t) + (begin + ;; (debug:print-info 2 *default-log-port* "login failed") + #f))) (define (server:get-timeout) (let ((tmo (configf:lookup *configdat* "server" "timeout"))) (if (and (string? tmo) (string->number tmo))