@@ -17,12 +17,10 @@ ;; (import (prefix rpc rpc:)) (use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest) (import (prefix sqlite3 sqlite3:)) -(use zmq) - (declare (unit db)) (declare (uses common)) (declare (uses keys)) (declare (uses ods)) @@ -783,12 +781,12 @@ " run_id=? AND testname=? AND NOT (item_path='' AND testname in (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));"))) ;;(debug:print 0 "QRY: " qry) (sqlite3:execute db qry run-id newstate newstatus testname testname))) testnames)) -(define (cdb:delete-tests-in-state zmqsocket run-id state) - (cdb:client-call zmqsocket 'delete-tests-in-state #t *default-numtries* run-id state)) +(define (cdb:delete-tests-in-state serverdat run-id state) + (cdb:client-call serverdat 'delete-tests-in-state #t *default-numtries* run-id state)) ;; speed up for common cases with a little logic (define (db:test-set-state-status-by-id db test-id newstate newstatus newcomment) (cond ((and newstate newstatus newcomment) @@ -962,15 +960,15 @@ (sqlite3:execute db "UPDATE tests SET comment=? WHERE id=?;" comment test-id)) -(define (cdb:test-set-rundir! zmqsocket run-id test-name item-path rundir) - (cdb:client-call zmqsocket 'test-set-rundir #t *default-numtries* rundir run-id test-name item-path)) +(define (cdb:test-set-rundir! serverdat run-id test-name item-path rundir) + (cdb:client-call serverdat 'test-set-rundir #t *default-numtries* rundir run-id test-name item-path)) -(define (cdb:test-set-rundir-by-test-id zmqsocket test-id rundir) - (cdb:client-call zmqsocket 'test-set-rundir-by-test-id #t *default-numtries* rundir test-id)) +(define (cdb:test-set-rundir-by-test-id serverdat test-id rundir) + (cdb:client-call serverdat 'test-set-rundir-by-test-id #t *default-numtries* rundir test-id)) (define (db:test-get-rundir-from-test-id db test-id) (let ((res #f)) ;; (hash-table-ref/default *test-paths* test-id #f))) ;; (if res ;; res @@ -982,12 +980,12 @@ "SELECT rundir FROM tests WHERE id=?;" test-id) ;; (hash-table-set! *test-paths* test-id res) res)) ;; )) -(define (cdb:test-set-log! zmqsocket test-id logf) - (if (string? logf)(cdb:client-call zmqsocket 'test-set-log #f *default-numtries* logf test-id))) +(define (cdb:test-set-log! serverdat test-id logf) + (if (string? logf)(cdb:client-call serverdat 'test-set-log #f *default-numtries* logf test-id))) ;;====================================================================== ;; Misc. test related queries ;;====================================================================== @@ -1111,37 +1109,31 @@ ;; params = 'target cached remparams ;; ;; make-vector-record cdb packet client-sig qtype immediate query-sig params qtime ;; -(define (cdb:client-call zmq-sockets qtype immediate numretries . params) - (debug:print-info 11 "cdb:client-call zmq-sockets=" zmq-sockets ", qtype=" qtype ", immediate=" immediate ", numretries=" numretries ", params=" params) +(define (cdb:client-call serverdat qtype immediate numretries . params) + (debug:print-info 11 "cdb:client-call serverdat=" serverdat ", qtype=" qtype ", immediate=" immediate ", numretries=" numretries ", params=" params) (handle-exceptions exn (begin (thread-sleep! 5) - (if (> numretries 0)(apply cdb:client-call zmq-sockets qtype immediate (- numretries 1) params))) - (let* ((push-socket (vector-ref zmq-sockets 0)) - (sub-socket (vector-ref zmq-sockets 1)) - (client-sig (server:get-client-signature)) + (if (> numretries 0)(apply cdb:client-call serverdat qtype immediate (- numretries 1) params))) + (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)))) (res #f) (send-receive (lambda () - (debug:print-info 11 "sending message") - (send-message push-socket zdat) - (debug:print-info 11 "message sent") - (let loop () + (let loop ((res (server:client-send-receive serverdat zdat))) ;; get the sender info ;; this should match (server:get-client-signature) ;; we will need to process "all" messages here some day - (receive-message* sub-socket) ;; now get the actual message - (let ((myres (db:string->obj (receive-message* sub-socket)))) + (let ((myres (db:string->obj res))) (if (equal? query-sig (vector-ref myres 1)) (set! res (vector-ref myres 2)) - (loop)))))) + (loop (server:client-send-receive serverdat zdat))))))) (timeout (lambda () (let loop ((n numretries)) (thread-sleep! 15) (if (not res) (if (> numretries 0) @@ -1149,11 +1141,11 @@ (debug:print 2 "WARNING: no reply to query " params ", trying resend") (debug:print-info 11 "re-sending message") (send-message push-socket zdat) (debug:print-info 11 "message re-sent") (loop (- n 1))) - ;; (apply cdb:client-call zmq-sockets qtype immediate (- numretries 1) params)) + ;; (apply cdb:client-call serverdats qtype immediate (- numretries 1) params)) (begin (debug:print 0 "ERROR: cdb:client-call timed out " params ", exiting.") (exit 5)))))))) (debug:print-info 11 "Starting threads") (let ((th1 (make-thread send-receive "send receive")) @@ -1162,53 +1154,53 @@ (thread-start! th2) (thread-join! th1) (debug:print-info 11 "cdb:client-call returning res=" res) res)))) -(define (cdb:set-verbosity zmq-socket val) - (cdb:client-call zmq-socket 'set-verbosity #f *default-numtries* val)) - -(define (cdb:login zmq-sockets keyval signature) - (cdb:client-call zmq-sockets 'login #t *default-numtries* keyval megatest-version signature)) - -(define (cdb:logout zmq-socket keyval signature) - (cdb:client-call zmq-socket 'logout #t *default-numtries* keyval signature)) - -(define (cdb:num-clients zmq-socket) - (cdb:client-call zmq-socket 'numclients #t *default-numtries*)) - -(define (cdb:test-set-status-state zmqsocket test-id status state msg) +(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*)) + +(define (cdb:test-set-status-state serverdat test-id status state msg) (if msg - (cdb:client-call zmqsocket 'state-status-msg #t *default-numtries* state status msg test-id) - (cdb:client-call zmqsocket 'state-status #t *default-numtries* state status test-id))) ;; run-id test-name item-path minutes cpuload diskfree tmpfree) - -(define (cdb:test-rollup-test_data-pass-fail zmqsocket test-id) - (cdb:client-call zmqsocket 'test_data-pf-rollup #t *default-numtries* test-id test-id test-id test-id)) - -(define (cdb:pass-fail-counts zmqsocket test-id fail-count pass-count) - (cdb:client-call zmqsocket 'pass-fail-counts #t *default-numtries* fail-count pass-count test-id)) - -(define (cdb:tests-register-test zmqsocket run-id test-name item-path) + (cdb:client-call serverdat 'state-status-msg #t *default-numtries* state status msg test-id) + (cdb:client-call serverdat 'state-status #t *default-numtries* state status test-id))) ;; run-id test-name item-path minutes cpuload diskfree tmpfree) + +(define (cdb:test-rollup-test_data-pass-fail serverdat test-id) + (cdb:client-call serverdat 'test_data-pf-rollup #t *default-numtries* test-id test-id test-id test-id)) + +(define (cdb:pass-fail-counts serverdat test-id fail-count pass-count) + (cdb:client-call serverdat 'pass-fail-counts #t *default-numtries* fail-count pass-count test-id)) + +(define (cdb:tests-register-test serverdat run-id test-name item-path) (let ((item-paths (if (equal? item-path "") (list item-path) (list item-path "")))) - (cdb:client-call zmqsocket 'register-test #t *default-numtries* run-id test-name item-path))) - -(define (cdb:flush-queue zmqsocket) - (cdb:client-call zmqsocket 'flush #f *default-numtries*)) - -(define (cdb:kill-server zmqsocket) - (cdb:client-call zmqsocket 'killserver #f *default-numtries*)) - -(define (cdb:roll-up-pass-fail-counts zmqsocket run-id test-name item-path status) - (cdb:client-call zmqsocket 'immediate #f *default-numtries* 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 *default-numtries* open-run-close db:get-test-info #f run-id test-name item-path)) - -(define (cdb:get-test-info-by-id zmqsocket test-id) - (cdb:client-call zmqsocket 'immediate #f *default-numtries* open-run-close db:get-test-info-by-id #f test-id)) + (cdb:client-call serverdat 'register-test #t *default-numtries* run-id test-name item-path))) + +(define (cdb:flush-queue serverdat) + (cdb:client-call serverdat 'flush #f *default-numtries*)) + +(define (cdb:kill-server serverdat) + (cdb:client-call serverdat 'killserver #f *default-numtries*)) + +(define (cdb:roll-up-pass-fail-counts serverdat run-id test-name item-path status) + (cdb:client-call serverdat 'immediate #f *default-numtries* open-run-close db:roll-up-pass-fail-counts #f run-id test-name item-path status)) + +(define (cdb:get-test-info serverdat run-id test-name item-path) + (cdb:client-call serverdat 'immediate #f *default-numtries* open-run-close db:get-test-info #f run-id test-name item-path)) + +(define (cdb:get-test-info-by-id serverdat test-id) + (cdb:client-call serverdat 'immediate #f *default-numtries* open-run-close db:get-test-info-by-id #f test-id)) ;; db should be db open proc or #f (define (cdb:remote-run proc db . params) (apply cdb:client-call *runremote* 'immediate #f *default-numtries* open-run-close proc #f params))