@@ -53,11 +53,11 @@ (max (- (current-seconds) start) 1)))) (vector-set! record 1 count) (if (and (> count 10) (> queries-per-second 10)) (begin - (debug:print-info 1 #f "db write rate too high, starting a server, count=" count " start=" start " run-id=" run-id " queries-per-second=" queries-per-second) + (debug:print-info 1 *default-log-port* "db write rate too high, starting a server, count=" count " start=" start " run-id=" run-id " queries-per-second=" queries-per-second) #t) #f)))) ;; if a server is either running or in the process of starting call client:setup ;; else return #f to let the calling proc know that there is no server available @@ -81,11 +81,11 @@ (lambda (run-id) (let ((connection (hash-table-ref/default *runremote* run-id #f))) (if (and (vector? connection) (< (http-transport:server-dat-get-last-access connection) expire-time)) (begin - (debug:print-info 0 #f "Discarding connection to server for run-id " run-id ", too long between accesses") + (debug:print-info 0 *default-log-port* "Discarding connection to server for run-id " run-id ", too long between accesses") ;; SHOULD CLOSE THE CONNECTION HERE (case *transport-type* ((nmsg)(nn-close (http-transport:server-dat-get-socket (hash-table-ref *runremote* run-id))))) (hash-table-delete! *runremote* run-id))))) @@ -114,11 +114,11 @@ ;; (mutex-unlock! *send-receive-mutex*) (case *transport-type* ((http) res) ;; (db:string->obj res)) ((nmsg) res))) ;; (vector-ref res 1))) (begin ;; let ((new-connection-info (client:setup run-id))) - (debug:print 0 #f "WARNING: Communication failed, trying call to rmt:send-receive again.") + (debug:print 0 *default-log-port* "WARNING: Communication failed, trying call to rmt:send-receive again.") ;; (case *transport-type* ;; ((nmsg)(nn-close (http-transport:server-dat-get-socket connection-info)))) (hash-table-delete! *runremote* run-id) ;; don't keep using the same connection ;; NOTE: killing server causes this process to block forever. No idea why. Dec 2. ;; (if (eq? (modulo attemptnum 5) 0) @@ -153,17 +153,17 @@ "300"))) (newres (rmt:open-qry-close-locally cmd run-id params))) (let ((delta (- (current-milliseconds) start-time))) (if (> delta max-query) (begin - (debug:print-info 0 #f "Starting server as query time " delta " is over the limit of " max-query) + (debug:print-info 0 *default-log-port* "Starting server as query time " delta " is over the limit of " max-query) (server:kind-run run-id))) ;; return the result! newres) ))) (begin - ;; (debug:print 0 #f "ERROR: Communication failed!") + ;; (debug:print-error 0 *default-log-port* "Communication failed!") ;; (mutex-unlock! *send-receive-mutex*) ;; (exit) (rmt:open-qry-close-locally cmd run-id params) ))))) @@ -170,12 +170,12 @@ (define (rmt:update-db-stats run-id rawcmd params duration) (mutex-lock! *db-stats-mutex*) (handle-exceptions exn (begin - (debug:print 0 #f "WARNING: stats collection failed in update-db-stats") - (debug:print 0 #f " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* "WARNING: stats collection failed in update-db-stats") + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) (print "exn=" (condition->list exn)) #f) ;; if this fails we don't care, it is just stats (let* ((cmd (conc "run-id=" run-id " " (if (eq? rawcmd 'general-call) (car params) rawcmd))) (stat-vec (hash-table-ref/default *db-stats* cmd #f))) (if (not (vector? stat-vec)) @@ -187,15 +187,15 @@ (mutex-unlock! *db-stats-mutex*)) (define (rmt:print-db-stats) (let ((fmtstr "~40a~7-d~9-d~20,2-f")) ;; "~20,2-f" - (debug:print 18 #f "DB Stats\n========") - (debug:print 18 #f (format #f "~40a~8a~10a~10a" "Cmd" "Count" "TotTime" "Avg")) + (debug:print 18 *default-log-port* "DB Stats\n========") + (debug:print 18 *default-log-port* (format #f "~40a~8a~10a~10a" "Cmd" "Count" "TotTime" "Avg")) (for-each (lambda (cmd) (let ((cmd-dat (hash-table-ref *db-stats* cmd))) - (debug:print 18 #f (format #f fmtstr cmd (vector-ref cmd-dat 0) (vector-ref cmd-dat 1) (/ (vector-ref cmd-dat 1)(vector-ref cmd-dat 0)))))) + (debug:print 18 *default-log-port* (format #f fmtstr cmd (vector-ref cmd-dat 0) (vector-ref cmd-dat 1) (/ (vector-ref cmd-dat 1)(vector-ref cmd-dat 0)))))) (sort (hash-table-keys *db-stats*) (lambda (a b) (> (vector-ref (hash-table-ref *db-stats* a) 0) (vector-ref (hash-table-ref *db-stats* b) 0))))))) @@ -239,15 +239,15 @@ (res (vector-ref resdat 1)) (duration (- (current-milliseconds) start))) (if (not success) (if (> remretries 0) (begin - (debug:print 0 #f "ERROR: local query failed. Trying again.") + (debug:print-error 0 *default-log-port* "local query failed. Trying again.") (thread-sleep! (/ (random 5000) 1000)) ;; some random delay (rmt:open-qry-close-locally cmd run-id params remretries: (- remretries 1))) (begin - (debug:print 0 #f "ERROR: too many retries in rmt:open-qry-close-locally, giving up") + (debug:print-error 0 *default-log-port* "too many retries in rmt:open-qry-close-locally, giving up") #f)) (begin ;; (rmt:update-db-stats run-id cmd params duration) ;; mark this run as dirty if this was a write (if (not (member cmd api:read-only-queries)) @@ -270,11 +270,11 @@ (if (and res (vector-ref res 0)) (vector-ref res 1) ;;; YES!! THIS IS CORRECT!! CHANGE IT HERE, THEN CHANGE rmt:send-receive ALSO!!! #f))) ;; (db:string->obj (vector-ref dat 1)) ;; (begin -;; (debug:print 0 #f "ERROR: rmt:send-receive-no-auto-client-setup failed, attempting to continue. Got " dat) +;; (debug:print-error 0 *default-log-port* "rmt:send-receive-no-auto-client-setup failed, attempting to continue. Got " dat) ;; dat)))) ;; Wrap json library for strings (why the ports crap in the first place?) (define (rmt:dat->json-str dat) (with-output-to-string @@ -350,10 +350,13 @@ (rmt:send-receive 'get-key-vals #f (list run-id))) (define (rmt:get-targets) (rmt:send-receive 'get-targets #f '())) +(define (rmt:get-target run-id) + (rmt:send-receive 'get-target run-id (list run-id))) + ;;====================================================================== ;; T E S T S ;;====================================================================== ;; Just some syntatic sugar @@ -365,11 +368,11 @@ (define (rmt:get-test-info-by-id run-id test-id) (if (and (number? run-id)(number? test-id)) (rmt:send-receive 'get-test-info-by-id run-id (list run-id test-id)) (begin - (debug:print 0 #f "WARNING: Bad data handed to rmt:get-test-info-by-id run-id=" run-id ", test-id=" test-id) + (debug:print 0 *default-log-port* "WARNING: Bad data handed to rmt:get-test-info-by-id run-id=" run-id ", test-id=" test-id) (print-call-chain (current-error-port)) #f))) (define (rmt:test-get-rundir-from-test-id run-id test-id) (rmt:send-receive 'test-get-rundir-from-test-id run-id (list run-id test-id))) @@ -376,11 +379,11 @@ (define (rmt:open-test-db-by-test-id run-id test-id #!key (work-area #f)) (let* ((test-path (if (string? work-area) work-area (rmt:test-get-rundir-from-test-id run-id test-id)))) - (debug:print 3 #f "TEST PATH: " test-path) + (debug:print 3 *default-log-port* "TEST PATH: " test-path) (open-test-db test-path))) ;; WARNING: This currently bypasses the transaction wrapped writes system (define (rmt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment) (rmt:send-receive 'test-set-state-status-by-id run-id (list run-id test-id newstate newstatus newcomment))) @@ -390,11 +393,11 @@ (define (rmt:get-tests-for-run run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode) (if (number? run-id) (rmt:send-receive 'get-tests-for-run run-id (list run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode)) (begin - (debug:print 0 #f "ERROR: rmt:get-tests-for-run called with bad run-id=" run-id) + (debug:print-error 0 *default-log-port* "rmt:get-tests-for-run called with bad run-id=" run-id) (print-call-chain (current-error-port)) '()))) ;; get stuff via synchash (define (rmt:synchash-get run-id proc synckey keynum params) @@ -421,11 +424,11 @@ (if (list? res) (begin (mutex-lock! multi-run-mutex) (set! result (append result res)) (mutex-unlock! multi-run-mutex)) - (debug:print 0 #f "ERROR: get-tests-for-run-mindata failed for run-id " hed ", testpatt " testpatt ", states " states ", status " status ", not-in " not-in)))) + (debug:print-error 0 *default-log-port* "get-tests-for-run-mindata failed for run-id " hed ", testpatt " testpatt ", states " states ", status " status ", not-in " not-in)))) (conc "multi-run-thread for run-id " hed))) (newthreads (cons newthread threads))) (thread-start! newthread) (thread-sleep! 0.05) ;; give that thread some time to start (if (null? tal) @@ -615,22 +618,27 @@ (if (not keyvals) #f (let ((prev-run-ids (rmt:get-prev-run-ids run-id))) ;; for each run starting with the most recent look to see if there is a matching test ;; if found then return that matching test record - (debug:print 4 #f "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids) + (debug:print 4 *default-log-port* "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids) (if (null? prev-run-ids) #f (let loop ((hed (car prev-run-ids)) (tal (cdr prev-run-ids))) - (let ((results (rmt:get-tests-for-run hed (conc test-name "/" item-path) '() '() #f #f #f #f #f #f #f 'normal))) - (debug:print 4 #f "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path ": " results) + (let ((results (rmt:get-tests-for-run hed (conc test-name "/" item-path) '() '() ;; run-id testpatt states statuses + #f #f #f ;; offset limit not-in hide/not-hide + #f #f #f #f 'normal))) ;; sort-by sort-order qryvals last-update mode + (debug:print 4 *default-log-port* "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path ": " results) (if (and (null? results) (not (null? tal))) (loop (car tal)(cdr tal)) (if (null? results) #f (car results)))))))))) +(define (rmt:get-run-stats) + (rmt:send-receive 'get-run-stats #f '())) + ;;====================================================================== ;; S T E P S ;;====================================================================== ;; Getting steps is more complicated. @@ -647,11 +655,11 @@ (define (rmt:teststep-set-status! run-id test-id teststep-name state-in status-in comment logfile) (let* ((state (items:check-valid-items "state" state-in)) (status (items:check-valid-items "status" status-in))) (if (or (not state)(not status)) - (debug:print 3 #f "WARNING: Invalid " (if status "status" "state") + (debug:print 3 *default-log-port* "WARNING: Invalid " (if status "status" "state") " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config")) (rmt:send-receive 'teststep-set-status! run-id (list run-id test-id teststep-name state-in status-in comment logfile)))) (define (rmt:get-steps-for-test run-id test-id) (rmt:send-receive 'get-steps-for-test run-id (list run-id test-id))) @@ -693,10 +701,13 @@ (rmt:send-receive 'tasks-add #f (list action owner target runname testpatt params))) (define (rmt:tasks-set-state-given-param-key param-key new-state) (rmt:send-receive 'tasks-set-state-given-param-key #f (list param-key new-state))) +(define (rmt:tasks-get-last target runname) + (rmt:send-receive 'tasks-get-last #f (list target runname))) + ;;====================================================================== ;; A R C H I V E S ;;====================================================================== (define (rmt:archive-get-allocations testname itempath dneeded)