Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -117,17 +117,18 @@ ;; SERVER (define *my-client-signature* #f) (define *transport-type* #f) ;; override with [server] transport http|rpc|nmsg +(define *DEFAULT-TRANSPORT* "http") (define (common:set-transport-type) (set! *transport-type* (string->symbol (or (args:get-arg "-transport") (configf:lookup *configdat* "server" "transport") - "rpc"))) + *DEFAULT-TRANSPORT*))) *transport-type*) (define *runremote* #f) ;; if set up for server communication this will hold (define *max-cache-size* 0) (define *logged-in-clients* (make-hash-table)) @@ -656,11 +657,11 @@ "clean exit"))) ;; let's try to clean up open sockets (if *runremote* (case (remote-transport *runremote*) - ((http) (close-all-connections!)) + ((http) #t) ((rpc) (rpc:close-all-connections!)) (else (debug:print-info 0 *default-log-port* "Transport "(remote-transport *runremote*)" not supported")))) (thread-start! th1) Index: http-transport.scm ================================================================== --- http-transport.scm +++ http-transport.scm @@ -84,11 +84,11 @@ ((equal? (uri-path (request-uri (current-request))) '(/ "api")) (send-response body: (api:process-request *dbstruct-db* $) ;; the $ is the request vars proc headers: '((content-type text/plain))) (mutex-lock! *heartbeat-mutex*) - (set! *last-db-access* (current-seconds)) + (set! *db-lastaccess* (current-seconds)) (mutex-unlock! *heartbeat-mutex*)) ((equal? (uri-path (request-uri (current-request))) '(/ "")) (send-response body: (http-transport:main-page))) ((equal? (uri-path (request-uri (current-request))) @@ -426,13 +426,13 @@ (begin (debug:print-info 0 *default-log-port* "interface changed, refreshing iface and port info") (set! iface (car sdat)) (set! port (cadr sdat)))) - ;; Transfer *last-db-access* to last-access to use in checking that we are still alive + ;; Transfer *db-last-access* to last-access to use in checking that we are still alive (mutex-lock! *heartbeat-mutex*) - (set! last-access *last-db-access*) + (set! last-access *db-last-access*) (mutex-unlock! *heartbeat-mutex*) ;; (debug:print 11 *default-log-port* "last-access=" last-access ", server-timeout=" server-timeout) ;; ;; no_traffic, no running tests, if server 0, no running servers Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -135,11 +135,13 @@ (not (remote-conndat *runremote*))) ;; and no connection (debug:print-info 12 *default-log-port* "rmt:send-receive, case 6 hh-dat: " (remote-hh-dat *runremote*) " conndat: " (remote-conndat *runremote*)) (mutex-unlock! *rmt-mutex*) (tasks:start-and-wait-for-server (tasks:open-db) 0 15) (let* ((cinfo (rmt:get-connection-info 0)) - (transport (vector-ref cinfo 6))) ;; TODO: replace with tasks:server-dat-accessor-?? for transport + (transport (if cinfo + (vector-ref cinfo 6) + (server:get-transport)))) ;; TODO: replace with tasks:server-dat-accessor-?? for transport (remote-conndat-set! *runremote* cinfo) ;; calls client:setup which calls client:setup-http (remote-transport-set! *runremote* transport)) (rmt:send-receive cmd rid params attemptnum: attemptnum)) ;; all set up if get this far, dispatch the query ((cdr (remote-hh-dat *runremote*)) ;; we are on homehost @@ -271,14 +273,15 @@ (mutex-unlock! *db-multi-sync-mutex*))))) res)) (define (rmt:send-receive-no-auto-client-setup connection-info cmd run-id params) (let* ((run-id (if run-id run-id 0)) + (transport (or (remote-transport *runremote*) (server:get-transport))) (res (handle-exceptions exn #f - (case (remote-transport *runremote*) + (case transport ((http) (http-transport:client-api-send-receive run-id connection-info cmd params)) ((rpc) (rpc-transport:client-api-send-receive run-id connection-info cmd params)) (else (debug:print 0 *default-log-port* "ERROR: transport " (remote-transport *runremote*) " not supported (2)") (exit)) Index: rpc-transport.scm ================================================================== --- rpc-transport.scm +++ rpc-transport.scm @@ -154,11 +154,11 @@ ;;(if *dbstruct-db* (db:sync-touched *dbstruct-db* *run-id* force-sync: #t)) (server:remove-dotserver-file *toppath* "anyhost:anyport" force: #t) (tasks:server-delete-record (db:delay-if-busy (tasks:open-db)) server-id " rpc-transport:keep-running complete") - + (rpc:close-all-connections!) ;;(BB> "Before (exit) (from-on-exit="from-on-exit")") ;;(unless from-on-exit (exit)) ;; sometimes we hang (around) here with 100% cpu. ;;(BB> "After") ;; strace reveals endless: ;; getrusage(RUSAGE_SELF, {ru_utime={413, 917868}, ru_stime={0, 60003}, ...}) = 0 @@ -276,10 +276,11 @@ ;;(BB> "entered rpc-transport:client-api-send-receive with run-id="run-id " serverdat="serverdat" cmd="cmd" params="params" numretries="numretries) (if (not (vector? serverdat)) (begin (BB> "WHAT?? for run-id="run-id", serverdat="serverdat) (print-call-chain) + (rpc:close-all-connections!) (exit 1))) (let* ((iface (rpc-transport:server-dat-get-iface serverdat)) (port (rpc-transport:server-dat-get-port serverdat)) (res #f) (api-exec (rpc-transport:get-api-exec iface port)) ;; chached by host/port. may need to clear... @@ -307,10 +308,11 @@ (time-out-reached #f) (time-out (lambda () (thread-sleep! 45) (set! time-out-reached #t) (thread-terminate! th1) + #f)) (th2 (make-thread time-out "time out"))) (thread-start! th1) (thread-start! th2) Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -71,11 +71,11 @@ (if *transport-type* *transport-type* (let ((ttype (string->symbol (or (args:get-arg "-transport") (configf:lookup *configdat* "server" "transport") - "rpc")))) + *DEFAULT-TRANSPORT*)))) (set! *transport-type* ttype) ttype))) ;; Generate a unique signature for this server (define (server:mk-signature)