Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -40,11 +40,11 @@ (define *globalexitstatus* 0) ;; attempt to work around possible thread issues (define *passnum* 0) ;; when running track calls to run-tests or similar ;; SERVER (define *my-client-signature* #f) -(define *transport-type* 'fs) +(define *transport-type* #f) (define *megatest-db* #f) (define *rpc:listener* #f) ;; if set up for server communication this will hold the tcp port (define *runremote* #f) ;; if set up for server communication this will hold (define *last-db-access* (current-seconds)) ;; update when db is accessed via server (define *max-cache-size* 0) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -1160,11 +1160,11 @@ (let* ((client-sig (server:get-client-signature)) (query-sig (message-digest-string (md5-primitive) (conc qtype immediate params))) (zdat (db:obj->string (vector client-sig qtype immediate query-sig params (current-seconds))))) ;; (with-output-to-string (lambda ()(serialize params)))) (debug:print-info 11 "zdat=" zdat) (let* ((res #f) - (rawdat (server:client-send-receive serverdat zdat)) + (rawdat (http-transport:client-send-receive serverdat zdat)) (tmp #f)) (debug:print-info 11 "Sent " zdat ", received " rawdat) (set! tmp (db:string->obj rawdat)) (vector-ref tmp 2)))) ((zmq) Index: http-transport.scm ================================================================== --- http-transport.scm +++ http-transport.scm @@ -107,46 +107,10 @@ (else (continue)))))))) (http-transport:try-start-server ipaddrstr start-port) ;; lite3:finalize! db))) )) - - -;; (define (http-transport:main-loop) -;; (print "INFO: Exectuing main server loop") -;; (access-log "megatest-http.log") -;; (server-bind-address #f) -;; (define-page (main-page-path) -;; (lambda () -;; (let ((dat ($ "dat"))) -;; ;; (with-request-variables (dat) -;; (debug:print-info 12 "Got dat=" dat) -;; (let* ((packet (db:string->obj dat)) -;; (qtype (cdb:packet-get-qtype packet))) -;; (debug:print-info 12 "server=> received packet=" packet) -;; (if (not (member qtype '(sync ping))) -;; (begin -;; (mutex-lock! *heartbeat-mutex*) -;; (set! *last-db-access* (current-seconds)) -;; (mutex-unlock! *heartbeat-mutex*))) -;; (let ((res (open-run-close db:process-queue-item open-db packet))) -;; (debug:print-info 11 "Return value from db:process-queue-item is " res) -;; res)))))) - -;;; (use spiffy uri-common intarweb) -;;; -;;; (root-path "/var/www") -;;; -;;; (vhost-map `(((* any) . ,(lambda (continue) -;;; (if (equal? (uri-path (request-uri (current-request))) -;;; '(/ "hey")) -;;; (send-response body: "hey there!\n" -;;; headers: '((content-type text/plain))) -;;; (continue)))))) -;;; -;;; (start-server port: 12345) - ;; This is recursively run by http-transport:run until sucessful ;; (define (http-transport:try-start-server ipaddrstr portnum) (handle-exceptions exn Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -338,11 +338,11 @@ (exit))) ;; if not list or kill then start a client (if appropriate) (if (or (args-defined? "-h" "-version" "-gen-megatest-area" "-gen-megatest-test") (eq? (length (hash-table-keys args:arg-hash)) 0)) (debug:print-info 1 "Server connection not needed") - + ;; ok, so lets connect to the server (server:client-launch))) ;;====================================================================== ;; Weird special calls that need to run *after* the server has started? ;;====================================================================== Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -178,18 +178,19 @@ (if (not *toppath*) (if (not (setup-for-run)) (begin (debug:print 0 "ERROR: failed to find megatest.config, exiting") (exit)))) + (debug:print-info 11 "*transport-type* is " *transport-type*) (let* ((hostinfo (if (not *transport-type*) ;; If we dont' already have transport type set then figure it out (open-run-close tasks:get-best-server tasks:open-db) #f))) ;; if have hostinfo then extract the transport type ;; else fall back to fs - ;; + (debug:print-info 11 "CLIENT SETUP, hostinfo=" hostinfo) (set! *transport-type* (if hostinfo - (string->vector (tasks:hostinfo-get-transport hostinfo)) + (string->symbol (tasks:hostinfo-get-transport hostinfo)) 'fs)) (debug:print-info 1 "Using transport type of " *transport-type* (if hostinfo (conc " to connect to " hostinfo) "")) (case *transport-type* ((fs)(if (not *megatest-db*)(set! *megatest-db* (open-db)))) ((http) Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -85,17 +85,18 @@ ;;====================================================================== ;; Server and client management ;;====================================================================== -;; make-vector-record tasks hostinfo id interface port pubport transport -(define (make-tasks:hostinfo)(make-vector 5)) +;; make-vector-record tasks hostinfo id interface port pubport transport pid hostname (define (tasks:hostinfo-get-id vec) (vector-ref vec 0)) (define (tasks:hostinfo-get-interface vec) (vector-ref vec 1)) (define (tasks:hostinfo-get-port vec) (vector-ref vec 2)) (define (tasks:hostinfo-get-pubport vec) (vector-ref vec 3)) (define (tasks:hostinfo-get-transport vec) (vector-ref vec 4)) +(define (tasks:hostinfo-get-pid vec) (vector-ref vec 5)) +(define (tasks:hostinfo-get-hostname vec) (vector-ref vec 6)) ;; state: 'live, 'shutting-down, 'dead (define (tasks:server-register mdb pid interface port priority state transport #!key (pubport -1)) (debug:print-info 11 "tasks:server-register " pid " " interface " " port " " priority " " state) (sqlite3:execute @@ -188,15 +189,15 @@ ;; remove any others. will not necessarily remove all! (define (tasks:get-best-server mdb) (let ((res '()) (best #f)) (sqlite3:for-each-row - (lambda (id hostname interface port pid) - (set! res (cons (list hostname interface port pid id) res)) + (lambda (id interface port pubport transport pid hostname) + (set! res (cons (vector id interface port pubport transport pid hostname) res)) (debug:print-info 2 "Found existing server " hostname ":" port " registered in db")) mdb - "SELECT id,hostname,interface,port,pid FROM servers + "SELECT id,interface,port,pubport,transport,pid,hostname FROM servers WHERE strftime('%s','now')-heartbeat < 10 AND mt_version=? ORDER BY start_time ASC LIMIT 1;" megatest-version) ;; for now we are keeping only one server registered in the db, return #f or first server found (if (null? res) #f (car res))))