Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -851,11 +851,11 @@ db "SELECT id FROM tests WHERE run_id=? AND testname=? AND item_path=?;" run-id testname item-path) res)) -(define db:get-test-id db:get-test-id-cached) +(define db:get-test-id db:get-test-id-not-cached) ;; given a test-info record, patch in the latest data from the testdat.db file ;; found in the test run directory (define (db:patch-tdb-data-into-test-info db test-id res) (let ((tdb (db:open-test-db-by-test-id db test-id))) @@ -1124,10 +1124,25 @@ #t ;; path matches - pass! Should vet the caller at this time ... #f)))) ;; else fail to login ((flush) (db:write-cached-data) #t) + ((immediate) + (db:write-cached-data) + (if (not (null? remparam)) + (apply (car remparam) (cdr remparam)) + "ERROR")) + ((killserver) + (db:write-cached-data) + (debug:print-info 0 "Remotely killed server on host " (get-host-name) " pid " (current-process-id)) + (set! *time-to-exit* #t) + #t) + ((set-verbosity) + (set! *verbosity* (caddr params)) + *verbosity*) + ((get-verbosity) + *verbosity*) (else (mutex-lock! *incoming-mutex*) (set! *last-db-access* (current-seconds)) (set! *incoming-data* (cons (vector qry-name @@ -1156,10 +1171,13 @@ (send-message zmq-socket zdat) (set! res (db:string->obj (receive-message zmq-socket zdat))) (debug:print-info 11 "zmq-socket " (car params) " res=" res) res)) +(define (cdb:set-verbosity zmqsocket val) + (cdb:client-call zmqsocket 'set-verbosity #f val)) + (define (cdb:test-set-status-state zmqsocket test-id status state msg) (if msg (cdb:client-call zmqsocket 'state-status-msg #t state status msg test-id) (cdb:client-call zmqsocket 'state-status #t state status test-id))) ;; run-id test-name item-path minutes cpuload diskfree tmpfree) @@ -1176,34 +1194,47 @@ (cdb:client-call zmqsocket 'register-test #t run-id test-name item-path))) (define (cdb:flush-queue zmqsocket) (cdb:client-call zmqsocket 'flush #f)) +(define (cdb:kill-server zmqsocket) + (cdb:client-call zmqsocket 'killserver #f)) + +(define (cdb:roll-up-pass-fail-counts zmqsocket run-id test-name item-path status) + (cdb:client-call zmqsocket 'immediate #f open-run-close db:roll-up-pass-fail-counts #f run-id test-name item-path status)) + +(define (cdb:get-test-info zmqsocket run-id test-name item-path) + (cdb:client-call zmqsocket 'immediate #f open-run-close db:get-test-info #f run-id test-name item-path)) + +;; db should be db open proc or #f +(define (cdb:remote-run proc db . params) + (apply cdb:client-call *runremote* 'immediate #f open-run-close proc #f params)) + (define db:queries - '((register-test "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path,state,status) VALUES (?,?,strftime('%s','now'),?,'NOT_STARTED','n/a');") - (state-status "UPDATE tests SET state=?,status=? WHERE id=?;") - (state-status-msg "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;") - (pass-fail-counts "UPDATE tests SET fail_count=?,pass_count=? WHERE id=?;") - (test_data-pf-rollup "UPDATE tests - SET status=CASE WHEN (SELECT fail_count FROM tests WHERE id=?) > 0 - THEN 'FAIL' - WHEN (SELECT pass_count FROM tests WHERE id=?) > 0 AND - (SELECT status FROM tests WHERE id=?) NOT IN ('WARN','FAIL') - THEN 'PASS' - ELSE status - END WHERE id=?;") - (rollup-tests-pass-fail "UPDATE tests - SET fail_count=(SELECT count(id) FROM tests WHERE - run_id=? AND testname=? AND item_path != '' AND status='FAIL'), - pass_count=(SELECT count(id) FROM tests WHERE - run_id=? AND testname=? AND item_path != '' AND (status='PASS' OR status='WARN' OR status='WAIVED')) - WHERE run_id=? AND testname=? AND item_path='';") - (test-set-log "UPDATE tests SET final_logf=? WHERE id=?;") - (test-set-rundir-by-test-id "UPDATE tests SET rundir=? WHERE id=?"))) - -(define db:special-queries '(rollup-tests-pass-fail)) -(define db:run-local-queries '(rollup-tests-pass-fail)) + (list '(register-test "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path,state,status) VALUES (?,?,strftime('%s','now'),?,'NOT_STARTED','n/a');") + '(state-status "UPDATE tests SET state=?,status=? WHERE id=?;") + '(state-status-msg "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;") + '(pass-fail-counts "UPDATE tests SET fail_count=?,pass_count=? WHERE id=?;") + ;; test_data-pf-rollup is used to set a tests PASS/FAIL based on the pass/fail info from the steps + '(test_data-pf-rollup "UPDATE tests + SET status=CASE WHEN (SELECT fail_count FROM tests WHERE id=?) > 0 + THEN 'FAIL' + WHEN (SELECT pass_count FROM tests WHERE id=?) > 0 AND + (SELECT status FROM tests WHERE id=?) NOT IN ('WARN','FAIL') + THEN 'PASS' + ELSE status + END WHERE id=?;") + '(test-set-log "UPDATE tests SET final_logf=? WHERE id=?;") + '(test-set-rundir-by-test-id "UPDATE tests SET rundir=? WHERE id=?") + )) + +;; do not run these as part of the transaction +(define db:special-queries '(rollup-tests-pass-fail + db:roll-up-pass-fail-counts)) + +;; not used, intended to indicate to run in calling process +(define db:run-local-queries '()) ;; rollup-tests-pass-fail)) ;; 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 ;; @@ -1216,57 +1247,81 @@ (set! data (sort *incoming-data* (lambda (a b)(< (vector-ref a 1)(vector-ref b 1))))) (set! *incoming-data* '()) (mutex-unlock! *incoming-mutex*) (if (> (length data) 0) (debug:print-info 4 "Writing cached data " data)) - ;; prepare the needed statements + + ;; prepare the needed statements, do each only once (for-each (lambda (request-item) (let ((stmt-key (vector-ref request-item 0))) (if (not (hash-table-ref/default queries stmt-key #f)) (let ((stmt (alist-ref stmt-key db:queries))) (if stmt (hash-table-set! queries stmt-key (sqlite3:prepare db (car stmt))) - (debug:print 0 "ERROR: Missing query spec for " stmt-key "!")))))) + (if (procedure? stmt-key) + (hash-table-set! queries stmt-key #f) + (debug:print 0 "ERROR: Missing query spec for " stmt-key "!"))))))) data) + + ;; outer loop to handle special queries that cannot be handled in the + ;; transaction. (let outerloop ((special-qry #f) (stmts data)) (if special-qry + ;; handle a query that cannot be part of the grouped queries (let* ((stmt-key (vector-ref special-qry 0)) (qry (hash-table-ref queries stmt-key)) (params (vector-ref special-qry 2))) - (apply sqlite3:execute db qry params) + (if (string? qry) + (apply sqlite3:execute db qry params) + (if (procedure? stmt-key) + (begin + ;; we are being handed a procedure so call it + (debug:print-info 11 "Running (apply " stmt-key " " db " " params ")") + (apply stmt-key db params)) + (debug:print 0 "ERROR: Unrecognised queued call " qry " " params))) (if (not (null? stmts)) (outerloop #f stmts))) + ;; handle normal queries - (sqlite3:with-transaction - db - (lambda () - (debug:print-info 11 "flushing " stmts " to db") - (if (not (null? stmts)) - (let innerloop ((hed (car stmts)) - (tal (cdr stmts))) - (let ((params (vector-ref hed 2)) - (stmt-key (vector-ref hed 0))) - (if (not (member stmt-key db:special-queries)) - (begin - (debug:print-info 11 "Executing " stmt-key " for " params) - (apply sqlite3:execute (hash-table-ref queries stmt-key) params) - (if (not (null? tal)) - (innerloop (car tal)(cdr tal)))) - (outerloop hed tal))))))))) + (let ((rem (sqlite3:with-transaction + db + (lambda () + (debug:print-info 11 "flushing " stmts " to db") + (if (null? stmts) + stmts + (let innerloop ((hed (car stmts)) + (tal (cdr stmts))) + (let ((params (vector-ref hed 2)) + (stmt-key (vector-ref hed 0))) + (if (or (procedure? stmt-key) + (member stmt-key db:special-queries)) + (begin + (debug:print-info 11 "Handling special statement " stmt-key) + (cons hed tal)) + (begin + (debug:print-info 11 "Executing " stmt-key " for " params) + (apply sqlite3:execute (hash-table-ref queries stmt-key) params) + (if (not (null? tal)) + (innerloop (car tal)(cdr tal)) + '())) + )))))))) + (if (not (null? rem)) + (outerloop (car rem)(cdr rem)))))) (for-each (lambda (stmt-key) (sqlite3:finalize! (hash-table-ref queries stmt-key))) (hash-table-keys queries)) (let ((cache-size (length data))) (if (> cache-size *max-cache-size*) (set! *max-cache-size* cache-size))) )) #f)) +;; Rollup the pass/fail counts from itemized tests into fail_count and pass_count (define (db:roll-up-pass-fail-counts db run-id test-name item-path status) - (cdb:flush-queue *runremote*) + ;; (cdb:flush-queue *runremote*) (if (and (not (equal? item-path "")) (or (equal? status "PASS") (equal? status "WARN") (equal? status "FAIL") (equal? status "WAIVED") @@ -1290,11 +1345,10 @@ ELSE 'COMPLETED' END, status=CASE WHEN fail_count > 0 THEN 'FAIL' WHEN pass_count > 0 AND fail_count=0 THEN 'PASS' ELSE 'UNKNOWN' END WHERE run_id=? AND testname=? AND item_path='';" run-id test-name run-id test-name)) #f) - #f)) ;;====================================================================== ;; Tests meta data ;;====================================================================== Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -26,10 +26,11 @@ (define (server:make-server-url hostport) (if (not hostport) #f (conc "tcp://" (car hostport) ":" (cadr hostport)))) +(define *time-to-exit* #f) (define (server:run hostn) (debug:print 0 "Attempting to start the server ...") (if (not *toppath*)(setup-for-run)) (let* ((hostport (open-run-close tasks:get-best-server tasks:open-db)) ;; do whe already have a server running? @@ -82,10 +83,11 @@ (res #f)) (debug:print-info 12 "server=> received params=" params) (set! res (cdb:cached-access params)) (debug:print-info 12 "server=> processed res=" res) (send-message zmq-socket (db:obj->string res)) + (if *time-to-exit* (exit)) (loop))))))) ;; run server:keep-running in a parallel thread to monitor that the db is being ;; used and to shutdown after sometime if it is not. ;; Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -86,11 +86,11 @@ (if port (sqlite3:execute mdb "DELETE FROM servers WHERE hostname=? AND port=?;" hostname port) (debug:print 0 "ERROR: tasks:server-deregister called with neither pid nor port specified")))) (define (tasks:server-deregister-self mdb) - (tasks:server-deregister mdb pid: (current-process-id) (get-host-name))) + (tasks:server-deregister mdb (get-host-name) pid: (current-process-id))) (define (tasks:server-get-server-id mdb) ;; dunno yet 0) Index: tests/tests.scm ================================================================== --- tests/tests.scm +++ tests/tests.scm @@ -89,13 +89,14 @@ (open-run-close tasks:get-best-server tasks:open-db))) ;; (exit) -(set! *verbosity* 10) +(set! *verbosity* 3) ;; enough to trigger turning off exception handling in db accesses (define server-pid (process-run "../../bin/megatest" (list "-server" "-" "-debug" (conc *verbosity*)))) (sleep 3) +(set! *verbosity* 1) (define th1 (make-thread (lambda ()(server:client-setup)))) (thread-start! th1) (test #f #t (socket? *runremote*)) @@ -147,24 +148,21 @@ (test "write env files" "nada.csh" (begin (save-environment-as-files "nada") (and (file-exists? "nada.sh") (file-exists? "nada.csh")))) + +(test #f #t (cdb:client-call *runremote* 'immediate #f (lambda ()(display "Got here eh!?") #t))) + +;; (set! *verbosity* 20) +(test #f *verbosity* (cdb:set-verbosity *runremote* *verbosity*)) +(test #f #f (cdb:roll-up-pass-fail-counts *runremote* 1 "test1" "" "PASS")) +;; (set! *verbosity* 1) +;; (cdb:set-verbosity *runremote* *verbosity*) (test "get all legal tests" (list "test1" "test2") (sort (get-all-legal-tests) string<=?)) -(test "register-test, test info" "NOT_STARTED" - (begin - (cdb:tests-register-test *runremote* 1 "nada" "") - ;; (rdb:flush-queue) - (vector-ref (db:get-test-info *db* 1 "nada" "") 3))) - -(test #f "NOT_STARTED" - (begin - (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 '("bar" "foo" ":runname" "bob" ":SYSTEM" "ubuntu" ":RELEASE" "v1.2" ":datapath" "blah/foo" "nada") @@ -178,10 +176,16 @@ '(("SYSTEM" "key1")("RELEASE" "key2")) "myrun" "new" "n/a" "bob"))) + +(test #f "CACHED" (cdb:tests-register-test *runremote* 1 "nada" "")) +(test #f 1 (cdb:remote-run db:get-test-id #f 1 "nada" "")) +(test #f "NOT_STARTED" (vector-ref (open-run-close db:get-test-info #f 1 "nada" "") 3)) +(test #f "NOT_STARTED" (vector-ref (cdb:get-test-info *runremote* 1 "nada" "") 3)) + (define keys (db:get-keys *db*)) ;;====================================================================== ;; D B ;;====================================================================== @@ -294,17 +298,16 @@ ;;====================================================================== ;; R E M O T E C A L L S ;;====================================================================== (define start-wait (current-seconds)) -(server:client-setup) (print "Starting intensive cache and rpc test") (for-each (lambda (params) - ;;; (rdb:tests-register-test #f 1 (conc "test" (random 20)) "") + (cdb:tests-register-test *runremote* 1 (conc "test" (random 20)) "") (apply cdb:test-set-status-state *runremote* test-id params) - (rdb:pass-fail-counts test-id (random 100) (random 100)) - (rdb:test-rollup-test_data-pass-fail test-id) + (cdb:pass-fail-counts *runremote* test-id (random 100) (random 100)) + (cdb:test-rollup-test_data-pass-fail *runremote* 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") @@ -343,20 +346,21 @@ ("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 "%" '() '()))) +(cdb:flush-queue *runremote*) +(let ((tests (cdb:remote-run 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")) + (cdb:test-set-status-state *runremote* (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) +(cdb:kill-server *runremote*) +;; (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