Index: client.scm ================================================================== --- client.scm +++ client.scm @@ -51,11 +51,11 @@ ;; 2. We are a run tests, list runs or other interactive process and we must figure out ;; *transport-type* and *runremote* from the monitor.db ;; ;; client:setup ;; -;; lookup_server, +;; lookup_server, need to remove *runremote* stuff ;; (define (client:setup run-id #!key (remaining-tries 3)) (if (not *toppath*) (if (not (setup-for-run)) (begin @@ -85,25 +85,27 @@ (exit 1))) (begin (hash-table-set! *runremote* run-id hostinfo) (debug:print-info 11 "CLIENT SETUP, hostinfo=" hostinfo) (debug:print-info 11 "Using transport type of " transport (if hostinfo (conc " to connect to " hostinfo) "")) - (case *transport-type* - ;; ((fs)(if (not *megatest-db*)(set! *megatest-db* (open-db)))) - ((http) - ;; this saves the hostinfo in the *runremote* hash and returns it - (http-transport:client-connect run-id - (tasks:hostinfo-get-interface hostinfo) - (tasks:hostinfo-get-port hostinfo))) - ((zmq) - (zmq-transport:client-connect (tasks:hostinfo-get-interface hostinfo) - (tasks:hostinfo-get-port hostinfo) - (tasks:hostinfo-get-pubport hostinfo))) - (else ;; default to fs - (debug:print 0 "ERROR: unrecognised transport type " *transport-type* " exiting now.") - (exit))))))))) - ;; (pop-directory))) + (client:start run-id transport server-info))))))) + +(define (client:start run-id transport server-info) + (case transport + ;; ((fs)(if (not *megatest-db*)(set! *megatest-db* (open-db)))) + ((http) + ;; this saves the server-info in the *runremote* hash and returns it + (http-transport:client-connect run-id + (tasks:hostinfo-get-interface server-info) + (tasks:hostinfo-get-port server-info))) + ((zmq) + (zmq-transport:client-connect (tasks:hostinfo-get-interface server-info) + (tasks:hostinfo-get-port server-info) + (tasks:hostinfo-get-pubport server-info))) + (else ;; default to fs + (debug:print 0 "ERROR: unrecognised transport type " transport ) + #f))) ;; client:signal-handler (define (client:signal-handler signum) (handle-exceptions exn Index: http-transport.scm ================================================================== --- http-transport.scm +++ http-transport.scm @@ -392,11 +392,11 @@ (debug:print-info 2 "Logged in and connected to " iface ":" port) (hash-table-set! *runremote* run-id serverdat) serverdat) (begin (debug:print-info 0 "ERROR: Failed to login or connect to " iface ":" port) - (exit 1))))) + #f)))) ;; run http-transport:keep-running in a parallel thread to monitor that the db is being ;; used and to shutdown after sometime if it is not. ;; (define (http-transport:keep-running server-id) @@ -522,49 +522,37 @@ ;; ;; start_server? ;; (define (http-transport:launch run-id) (set! *run-id* run-id) - (if (not *toppath*) - (if (not (setup-for-run)) - (begin - (debug:print 0 "ERROR: cannot find megatest.config, exiting") - (exit)))) - (debug:print-info 2 "Starting the standalone server") (if (args:get-arg "-daemonize") (daemon:ize)) ;; ;; set_available ;; (let ((server-id (open-run-close tasks:server-lock-slot tasks:open-db run-id))) (if (not server-id) - ;; - ;; remove_dead_entry? - ;; (begin (debug:print-info 2 "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue") (open-run-close tasks:server-delete-records-for-this-pid tasks:open-db)) - (if *toppath* - (let* ((th2 (make-thread (lambda () - (http-transport:run - (if (args:get-arg "-server") - (args:get-arg "-server") - "-") - run-id - server-id)) "Server run")) - (th3 (make-thread (lambda () - (http-transport:keep-running server-id)) - "Keep running"))) - ;; Database connection - (set! *inmemdb* (db:setup run-id)) - (thread-start! th2) - (thread-start! th3) - (set! *didsomething* #t) - (thread-join! th2)) - (debug:print 0 "ERROR: Failed to setup for megatest"))) - ;; (sdb:qry 'finalize) - (exit))) + (let* ((th2 (make-thread (lambda () + (http-transport:run + (if (args:get-arg "-server") + (args:get-arg "-server") + "-") + run-id + server-id)) "Server run")) + (th3 (make-thread (lambda () + (http-transport:keep-running server-id)) + "Keep running"))) + ;; Database connection + (set! *inmemdb* (db:setup run-id)) + (thread-start! th2) + (thread-start! th3) + (set! *didsomething* #t) + (thread-join! th2) + (exit))))) (define (http-transport:server-signal-handler signum) (handle-exceptions exn (debug:print " ... exiting ...") Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -46,24 +46,20 @@ ;; all routes though here end in exit ... ;; ;; start_server ;; (define (server:launch transport run-id) - (if (not *toppath*) - (if (not (setup-for-run)) - (begin - (debug:print 0 "ERROR: cannot find megatest.config, exiting") - (exit)))) - (debug:print-info 2 "Starting server using " transport " transport") - (set! *transport-type* transport) - (case transport - ;; ((fs) (exit)) ;; there is no "fs" server transport - ((fs http) (http-transport:launch run-id)) - ((zmq) (zmq-transport:launch run-id)) - (else - (debug:print "WARNING: unrecognised transport " transport) - (exit)))) + (let ((server-running (server:check-if-running run-id transport))) + (if server-running + ;; a server is already running + (exit) + (case transport + ((http) (http-transport:launch run-id)) + ((zmq) (zmq-transport:launch run-id)) + (else + (debug:print "WARNING: unrecognised transport " transport) + (exit)))))) ;;====================================================================== ;; Q U E U E M A N A G E M E N T ;;====================================================================== @@ -148,5 +144,14 @@ (loop (open-run-close tasks:get-server tasks:open-db run-id) (+ trycount 1)) (debug:print 0 "WARNING: Couldn't start or find a server."))) (debug:print 2 "INFO: Server(s) running " servers) ))) + +(define (server:check-if-running run-id transport) + (let loop ((server (open-run-close tasks:get-server tasks:open-db run-id)) + (trycount 0)) + (if server + ;; 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 run-id transport server) + #f)))