Index: apimod.scm ================================================================== --- apimod.scm +++ apimod.scm @@ -411,21 +411,26 @@ (cmd (if (string? cmd-in)(string->symbol cmd-in) cmd-in)) (params (alist-ref 'params indat)) (key (alist-ref 'key indat)) ;; TODO - add this back ) (debug:print 0 *default-log-port* "cmd:" cmd " with params " params ", key " key) - (if (equal? key *my-signature*) ;; 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: " *my-signature* ".\nOther arguments recived: cmd=" cmd " params = " params) - (conc "Server refused to process request server signature mismatch: " key ", " *my-signature*))))) + (case cmd-in + ((ping) #t) + ;; ((quit) (exit)) + (else + (if (equal? key *my-signature*) ;; 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) + res)) + (begin + (debug:print 0 *default-log-port* "Server refused to process request. Sever id mismatch. recived " key " expected: " *my-signature* ".\nOther arguments recived: cmd=" cmd " params = " params) + (conc "Server refused to process request server signature mismatch: " key ", " *my-signature*))))))) ) Index: commonmod.scm ================================================================== --- commonmod.scm +++ commonmod.scm @@ -3780,9 +3780,13 @@ (handle-exceptions exn (begin (debug:print 0 *default-log-port* "ERROR: string->sexpr bad input \""instr"\"") #f) - (with-input-from-string instr - read))) + (if (string? instr) + (with-input-from-string instr + read) + (begin + (debug:print-info 0 *default-log-port* "Odd, instr is not a string: "instr) + instr)))) ) Index: rmtmod.scm ================================================================== --- rmtmod.scm +++ rmtmod.scm @@ -1598,18 +1598,13 @@ (begin (close-input-port i) (close-output-port o) (oloop)) (let* ((res (api:process-request dbstruct indat))) - (case res - ((quit) - (close-input-port i) - (close-output-port o)) - (else - (set! *db-last-access* (current-seconds)) - (write res o) - (loop (read i)))))))))) + (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) @@ -1941,10 +1936,11 @@ ;; 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!") + ;; (if (not *server-id*) (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) @@ -2032,10 +2028,11 @@ (server-key (rmt: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) + (set! *server-id* server-key) (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*)) Index: tests/unittests/basicserver.scm ================================================================== --- tests/unittests/basicserver.scm +++ tests/unittests/basicserver.scm @@ -61,11 +61,11 @@ ;; (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))) +(test #f #t (rmt:send-receive 'ping #f 'hello)) (define *db* (db:setup #f)) ;; these let me cut and paste from source easily (define apath *toppath*) Index: vg.scm ================================================================== --- vg.scm +++ vg.scm @@ -40,11 +40,12 @@ ;; ;; 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 +;; (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))