Index: client.scm ================================================================== --- client.scm +++ client.scm @@ -71,11 +71,11 @@ (thread-sleep! (+ 5 (random (- 20 remaining-tries)))) ;; give server a little time to start up, randomize a little to avoid start storms. (client:setup run-id remaining-tries: (- remaining-tries 1)))))) ((http)(client:setup-http run-id server-dat remaining-tries)) ;; ((rpc) (rpc-transport:client-setup run-id)) ;;(client:setup-rpc run-id)) rpc not implemented; want to see a failure here for now. (else - (debug:print-error 0 *default-log-port* "Transport [" + (debug:print-error 0 *default-log-port* "(6) Transport [" transport "] specified for run-id [" run-id "] is not implemented in client:setup. Cannot proceed.") (exit 1))))) ;; client:setup-http ;; @@ -93,16 +93,16 @@ (begin (hash-table-set! *runremote* run-id start-res) ;; side-effect - *runremote* cache init fpr rmt:* (debug:print-info 2 *default-log-port* "connected to " (http-transport:server-dat-make-url start-res)) start-res) (begin ;; login failed but have a server record, clean out the record and try again - (debug:print-info 0 *default-log-port* "client:setup, login failed, will attempt to start server ... start-res=" start-res ", run-id=" run-id ", server-dat=" server-dat) + (debug:print-info 0 *default-log-port* "client:setup-http, login failed, will attempt to start server ... start-res=" start-res ", run-id=" run-id ", server-dat=" server-dat) (http-transport:close-connections run-id) (hash-table-delete! *runremote* run-id) (tasks:kill-server-run-id run-id) (tasks:bb-server-force-clean-run-record run-id iface port - " client:setup (server-dat = #t)") + " client:setup-http (server-dat = #t)") (if (> remaining-tries 8) (thread-sleep! (+ 1 (random 5))) ;; spread out the starts a little (thread-sleep! (+ 15 (random 20)))) ;; it isn't going well. give it plenty of time (server:try-running run-id) (thread-sleep! 5) ;; give server a little time to start up Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -77,12 +77,15 @@ (define *db-access-allowed* #t) ;; flag to allow access (define *db-access-mutex* (make-mutex)) ;; SERVER (define *my-client-signature* #f) -(define *transport-type* 'http) -(define *transport-type* 'http) ;; override with [server] transport http|rpc|nmsg + +;; default preference for transport-type is set here +;; +(define *transport-type* 'http) ;; override with [server] transport http|rpc + (define *runremote* (make-hash-table)) ;; if set up for server communication this will hold (define *max-cache-size* 0) (define *logged-in-clients* (make-hash-table)) (define *client-non-blocking-mode* #f) (define *server-id* #f) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -1122,11 +1122,11 @@ (set! cmdparms (base64:base64-encode (z3:encode-buffer (with-output-to-string (lambda () ;; (list 'hosts hosts) (write (list (list 'testpath test-path) - (list 'transport (conc *transport-type*)) + (list 'transport (conc (rmt:run-id->transport-type run-id))) ;; (list 'serverinf *server-info*) (list 'toppath *toppath*) (list 'work-area work-area) (list 'test-name test-name) (list 'runscript runscript) Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -13,11 +13,12 @@ (declare (unit rmt)) (declare (uses api)) (declare (uses tdb)) (declare (uses http-transport)) -;;(declare (uses nmsg-transport)) +(declare (uses rpc-transport)) + ;; ;; THESE ARE ALL CALLED ON THE CLIENT SIDE!!! ;; ;; ;; For debugging add the following to ~/.megatestrc @@ -68,18 +69,28 @@ ;; NB// can cache the answer for server running for 10 seconds ... ;; ;; (and (not (rmt:write-frequency-over-limit? cmd run-id)) (if (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id) (client:setup run-id) #f)))) + +(define (rmt:run-id->transport-type rid) + (let* ((run-id (if rid rid 0)) + (connection-info (hash-table-ref/default *runremote* run-id #f))) + ;; the nmsg method does the encoding under the hood (the http method should be changed to do this also) + + (if connection-info ;; if we already have a connection for this run-id, use that precendent + ;; use the server if have connection info + (let* ((transport-type (vector-ref connection-info 6))) ;; BB: assumes all transport-type'-servertdat vector's item 6 ids transport type + transport-type) + ;; otherwise pick the global default as preference. + *transport-type*))) (define *send-receive-mutex* (make-mutex)) ;; should have separate mutex per run-id ;; RA => e.g. usage (rmt:send-receive 'get-var #f (list varname)) ;; (define (rmt:send-receive cmd rid params #!key (attemptnum 1)) ;; start attemptnum at 1 so the modulo below works as expected - - ;; side-effect: clean out old connections ;; (mutex-lock! *db-multi-sync-mutex*) (let ((expire-time (- (current-seconds) (server:get-timeout) 10))) ;; don't forget the 10 second margin (for-each (lambda (run-id) @@ -96,34 +107,48 @@ (let* ((run-id (if rid rid 0)) (connection-info (rmt:get-connection-info run-id))) ;; the nmsg method does the encoding under the hood (the http method should be changed to do this also) (if connection-info ;; use the server if have connection info - (let* ((transport-type (vector-ref connection-info 6)) ;; BB: assumes all transport-type'-servertdat vector's item 6 ids transport type - (dat (case transport-type ;; BB: replaced *transport-type* global with run-id specific transport-type, item 6 in server-info vector which was populated by *-transport:client-connect with >> (vector iface port api-uri api-url api-req (current-seconds) 'http ) << + (let* ((transport-type (rmt:run-id->transport-type run-id)) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Here, we make request to remote server + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (dat (case transport-type ;; BB: replaced *transport-type* global with run-id specific transport-type ((http)(condition-case (http-transport:client-api-send-receive run-id connection-info cmd params) ((commfail)(vector #f "communications fail")) ((exn)(vector #f "other fail")))) ;;((rpc) (rpc-transport:client-api-send-receive run-id connection-info cmd params)) ;; BB: let us error out for now (else - (debug:print-error 0 *default-log-port* "Transport [" - transport "] specified for run-id [" run-id "] is not implemented in rmt:send-receive. Cannot proceed.") - (exit 1)))) + (debug:print-error 0 *default-log-port* "(1) Transport [" transport-type + "] specified for run-id [" run-id + "] is not implemented in rmt:send-receive. Cannot proceed.") + (vector #f (conc "transport ["transport-type"] unimplemented"))))) + + (success (if (vector? dat) (vector-ref dat 0) #f)) (res (if (vector? dat) (vector-ref dat 1) #f))) (if (vector? connection-info)(http-transport:server-dat-update-last-access connection-info)) ;; BB> BBTODO: make this generic, not http transport specific. (if success (begin ;; (mutex-unlock! *send-receive-mutex*) - (case *transport-type* + (case transport-type ((http rpc) res) ;; (db:string->obj res)) + (else + (debug:print-error 0 *default-log-port* "(2) Transport [" transport-type + "] specified for run-id [" run-id + "] is not implemented in rmt:send-receive. Cannot proceed. Also unexpected since this branch follows success which would follow a suported transport...") + #f) ;; ((nmsg) res) )) ;; (vector-ref res 1))) + + (begin ;; let ((new-connection-info (client:setup run-id))) (debug:print 0 *default-log-port* "WARNING: Communication failed, trying call to rmt:send-receive again.") - (case *transport-type* + (case transport-type ((http) (hash-table-delete! *runremote* run-id) ;; don't keep using the same connection ;; NOTE: killing server causes this process to block forever. No idea why. Dec 2. ;; (if (eq? (modulo attemptnum 5) 0) ;; (tasks:kill-server-run-id run-id tag: "api-send-receive-failed")) @@ -134,19 +159,25 @@ ;; no longer killing the server in http-transport:client-api-send-receive ;; may kill it here but what are the criteria? ;; start with three calls then kill server ;; (if (eq? attemptnum 3)(tasks:kill-server-run-id run-id)) ;; (thread-sleep! 2) - (rmt:send-receive cmd run-id params attemptnum: (+ attemptnum 1))))))) - ;; no connection info? try to start a server, or access locally if no + (rmt:send-receive cmd run-id params attemptnum: (+ attemptnum 1))) + (else + (debug:print-error 0 *default-log-port* "(3) Transport [" transport-type + "] specified for run-id [" run-id + "] is not implemented in rmt:send-receive. Cannot proceed.") + #f))))) + + ;; no connection info; try to start a server, or access locally if no ;; server and the query is read-only ;; ;; Note: The tasks db was checked for a server in starting mode in the rmt:get-connection-info call ;; (if (and (< attemptnum 15) (member cmd api:write-queries)) - (let ((faststart (configf:lookup *configdat* "server" "faststart"))) + (let* ((faststart (configf:lookup *configdat* "server" "faststart"))) (hash-table-delete! *runremote* run-id) ;; (mutex-unlock! *send-receive-mutex*) (if (and faststart (equal? faststart "no")) (begin (tasks:start-and-wait-for-server (db:delay-if-busy (tasks:open-db)) run-id 10) @@ -315,14 +346,17 @@ ;; This login does no retries under the hood - it acts a bit like a ping. ;; Deprecated for nmsg-transport. ;; (define (rmt:login-no-auto-client-setup connection-info run-id) - (case *transport-type* + (case (rmt:run-id->transport-type run-id) ((http)(rmt:send-receive-no-auto-client-setup connection-info 'login run-id (list *toppath* megatest-version run-id *my-client-signature*))) - ;;((nmsg)(nmsg-transport:client-api-send-receive run-id connection-info 'login (list *toppath* megatest-version run-id *my-client-signature*))) - )) + (else + (debug:print-error 0 *default-log-port* "(4) Transport [" *transport-type* + "] specified for run-id [" run-id + "] is not implemented in rmt:send-receive. Cannot proceed.") + (exit 1)))) ;; hand off a call to one of the db:queries statements ;; added run-id to make looking up the correct db possible ;; (define (rmt:general-call stmtname run-id . params) Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -72,11 +72,11 @@ "http")))) (set! *transport-type* ttype) ttype)) ;; Get the transport -- DO NOT call this from client code. In client code, this is run-id sensitive and not a global - +;; For code communicating with existing run-id with a server, use: (rmt:run-id->transport-type run-id) (define (server:get-transport) (if *transport-type* *transport-type* (server:set-transport))) @@ -194,18 +194,20 @@ ;; note: client:start will set *runremote*. this needs to be changed ;; also, client:start will login to the server, also need to change that. ;; ;; client:start returns #t if login was successful. ;; - (let ((res (case *transport-type* + (let* ((transport-type (rmt:run-id->transport-type run-id)) + (res (case transport-type ((http)(server:ping-server run-id (tasks:hostinfo-get-interface server) (tasks:hostinfo-get-port server))) - ;; ((nmsg)(nmsg-transport:ping (tasks:hostinfo-get-interface server) - ;; (tasks:hostinfo-get-port server) - ;; timeout: 2)) - ))) + (else + (debug:print-error 0 *default-log-port* "(5) Transport [" transport-type + "] specified for run-id [" run-id + "] is not implemented in rmt:send-receive. Cannot proceed.") + (exit 1))))) ;; if the server didn't respond we must remove the record (if res #t (begin (debug:print-info 0 *default-log-port* "server at " server " not responding, removing record") Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -337,10 +337,13 @@ ;; BB> bb opinion - want to push responsibility into api (encapsulation), like waiting if db is busy and finding the db handle in the first place. why should the caller need to be concerned?? If my opinion carries, we'll remove the bb- and make other needful adjustments. (define (bb-mdb-inserter mdb-expecting-proc mdbless-args) (let ((mdb (db:delay-if-busy (tasks:open-db)))) (apply mdb-expecting-proc (cons mdb mdbless-args)))) +(define (tasks:bb-server-force-clean-run-record . args) + (bb-mdb-inserter tasks:server-force-clean-run-record args)) + (define (tasks:bb-server-lock-slot . args) (bb-mdb-inserter tasks:server-lock-slot args)) (define (tasks:bb-server-set-interface-port . args) (bb-mdb-inserter tasks:server-set-interface-port args))