Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -101,12 +101,10 @@ (paramsj ($ 'params)) (params (rmt:json-str->dat paramsj)) (res (api:execute-requests db cmd params))) ;; This can be here but needs controls to ensure it doesn't run more than every 4 seconds - (db:sync-to *inmemdb* *db*) - (rmt:dat->json-str (if (or (string? res) (list? res) (number? res) (boolean? res)) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -211,11 +211,12 @@ (sqlite3:finalize! rgetstmt) (sqlite3:finalize! rputstmt)) (if (> rrecchgd 0) (debug:print 0 "synced " rrecchgd " changed records in runs table")) (if (> trecchgd 0) (debug:print 0 "synced " trecchgd " changed records in tests table")) - (if (> tmrecchgd 0) (debug:print 0 "sync'd " tmrecchgd " changed records in test_meta table")))) + (if (> tmrecchgd 0) (debug:print 0 "sync'd " tmrecchgd " changed records in test_meta table")) + (+ rrecchgd trecchgd tmrecchgd))) (define (db:sync-back) (db:sync-to *inmemdb* *db*)) ;; keeping it around for debugging purposes only @@ -892,11 +893,11 @@ ;; use (get-value-by-header (db:get-header runinfo)(db:get-row runinfo)) (define (db:get-run-info db run-id) ;;(if (hash-table-ref/default *run-info-cache* run-id #f) ;; (hash-table-ref *run-info-cache* run-id) - (let* ((res #f) + (let* ((res (vector #f #f #f #f)) (keys (db:get-keys db)) (remfields (list "id" "runname" "state" "status" "owner" "event_time")) (header (append keys remfields)) (keystr (conc (keys->keystr keys) "," (string-intersperse remfields ",")))) Index: http-transport.scm ================================================================== --- http-transport.scm +++ http-transport.scm @@ -83,11 +83,10 @@ (if (and (config-lookup *configdat* "server" "port") (string->number (config-lookup *configdat* "server" "port"))) (string->number (config-lookup *configdat* "server" "port")) (+ 5000 (random 1001))))) (link-tree-path (config-lookup *configdat* "setup" "linktree"))) - (set! *cache-on* #t) (root-path (if link-tree-path link-tree-path (current-directory))) ;; WARNING: SECURITY HOLE. FIX ASAP! (handle-directory spiffy-directory-listing) ;; http-transport:handle-directory) ;; simple-directory-handler) @@ -94,14 +93,10 @@ ;; Setup the web server and a /ctrl interface ;; (vhost-map `(((* any) . ,(lambda (continue) ;; open the db on the first call ;; 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))) @@ -510,10 +505,16 @@ (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"))) + (set! *cache-on* #t) + (set! *db* (open-db)) + (set! *inmemdb* (open-in-mem-db)) + (set! db *inmemdb*) + (db:sync-to *db* *inmemdb*) + (thread-start! th2) (thread-start! th3) ;; (thread-start! th1) (set! *didsomething* #t) (thread-join! th2)) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -121,11 +121,14 @@ (setenv key val) (debug:print 0 "ERROR: Malformed environment variable definition: var=" var ", val=" val)))) (if (not (get-environment-variable "MT_TARGET"))(setenv "MT_TARGET" target)) (alist->env-vars (hash-table-ref/default *configdat* "env-override" '())) ;; Lets use this as an opportunity to put MT_RUNNAME in the environment - (setenv "MT_RUNNAME" (if inrunname inrunname (rmt:get-run-name-from-id run-id))) + (let ((runname (if inrunname inrunname (rmt:get-run-name-from-id run-id)))) + (if runname + (setenv "MT_RUNNAME" runname) + (debug:print 0 "ERROR: no value for runname for id " run-id))) (setenv "MT_RUN_AREA_HOME" *toppath*))) (define (set-item-env-vars itemdat) (for-each (lambda (item) (debug:print 2 "setenv " (car item) " " (cadr item)) Index: tests/unittests/server.scm ================================================================== --- tests/unittests/server.scm +++ tests/unittests/server.scm @@ -41,10 +41,18 @@ (define *keys* (keys:config-get-fields *configdat*)) (define *keyvals* (keys:target->keyval *keys* "a/b/c")) (test #f #t (string? (car *runremote*))) (test #f '(#t "successful login") (rmt:login)) ;; *runremote* *toppath* *my-client-signature*))) + +(define inmem (open-in-mem-db)) +(define (inmem-test t b) + (test "inmem sync to" t (db:sync-to *db* inmem)) + (test "inmem sync back" b (db:sync-to inmem *db*))) + +(inmem-test 0 0) + (test #f #f (rmt:get-test-info-by-id 99)) ;; get non-existant test ;; RUNS (test #f 1 (rmt:register-run *keyvals* "firstrun" "new" "n/a" (current-user-name))) (test "get run info" "firstrun" (let ((rinfo (rmt:get-run-info 1))) @@ -54,10 +62,12 @@ ;; TESTS (test "get tests (no data)" '() (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f)) (test "register test" #t (rmt:general-call 'register-test 1 "test1" "")) (test "get tests (some data)" 1 (length (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f))) (test "get test id" 1 (rmt:get-test-id 1 "test1" "")) + +(inmem-test 1 1) (test "get test id from main" 1 (db:get-test-id *db* 1 "test1" "")) (test "get keys" #t (list? (rmt:get-keys))) (test "set comment" #t (begin (rmt:general-call 'set-test-comment "this is a comment" 1) #t)) (test "get comment" "this is a comment" (let ((trec (rmt:get-test-info-by-id 1))) @@ -69,13 +79,13 @@ (data (vector-ref runs 1))) (and (list? header) (list? data) (vector? (car data))))) -;; (test "sync back" #t (begin (rmt:sync-back) #t)) +(inmem-test 1 1) ;;====================================================================== ;; D B ;;====================================================================== (test #f '(#t "exit process started") (rmt:kill-server)) ;; *toppath* *my-client-signature* #f)))