Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -601,23 +601,23 @@ ;;====================================================================== ;; T E S T S ;;====================================================================== -(define (db:tests-register-test db run-id test-name item-path) - (debug:print 4 "INFO: db:tests-register-test db=" db ", run-id=" run-id ", test-name=" test-name ", item-path=\"" item-path "\"") - (let ((item-paths (if (equal? item-path "") - (list item-path) - (list item-path "")))) - (for-each - (lambda (pth) - (sqlite3:execute db "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path,state,status) VALUES (?,?,strftime('%s','now'),?,'NOT_STARTED','n/a');" - run-id - test-name - pth)) - item-paths) - #f)) +;; (define (db:tests-register-test db run-id test-name item-path) +;; (debug:print 4 "INFO: db:tests-register-test db=" db ", run-id=" run-id ", test-name=" test-name ", item-path=\"" item-path "\"") +;; (let ((item-paths (if (equal? item-path "") +;; (list item-path) +;; (list item-path "")))) +;; (for-each +;; (lambda (pth) +;; (sqlite3:execute db "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path,state,status) VALUES (?,?,strftime('%s','now'),?,'NOT_STARTED','n/a');" +;; run-id +;; test-name +;; pth)) +;; item-paths) +;; #f)) ;; states and statuses are lists, turn them into ("PASS","FAIL"...) and use NOT IN ;; i.e. these lists define what to NOT show. ;; states and statuses are required to be lists, empty is ok @@ -726,11 +726,11 @@ (let ((res 0)) (sqlite3:for-each-row (lambda (count) (set! res count)) db - "SELECT count(id) FROM tests WHERE state = 'RUNNING' OR state = 'LAUNCHED' OR state = 'REMOTEHOSTSTART';") + "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART','NOT_STARTED');") res)) (define (db:get-count-tests-running-in-jobgroup db jobgroup) (if (not jobgroup) 0 ;; @@ -1025,24 +1025,25 @@ ;;====================================================================== (define (db:updater) (debug:print 4 "INFO: Starting cache processing") (let loop ((start-time (current-time))) - (thread-sleep! 15) ;; move save time around to minimize regular collisions? + (thread-sleep! 5) ;; move save time around to minimize regular collisions? (db:write-cached-data) (loop start-time))) (define (cdb:test-set-status-state test-id status state msg) (debug:print 4 "INFO: cdb:test-set-status-state test-id=" test-id ", status=" status ", state=" state ", msg=" msg) (mutex-lock! *incoming-mutex*) + (set! *last-db-access* (current-seconds)) (if msg (set! *incoming-data* (cons (vector 'state-status-msg - (current-seconds) + (current-milliseconds) (list state status msg test-id)) *incoming-data*)) (set! *incoming-data* (cons (vector 'state-status - (current-seconds) + (current-milliseconds) (list state status test-id)) ;; run-id test-name item-path minutes cpuload diskfree tmpfree) *incoming-data*))) (mutex-unlock! *incoming-mutex*) (if *cache-on* (debug:print 6 "INFO: *cache-on* is " *cache-on* ", skipping cache write") @@ -1049,12 +1050,13 @@ (db:write-cached-data))) (define (cdb:test-rollup-iterated-pass-fail test-id) (debug:print 4 "INFO: Adding " test-id " for iterated rollup to the queue") (mutex-lock! *incoming-mutex*) + (set! *last-db-access* (current-seconds)) (set! *incoming-data* (cons (vector 'iterated-p/f-rollup - (current-seconds) + (current-milliseconds) (list test-id test-id test-id test-id)) *incoming-data*)) (mutex-unlock! *incoming-mutex*) (if *cache-on* (debug:print 6 "INFO: *cache-on* is " *cache-on* ", skipping cache write") @@ -1061,27 +1063,45 @@ (db:write-cached-data))) (define (cdb:pass-fail-counts test-id fail-count pass-count) (debug:print 4 "INFO: Adding " test-id " for setting pass/fail counts to the queue") (mutex-lock! *incoming-mutex*) + (set! *last-db-access* (current-seconds)) (set! *incoming-data* (cons (vector 'pass-fail-counts - (current-seconds) + (current-milliseconds) (list fail-count pass-count test-id)) *incoming-data*)) (mutex-unlock! *incoming-mutex*) (if *cache-on* (debug:print 6 "INFO: *cache-on* is " *cache-on* ", skipping cache write") (db:write-cached-data))) + +(define (cdb:tests-register-test run-id test-name item-path) + (let ((item-paths (if (equal? item-path "") + (list item-path) + (list item-path "")))) + (debug:print 4 "INFO: Adding " run-id ", " test-name "/" item-path " for setting pass/fail counts to the queue") + (mutex-lock! *incoming-mutex*) + (set! *last-db-access* (current-seconds)) + (set! *incoming-data* (cons (vector 'register-test + (current-milliseconds) + (list run-id test-name item-path)) ;; fail-count pass-count test-id)) + *incoming-data*)) + (mutex-unlock! *incoming-mutex*) + (if *cache-on* + (debug:print 6 "INFO: *cache-on* is " *cache-on* ", skipping cache write") + (db:write-cached-data)))) ;; The queue is a list of vectors where the zeroth slot indicates the type of query to ;; apply and the second slot is the time of the query and the third entry is a list of ;; values to be applied ;; (define (db:write-cached-data) (open-run-close (lambda (db . params) - (let ((state-status-stmt (sqlite3:prepare db "UPDATE tests SET state=?,status=? WHERE id=?;")) + (let ((register-test-stmt (sqlite3:prepare db "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path,state,status) VALUES (?,?,strftime('%s','now'),?,'NOT_STARTED','n/a');")) + (state-status-stmt (sqlite3:prepare db "UPDATE tests SET state=?,status=? WHERE id=?;")) (state-status-msg-stmt (sqlite3:prepare db "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;")) (pass-fail-counts-stmt (sqlite3:prepare db "UPDATE tests SET fail_count=?,pass_count=? WHERE id=?;")) (iterated-rollup-stmt (sqlite3:prepare db "UPDATE tests SET status=CASE WHEN (SELECT fail_count FROM tests WHERE id=?) > 0 THEN 'FAIL' @@ -1111,20 +1131,25 @@ (apply sqlite3:execute state-status-msg-stmt params)) ((iterated-p/f-rollup) (apply sqlite3:execute iterated-rollup-stmt params)) ((pass-fail-counts) (apply sqlite3:execute pass-fail-counts-stmt params)) + ((register-test) + (apply sqlite3:execute register-test-stmt params)) (else (debug:print 0 "ERROR: Queued entry not recognised " entry))))) data))) (sqlite3:finalize! state-status-stmt) (sqlite3:finalize! state-status-msg-stmt) (sqlite3:finalize! iterated-rollup-stmt) (sqlite3:finalize! pass-fail-counts-stmt) - (set! *last-db-access* (current-seconds)) + (sqlite3:finalize! register-test-stmt) + ;; (set! *last-db-access* (current-seconds)) )) #f)) + +(define cdb:flush-queue db:write-cached-data) (define (db:roll-up-pass-fail-counts db run-id test-name item-path status) (if (and (not (equal? item-path "")) (or (equal? status "PASS") (equal? status "WARN") @@ -1612,15 +1637,29 @@ (define (rdb:test-rollup-iterated-pass-fail test-id) (if *runremote* (let ((host (vector-ref *runremote* 0)) (port (vector-ref *runremote* 1))) - (apply (rpc:procedure 'cdb:test-rollup-iterated-pass-fail host port) test-id)) + ((rpc:procedure 'cdb:test-rollup-iterated-pass-fail host port) test-id)) (cdb:test-rollup-iterated-pass-fail test-id))) (define (rdb:pass-fail-counts test-id fail-count pass-count) (if *runremote* (let ((host (vector-ref *runremote* 0)) (port (vector-ref *runremote* 1))) - (apply (rpc:procedure 'cdb:pass-fail-counts host port) test-id fail-count pass-count)) + ((rpc:procedure 'cdb:pass-fail-counts host port) test-id fail-count pass-count)) (cdb:pass-fail-counts test-id fail-count pass-count))) + +(define (rdb:tests-register-test run-id test-name item-path) + (if *runremote* + (let ((host (vector-ref *runremote* 0)) + (port (vector-ref *runremote* 1))) + ((rpc:procedure 'cdb:tests-register-test host port) run-id test-name item-path)) + (cdb:tests-register-test run-id test-name item-path))) + +(define (rdb:flush-queue) + (if *runremote* + (let ((host (vector-ref *runremote* 0)) + (port (vector-ref *runremote* 1))) + ((rpc:procedure 'cdb:flush-queue host port))) + (cdb:flush-queue))) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -340,21 +340,19 @@ ))) ;;====================================================================== ;; Start the server - can be done in conjunction with -runall or -runtests (one day...) ;;====================================================================== -(if (and (args:get-arg "-server") - (not (or (args:get-arg "-runall") - (args:get-arg "-runtests")))) +(if (args:get-arg "-server") (let* ((toppath (setup-for-run)) (db (if toppath (open-db) #f))) (debug:print 0 "INFO: Starting the standalone server") (if db (let* ((host:port (db:get-var db "SERVER")) ;; this doen't support multiple servers BUG!!!! (th2 (server:start db (args:get-arg "-server"))) (th3 (make-thread (lambda () - (server:keep-running db))))) + (server:keep-running db host:port))))) (thread-start! th3) (thread-join! th3)) (debug:print 0 "ERROR: Failed to setup for megatest")))) ;;====================================================================== Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -402,11 +402,11 @@ (debug:print 1 "INFO: Skipping " (tests:testqueue-get-testname test-record) " " item-path " as it doesn't match " item-patts) (thread-sleep! *global-delta*) (if (not (null? tal)) (loop (car tal)(cdr tal) reruns))) ((not (hash-table-ref/default test-registery (runs:make-full-test-name test-name item-path) #f)) - (open-run-close db:tests-register-test #f run-id test-name item-path) + (rdb:tests-register-test run-id test-name item-path) (hash-table-set! test-registery (runs:make-full-test-name test-name item-path) #t) (thread-sleep! *global-delta*) (loop (car newtal)(cdr newtal) reruns)) ((not have-resources) ;; simply try again after waiting a second (thread-sleep! (+ 1 *global-delta*)) @@ -614,11 +614,12 @@ ;; (set! test-id (open-run-close db:get-test-id db run-id test-name item-path)) (if (not test-id) (begin (debug:print 2 "WARN: Test not pre-created? test-name=" test-name ", item-path=" item-path ", run-id=" run-id) - (open-run-close db:tests-register-test db run-id test-name item-path) + (rdb:tests-register-test run-id test-name item-path) + (rdb:flush-queue) (set! test-id (open-run-close db:get-test-id db run-id test-name item-path)))) (debug:print 4 "INFO: test-id=" test-id ", run-id=" run-id ", test-name=" test-name ", item-path=\"" item-path "\"") (set! testdat (open-run-close db:get-test-info-by-id db test-id)))) (set! test-id (db:test-get-id testdat)) (change-directory test-path) @@ -823,12 +824,12 @@ (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (if (args:get-arg "-server") (open-run-close server:start db (args:get-arg "-server")) - (if (not (or (args:get-arg "-runall") ;; runall and runtests are allowed to be servers - (args:get-arg "-runtests"))) + (if (not (or (args:get-arg "-runall") ;; runall and runtests are allowed to be servers + (args:get-arg "-runtests"))) (server:client-setup))) (set! keys (open-run-close db:get-keys db)) ;; have enough to process -target or -reqtarg here (if (args:get-arg "-reqtarg") (let* ((runconfigf (conc *toppath* "/runconfigs.config")) ;; DO NOT EVALUATE ALL Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -36,11 +36,15 @@ (define (server:start db hostn) (debug:print 0 "Attempting to start the server ...") (let ((host:port (db:get-var db "SERVER"))) ;; do whe already have a server running? (if host:port - (set! *runremote* #t) + (set! *runremote* (let* ((lst (string-split host:port ":")) + (port (if (> (length lst) 1) + (string->number (cadr lst)) + #f))) + (if port (vector (car lst) port) #f))) (let* ((rpc:listener (server:find-free-port-and-open (rpc:default-server-port))) (th1 (make-thread (cute (rpc:make-server rpc:listener) "rpc:server") 'rpc:server)) (th2 (make-thread (lambda ()(db:updater)))) @@ -89,49 +93,77 @@ (rpc:publish-procedure! 'cdb:test-rollup-iterated-pass-fail (lambda (test-id) (debug:print 4 "INFO: Remote call of cdb:test-rollup-iterated-pass-fail " test-id) - (apply cdb:test-rollup-iterated-pass-fail test-id))) + (cdb:test-rollup-iterated-pass-fail test-id))) (rpc:publish-procedure! 'cdb:pass-fail-counts (lambda (test-id fail-count pass-count) (debug:print 4 "INFO: Remote call of cdb:pass-fail-counts " test-id " passes: " pass-count " fails: " fail-count) - (apply cdb:pass-fail-counts test-id fail count-pass-count))) + (cdb:pass-fail-counts test-id fail-count pass-count))) + + (rpc:publish-procedure! + 'cdb:tests-register-test + (lambda (run-id test-name item-path) + (debug:print 4 "INFO: Remote call of cdb:tests-register-test " run-id " testname: " test-name " item-path: " item-path) + (cdb:tests-register-test run-id test-name item-path))) + + (rpc:publish-procedure! + 'cdb:flush-queue + (lambda () + (debug:print 4 "INFO: Remote call of cdb:flush-queue") + (cdb:flush-queue))) ;;====================================================================== ;; end of publish-procedure section ;;====================================================================== (set! *rpc:listener* rpc:listener) (on-exit (lambda () - (sqlite3:execute db "DELETE FROM metadat WHERE var='SERVER' and val=?;" host:port) - (sqlite3:finalize! db))) + (open-run-close + (lambda (db . params) + (sqlite3:execute db "DELETE FROM metadat WHERE var='SERVER' and val=?;" host:port)) + #f ;; for db + #f) ;; for a param + (let loop ((n 0)) + (let ((queue-len 0)) + (thread-sleep! (random 5)) + (mutex-lock! *incoming-mutex*) + (set! queue-len (length *incoming-data*)) + (mutex-unlock! *incoming-mutex*) + (if (> queue-len 0) + (begin + (debug:print 0 "INFO: Queue not flushed, waiting ...") + (loop (+ n 1))))) + ))) (thread-start! th1) (debug:print 0 "Server started...") (thread-start! th2) ;; (thread-join! th2) ;; return th2 for the calling process to do a join with th2 )))) ;; rpc:server))) -(define (server:keep-running db) +(define (server:keep-running db host:port) ;; if none running or if > 20 seconds since ;; server last used then start shutdown (let loop ((count 0)) (thread-sleep! 20) ;; no need to do this very often (let ((numrunning (db:get-count-tests-running db))) (if (or (not (> numrunning 0)) (> *last-db-access* (+ (current-seconds) 60))) (begin (debug:print 0 "INFO: Starting to shutdown the server side") - (sqlite3:execute db "DELETE FROM metadat WHERE var='SERVER'"); ;; AND val like ?;" - ;; host:port) ;; need to delete only *my* server entry (future use) + ;; need to delete only *my* server entry (future use) + (sqlite3:execute db "DELETE FROM metadat WHERE var='SERVER' AND val like ?;" host:port) (thread-sleep! 10) (debug:print 0 "INFO: Server shutdown complete. Exiting") - (exit)))) + (exit)) + (debug:print 0 "INFO: Server continuing, tests running: " numrunning ", seconds since last db access: " (- (current-seconds) *last-db-access*)) + )) (loop (+ 1 count)))) (define (server:find-free-port-and-open port) (handle-exceptions exn Index: tests/tests.scm ================================================================== --- tests/tests.scm +++ tests/tests.scm @@ -60,16 +60,18 @@ (test "get all legal tests" (list "test1" "test2") (sort (get-all-legal-tests) string<=?)) (test "register-test, test info" "NOT_STARTED" (begin - (db:tests-register-test *db* 1 "nada" "") + (rdb:tests-register-test *db* 1 "nada" "") + ;; (rdb:flush-queue) (vector-ref (db:get-test-info *db* 1 "nada" "") 3))) (test #f "NOT_STARTED" (begin - (open-run-close db:tests-register-test #f 1 "nada" "") + (rdb:tests-register-test #f 1 "nada" "") + ;; (rdb:flush-queue) (vector-ref (open-run-close db:get-test-info #f 1 "nada" "") 3))) (test "get-keys" "SYSTEM" (vector-ref (car (db:get-keys *db*)) 0));; (key:get-fieldname (car (sort (db-get-keys *db*)(lambda (a b)(string>=? (vector-ref a 0)(vector-ref b 0))))))) (define remargs (args:get-args @@ -172,11 +174,10 @@ (sleep 2) (db:teststep-set-status! db 2 "step1" "end" "pass" "This is a different comment" "finallogfile.html") (set! test-id (db:test-get-id (car (db:get-tests-for-run db 1 "test1" "" '() '())))) (number? test-id))) -(sleep 4) (test "Get rundir" #t (let ((rundir (db:test-get-rundir-from-test-id db test-id))) (print "Rundir" rundir) (string? rundir))) (test "Create a test db" "../simpleruns/key1/key2/myrun/test1/testdat.db" (let ((tdb (db:open-test-db-by-test-id db test-id))) (sqlite3#finalize! tdb) @@ -183,10 +184,81 @@ (file-exists? "../simpleruns/key1/key2/myrun/test1/testdat.db"))) (test "Get steps for test" #t (> (length (db:get-steps-for-test db test-id)) 0)) (test "Get nice table for steps" "2s" (begin (vector-ref (hash-table-ref (db:get-steps-table db test-id) "step1") 4))) + +;;====================================================================== +;; R E M O T E C A L L S +;;====================================================================== + +;; start a server process +(define server-pid (process-run "../../bin/megatest" '("-server" "-" "-debug" "10"))) +(sleep 2) +(define start-wait (current-seconds)) +(server:client-setup) +;; (set! *verbosity* 10) +(for-each (lambda (params) + (rdb:tests-register-test 1 (conc "test" (random 20)) "") + (apply rdb:test-set-status-state test-id params) + (rdb:pass-fail-counts test-id (random 100) (random 100)) + (rdb:test-rollup-iterated-pass-fail test-id) + (thread-sleep! 0.01)) ;; cache ordering granularity is at the second level. Should really be at the ms level + '(("COMPLETED" "PASS" #f) + ("NOT_STARTED" "FAIL" "Just testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("COMPLETED" "PASS" #f) + ("NOT_STARTED" "FAIL" "Just testing") + ("KILLED" "UNKNOWN" "More testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("COMPLETED" "PASS" #f) + ("NOT_STARTED" "FAIL" "Just testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("KILLED" "UNKNOWN" "More testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("COMPLETED" "PASS" #f) + ("NOT_STARTED" "FAIL" "Just testing") + ("KILLED" "UNKNOWN" "More testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("COMPLETED" "PASS" #f) + ("NOT_STARTED" "FAIL" "Just testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("KILLED" "UNKNOWN" "More testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("COMPLETED" "PASS" #f) + ("NOT_STARTED" "FAIL" "Just testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("KILLED" "UNKNOWN" "More testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("COMPLETED" "PASS" #f) + ("NOT_STARTED" "FAIL" "Just testing") + ("KILLED" "UNKNOWN" "More testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("NOT_STARTED" "FAIL" "Just testing") + ("COMPLETED" "PASS" #f) + ("NOT_STARTED" "FAIL" "Just testing") + ("KILLED" "UNKNOWN" "More testing") + ("KILLED" "UNKNOWN" "More testing") + )) +;; now set all tests to completed +(rdb:flush-queue) +(let ((tests (open-run-close db:get-tests-for-run #f 1 "%" "%" '() '()))) + (print "Setting " (length tests) " to COMPLETED/PASS") + (for-each + (lambda (test) + (rdb:test-set-status-state (db:test-get-id test) "COMPLETED" "PASS" "Forced pass")) + tests)) + +(print "Waiting for server to be done, should be about 20 seconds") +(process-wait server-pid) +(test "Server wait time" #t (let ((run-delta (- (current-seconds) start-wait))) + (print "Server ran for " run-delta " seconds") + (> run-delta 20))) (test "Rollup the run(s)" #t (begin (runs:rollup-run keys (keys->alist keys "na") "rollup" "matt") #t))