Index: client.scm ================================================================== --- client.scm +++ client.scm @@ -56,93 +56,93 @@ ((http) (rmt:login-no-auto-client-setup server-info run-id)) (else (rpc:login-no-auto-client-setup server-info run-id)))) (define (client:setup run-id #!key (remaining-tries 10) (failed-connects 0)) (case (server:get-transport) - ((rpc) (client:setup-rpc run-id)) + ((rpc) (rpc-transport:client-setup run-id)) ;;(client:setup-rpc run-id)) ((http)(client:setup-http run-id)) - (else (client:setup-rpc run-id)))) - -(define (client:setup-rpc run-id) - (debug:print 0 "INFO: client:setup remaining-tries=" remaining-tries) - (if (<= remaining-tries 0) - (begin - (debug:print 0 "ERROR: failed to start or connect to server for run-id " run-id) - (exit 1)) - (let ((host-info (hash-table-ref/default *runremote* run-id #f))) - (debug:print-info 0 "client:setup host-info=" host-info ", remaining-tries=" remaining-tries) - (if host-info - (let* ((iface (car host-info)) - (port (cadr host-info)) - (start-res (client:connect iface port)) - ;; (ping-res (server:ping-server run-id iface port)) - (ping-res (client:login-no-auto-setup start-res run-id))) - (if ping-res ;; sucessful login? - (begin - (hash-table-set! *runremote* run-id start-res) - start-res) ;; return the server info - (if (member remaining-tries '(3 4 6)) - (begin ;; login failed - (debug:print 25 "INFO: client:setup start-res=" start-res ", run-id=" run-id ", server-dat=" host-info) - (hash-table-delete! *runremote* run-id) - (open-run-close tasks:server-force-clean-run-record - tasks:open-db - run-id - (car host-info) - (cadr host-info) - " client:setup (host-info=#t)") - (thread-sleep! 5) - (client:setup run-id remaining-tries: 10)) ;; (- remaining-tries 1))) - (begin - (debug:print 25 "INFO: client:setup failed to connect, start-res=" start-res ", run-id=" run-id ", host-info=" host-info) - (thread-sleep! 5) - (client:setup run-id remaining-tries: (- remaining-tries 1)))))) - ;; YUK: rename server-dat here - (let* ((server-dat (open-run-close tasks:get-server tasks:open-db run-id))) - (debug:print-info 0 "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries) - (if server-dat - (let* ((iface (tasks:hostinfo-get-interface server-dat)) - (port (tasks:hostinfo-get-port server-dat)) - (start-res (http-transport:client-connect iface port)) - ;; (ping-res (server:ping-server run-id iface port)) - (ping-res (rmt:login-no-auto-client-setup start-res run-id))) - (if start-res - (begin - (hash-table-set! *runremote* run-id start-res) - start-res) - (if (member remaining-tries '(2 5)) - (begin ;; login failed - (debug:print 25 "INFO: client:setup start-res=" start-res ", run-id=" run-id ", server-dat=" server-dat) - (hash-table-delete! *runremote* run-id) - (open-run-close tasks:server-force-clean-run-record - tasks:open-db - run-id - (tasks:hostinfo-get-interface server-dat) - (tasks:hostinfo-get-port server-dat) - " client:setup (server-dat = #t)") - (thread-sleep! 2) - (server:try-running run-id) - (thread-sleep! 10) ;; give server a little time to start up - (client:setup run-id remaining-tries: 10)) ;; (- remaining-tries 1))) - (begin - (debug:print 25 "INFO: client:setup start-res=" start-res ", run-id=" run-id ", server-dat=" server-dat) - (thread-sleep! 5) - (client:setup run-id remaining-tries: (- remaining-tries 1)))))) - (begin ;; no server registered - (if (eq? remaining-tries 2) - (begin - ;; (open-run-close tasks:server-clean-out-old-records-for-run-id tasks:open-db run-id " client:setup (server-dat=#f)") - (client:setup run-id remaining-tries: 10)) - (begin - (thread-sleep! 2) - (debug:print 25 "INFO: client:setup start-res (not defined here), run-id=" run-id ", server-dat=" server-dat) - (if (< (open-run-close tasks:num-in-available-state tasks:open-db run-id) 3) - (begin - ;; (open-run-close tasks:server-clean-out-old-records-for-run-id tasks:open-db run-id " client:setup (server-dat=#f)") - (server:try-running run-id))) - (thread-sleep! 10) ;; give server a little time to start up - (client:setup run-id remaining-tries: (- remaining-tries 1))))))))))) + (else (rpc-transport:client-setup run-id)))) ;; (client:setup-rpc run-id)))) + +;; (define (client:setup-rpc run-id) +;; (debug:print 0 "INFO: client:setup remaining-tries=" remaining-tries) +;; (if (<= remaining-tries 0) +;; (begin +;; (debug:print 0 "ERROR: failed to start or connect to server for run-id " run-id) +;; (exit 1)) +;; (let ((host-info (hash-table-ref/default *runremote* run-id #f))) +;; (debug:print-info 0 "client:setup host-info=" host-info ", remaining-tries=" remaining-tries) +;; (if host-info +;; (let* ((iface (car host-info)) +;; (port (cadr host-info)) +;; (start-res (client:connect iface port)) +;; ;; (ping-res (server:ping-server run-id iface port)) +;; (ping-res (client:login-no-auto-setup start-res run-id))) +;; (if ping-res ;; sucessful login? +;; (begin +;; (hash-table-set! *runremote* run-id start-res) +;; start-res) ;; return the server info +;; (if (member remaining-tries '(3 4 6)) +;; (begin ;; login failed +;; (debug:print 25 "INFO: client:setup start-res=" start-res ", run-id=" run-id ", server-dat=" host-info) +;; (hash-table-delete! *runremote* run-id) +;; (open-run-close tasks:server-force-clean-run-record +;; tasks:open-db +;; run-id +;; (car host-info) +;; (cadr host-info) +;; " client:setup (host-info=#t)") +;; (thread-sleep! 5) +;; (client:setup run-id remaining-tries: 10)) ;; (- remaining-tries 1))) +;; (begin +;; (debug:print 25 "INFO: client:setup failed to connect, start-res=" start-res ", run-id=" run-id ", host-info=" host-info) +;; (thread-sleep! 5) +;; (client:setup run-id remaining-tries: (- remaining-tries 1)))))) +;; ;; YUK: rename server-dat here +;; (let* ((server-dat (open-run-close tasks:get-server tasks:open-db run-id))) +;; (debug:print-info 0 "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries) +;; (if server-dat +;; (let* ((iface (tasks:hostinfo-get-interface server-dat)) +;; (port (tasks:hostinfo-get-port server-dat)) +;; (start-res (http-transport:client-connect iface port)) +;; ;; (ping-res (server:ping-server run-id iface port)) +;; (ping-res (rmt:login-no-auto-client-setup start-res run-id))) +;; (if start-res +;; (begin +;; (hash-table-set! *runremote* run-id start-res) +;; start-res) +;; (if (member remaining-tries '(2 5)) +;; (begin ;; login failed +;; (debug:print 25 "INFO: client:setup start-res=" start-res ", run-id=" run-id ", server-dat=" server-dat) +;; (hash-table-delete! *runremote* run-id) +;; (open-run-close tasks:server-force-clean-run-record +;; tasks:open-db +;; run-id +;; (tasks:hostinfo-get-interface server-dat) +;; (tasks:hostinfo-get-port server-dat) +;; " client:setup (server-dat = #t)") +;; (thread-sleep! 2) +;; (server:try-running run-id) +;; (thread-sleep! 10) ;; give server a little time to start up +;; (client:setup run-id remaining-tries: 10)) ;; (- remaining-tries 1))) +;; (begin +;; (debug:print 25 "INFO: client:setup start-res=" start-res ", run-id=" run-id ", server-dat=" server-dat) +;; (thread-sleep! 5) +;; (client:setup run-id remaining-tries: (- remaining-tries 1)))))) +;; (begin ;; no server registered +;; (if (eq? remaining-tries 2) +;; (begin +;; ;; (open-run-close tasks:server-clean-out-old-records-for-run-id tasks:open-db run-id " client:setup (server-dat=#f)") +;; (client:setup run-id remaining-tries: 10)) +;; (begin +;; (thread-sleep! 2) +;; (debug:print 25 "INFO: client:setup start-res (not defined here), run-id=" run-id ", server-dat=" server-dat) +;; (if (< (open-run-close tasks:num-in-available-state tasks:open-db run-id) 3) +;; (begin +;; ;; (open-run-close tasks:server-clean-out-old-records-for-run-id tasks:open-db run-id " client:setup (server-dat=#f)") +;; (server:try-running run-id))) +;; (thread-sleep! 10) ;; give server a little time to start up +;; (client:setup run-id remaining-tries: (- remaining-tries 1))))))))))) ;; Do all the connection work, look up the transport type and set up the ;; connection if required. ;; ;; There are two scenarios. Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -366,11 +366,11 @@ (debug:print 0 "ERROR: argument to -ping is host:port, got " (args:get-arg "-ping")) (print "ERROR: bad host:port") (exit 1)) (case transport ((http)(http:ping run-id host-port)) - ((rpc) (rpc:ping run-id host-port)) + ((rpc) (rpc:ping run-id (car host-port)(cadr host-port))) (else (debug:print 0 "ERROR: No transport set")(exit))))))) ;;====================================================================== ;; Start the server - can be done in conjunction with -runall or -runtests (one day...) ;; we start the server if not running else start the client thread Index: rpc-transport.scm ================================================================== --- rpc-transport.scm +++ rpc-transport.scm @@ -209,41 +209,71 @@ (rpc-transport:find-free-port-and-open (+ port 1))) (rpc:default-server-port port) (tcp-read-timeout 240000) (tcp-listen (rpc:default-server-port) 10000))) -(define (rpc:ping run-id host-port) - #f) +(define (rpc:ping run-id host port) + ((rpc:procedure 'server:login host port) *toppath*)) -(define (rpc-transport:client-setup) +(define (rpc-transport:client-setup run-id #!key (remtries 10)) (if *runremote* (begin (debug:print 0 "ERROR: Attempt to connect to server but already connected") #f) - (let* ((hostinfo (open-run-close db:get-var #f "SERVER")) - (hostdat (if hostinfo (string-split hostinfo ":") #f)) - (host (if hostinfo (car hostdat) #f)) - (port (if (and hostinfo (> (length hostdat) 1))(cadr hostdat) #f))) - (if (and port - (string->number port)) - (let ((portn (string->number port))) - (debug:print-info 2 "Setting up to connect to host " host ":" port) - (handle-exceptions - exn - (begin - (debug:print 0 "ERROR: Failed to open a connection to the server at host: " host " port: " port) - (debug:print 0 " EXCEPTION: " ((condition-property-accessor 'exn 'message) exn)) - ;; (open-run-close - ;; (lambda (db . param) - ;; (sqlite3:execute db "DELETE FROM metadat WHERE var='SERVER'")) - ;; #f) - (set! *runremote* #f)) - (if (and (not (args:get-arg "-server")) ;; no point in the server using the server using the server - ((rpc:procedure 'server:login host portn) *toppath*)) - (begin - (debug:print-info 2 "Logged in and connected to " host ":" port) - (set! *runremote* (vector host portn))) - (begin - (debug:print-info 2 "Failed to login or connect to " host ":" port) - (set! *runremote* #f))))) - (debug:print-info 2 "no server available"))))) + (let* ((host-info (hash-table-ref/default *runremote* run-id #f))) ;; (open-run-close db:get-var #f "SERVER")) + (if host-info + (let ((iface (car host-info)) + (port (cadr host-info)) + (ping-res (rpc:ping run-id host port))) + (if ping-res + (let ((server-dat (list iface port #f #f #f))) + (hash-table-set! *runremote* run-id server-dat) + server-dat) + (begin + (server:try-running run-id) + (thread-sleep! 2) + (rpc-transport:client-setup run-id (- remtries 1))))) + (let* ((server-db-info (open-run-close tasks:get-server tasks:open-db run-id))) + (debug:print-info 0 "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries) + (if server-db-info + (let* ((iface (tasks:hostinfo-get-interface server-db-info)) + (port (tasks:hostinfo-get-port server-db-info)) + (server-dat (list iface port #f #f #f)) + (ping-res (rpc:ping run-id iface port))) + (if start-res + (begin + (hash-table-set! *runremote* run-id server-dat) + server-dat) + (begin + (server:try-running run-id) + (thread-sleep! 2) + (rpc-transport:client-setup run-id (- remtries 1))))) + (begin + (server:try-running run-id) + (thread-sleep! 2) + (rpc-transport:client-setup run-id (- remtries 1))))))))) +;; +;; (port (if (and hostinfo (> (length hostdat) 1))(cadr hostdat) #f))) +;; (if (and port +;; (string->number port)) +;; (let ((portn (string->number port))) +;; (debug:print-info 2 "Setting up to connect to host " host ":" port) +;; (handle-exceptions +;; exn +;; (begin +;; (debug:print 0 "ERROR: Failed to open a connection to the server at host: " host " port: " port) +;; (debug:print 0 " EXCEPTION: " ((condition-property-accessor 'exn 'message) exn)) +;; ;; (open-run-close +;; ;; (lambda (db . param) +;; ;; (sqlite3:execute db "DELETE FROM metadat WHERE var='SERVER'")) +;; ;; #f) +;; (set! *runremote* #f)) +;; (if (and (not (args:get-arg "-server")) ;; no point in the server using the server using the server +;; ((rpc:procedure 'server:login host portn) *toppath*)) +;; (begin +;; (debug:print-info 2 "Logged in and connected to " host ":" port) +;; (set! *runremote* (vector host portn))) +;; (begin +;; (debug:print-info 2 "Failed to login or connect to " host ":" port) +;; (set! *runremote* #f))))) +;; (debug:print-info 2 "no server available")))))