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