Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -14,27 +14,26 @@ (declare (uses db)) ;; These are called by the server on recipt of /api calls (define (api:execute-requests db cmd params) - (debug:print-info 1 "api:execute-requests cmd=" cmd " params=" params) (case (string->symbol cmd) ;; KEYS ((get-key-val-pairs) (apply db:get-key-val-pairs db params)) ;; TESTS ;; json doesn't do vectors, convert to list - ((get-test-info-by-id) (vector->list (apply db:get-test-info-by-id db params))) + ((get-test-info-by-id) (let ((res (apply db:get-test-info-by-id db params))) + (if (vector? res)(vector->list res) res))) ((test-get-rundir-from-test-id) (apply db:test-get-rundir-from-test-id db params)) ((testmeta-get-record) (vector->list (apply db:testmeta-get-record db params))) ((test-set-state-status-by-id) (apply db:test-set-state-status-by-id db params)) ;; RUNS ((get-run-info) (let ((res (apply db:get-run-info db params))) (list (vector-ref res 0) (vector->list (vector-ref res 1))))) ((register-run) (apply db:register-run db params)) - ((login) ;(apply db:login db params) - (debug:print 0 "WOOHOO: Got login") #t) + ((login) (apply db:login db params)) (else (list "ERROR" 0)))) ;; http-server send-response ;; api:process-request Index: client.scm ================================================================== --- client.scm +++ client.scm @@ -35,14 +35,10 @@ (if *my-client-signature* *my-client-signature* (let ((sig (conc (get-host-name) " " (current-process-id)))) (set! *my-client-signature* sig) *my-client-signature*))) -;; client:login serverdat -(define (client:login serverdat) - (cdb:login serverdat *toppath* (client:get-signature))) - ;; Not currently used! But, I think it *should* be used!!! (define (client:logout serverdat) (let ((ok (and (socket? serverdat) (cdb:logout serverdat *toppath* (client:get-signature))))) ok)) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -1748,16 +1748,10 @@ res)))))) (define (cdb:set-verbosity serverdat val) (cdb:client-call serverdat 'set-verbosity #f *default-numtries* val)) -(define (cdb:login serverdat keyval signature) - (cdb:client-call serverdat 'login #t *default-numtries* keyval megatest-version signature)) - -(define (cdb:logout serverdat keyval signature) - (cdb:client-call serverdat 'logout #t *default-numtries* keyval signature)) - (define (cdb:num-clients serverdat) (cdb:client-call serverdat 'numclients #t *default-numtries*)) ;; I think this would be more efficient if executed on client side FIXME??? (define (cdb:test-set-status-state serverdat test-id status state msg) @@ -1957,15 +1951,15 @@ ;; (if (> cache-size *max-cache-size*) ;; (set! *max-cache-size* cache-size))) ;; #t) ;; #f))) -(define (db:login db keyval calling-path calling-version client-signature) +(define (db:login db calling-path calling-version client-signature) (if (and (equal? calling-path *toppath*) (equal? megatest-version calling-version)) (begin - (hash-table-set! *logged-in-clients* client-key (current-seconds)) + (hash-table-set! *logged-in-clients* client-signature (current-seconds)) '(#t "successful login")) ;; path matches - pass! Should vet the caller at this time ... (list #f (conc "Login failed due to mismatch paths: " calling-path ", " *toppath*)))) (define (db:process-write db request-item) (let ((stmt-key (vector-ref request-item 0)) Index: http-transport.scm ================================================================== --- http-transport.scm +++ http-transport.scm @@ -93,18 +93,15 @@ ;; http-transport:handle-directory) ;; simple-directory-handler) ;; Setup the web server and a /ctrl interface ;; (vhost-map `(((* any) . ,(lambda (continue) ;; open the db on the first call - (let loop () - (if (not db) - (if (not (sqlite3:database? *inmemdb*)) - (begin - (debug:print 0 "WARNING: db not ready yet. Waiting for it to be ready") - (thread-sleep! 5) - (loop))) - (set! db *inmemdb*))) ;; (open-db))) + ;; This is were we set up the database connections + (set! *db* (open-db)) + (set! *inmemdb* (open-in-mem-db)) + (set! db *inmemdb*) + (db:sync-to *db* *inmemdb*) (let* (($ (request-vars source: 'both)) (dat ($ 'dat)) (res #f)) (cond ((equal? (uri-path (request-uri (current-request))) @@ -382,12 +379,13 @@ (define (http-transport:client-connect iface port) (let* ((login-res #f) (uri-dat (make-request method: 'POST uri: (uri-reference (conc "http://" iface ":" port "/ctrl")))) (uri-api-dat (make-request method: 'POST uri: (uri-reference (conc "http://" iface ":" port "/api")))) (serverdat (list iface port uri-dat uri-api-dat))) - (set! login-res (client:login serverdat)) - (if (and (not (null? login-res)) + (set! *runremote* serverdat) ;; may or may not be good ... + (set! login-res (rmt:login)) + (if (and (list? login-res) (car login-res)) (begin (debug:print-info 2 "Logged in and connected to " iface ":" port) (set! *runremote* serverdat) serverdat) @@ -514,14 +512,10 @@ (if (args:get-arg "-server") (args:get-arg "-server") "-"))) "Server run")) (th3 (make-thread http-transport:keep-running "Keep running"))) ;; (th1 (make-thread server:write-queue-handler "write queue"))) - ;; This is were we set up the database connections - (set! *db* (open-db)) - (set! *inmemdb* (open-in-mem-db)) - (db:sync-to *db* *inmemdb*) (thread-start! th2) (thread-start! th3) ;; (thread-start! th1) (set! *didsomething* #t) (thread-join! th2)) Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -79,12 +79,14 @@ ;;====================================================================== ;; T E S T S ;;====================================================================== (define (rmt:get-test-info-by-id test-id) - (list->vector - (rmt:send-receive 'get-test-info-by-id (list test-id)))) + (let ((res (rmt:send-receive 'get-test-info-by-id (list test-id)))) + (if (list? res) + (list->vector res) + res))) (define (rmt:test-get-rundir-from-test-id test-id) (rmt:send-receive 'test-get-rundir-from-test-id (list test-id))) (define (rmt:open-test-db-by-test-id test-id #!key (work-area #f)) Index: tests/unittests/server.scm ================================================================== --- tests/unittests/server.scm +++ tests/unittests/server.scm @@ -22,11 +22,11 @@ ;; (test "launch server" #t (let ((pid (process-fork (lambda () ;; ;; (daemon:ize) ;; (server:launch 'http))))) ;; (set! server-pid pid) ;; (number? pid))) -(system "megatest -server - -debug 2 &") +(system "megatest -server - &") (thread-sleep! 3) ;; need to wait for server to start. Yes, a better way is needed. (test "get-best-server" #t (begin (client:launch) (let ((dat (open-run-close tasks:get-best-server tasks:open-db))) @@ -34,13 +34,13 @@ ;; (print "dat: " dat) ;; (set! *runremote* (list (vector-ref dat 1)(vector-ref dat 2) #f)) ;; host ip pullport pubport ;; (and (string? (car *runremote*)) ;; (number? (cadr *runremote*))))) -(test #f #t (string? (car *runremote*))) -(test #f #t (rmt:login)) ;; *runremote* *toppath* *my-client-signature*))) -(test #f #f (rmt:get-test-info-by-id 99)) +(test #f #t (string? (car *runremote*))) +(test #f '(#t "successful login") (rmt:login)) ;; *runremote* *toppath* *my-client-signature*))) +(test #f #f (rmt:get-test-info-by-id 99)) ;; ;; (set! *verbosity* 20) ;; (test #f *verbosity* (cadr (cdb:set-verbosity *runremote* *verbosity*))) ;; (test #f #f (cdb:roll-up-pass-fail-counts *runremote* 1 "test1" "" "PASS")) ;; ;; (set! *verbosity* 1)