Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -2030,11 +2030,12 @@ END WHERE id=?;") ;; DONE '(test-set-log "UPDATE tests SET final_logf=? WHERE id=?;") ;; DONE ;; '(test-set-rundir-by-test-id "UPDATE tests SET rundir=? WHERE id=?") ;; DONE ;; '(test-set-rundir "UPDATE tests SET rundir=? AND testname=? AND item_path=?;") ;; DONE '(test-set-rundir-shortdir "UPDATE tests SET rundir=?,shortdir=? WHERE testname=? AND item_path=?;") - '(delete-tests-in-state "DELETE FROM tests WHERE state=?;") ;; DONE + '(delete-tests-in-state ;; "DELETE FROM tests WHERE state=?;") ;; DONE + "UPDATE tests SET state='DELETED' WHERE state=?") '(tests:test-set-toplog "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path='';") '(update-cpuload-diskfree "UPDATE tests SET cpuload=?,diskfree=? WHERE id=?;") ;; DONE '(update-uname-host "UPDATE tests SET uname=?,host=? WHERE id=?;") ;; DONE '(update-test-state "UPDATE tests SET state=? WHERE state=? AND run_id=? AND testname=? AND NOT (item_path='' AND testname IN (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));") '(update-test-status "UPDATE tests SET status=? WHERE status like ? AND run_id=? AND testname=? AND NOT (item_path='' AND testname IN (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));") Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -346,19 +346,11 @@ (debug:print 0 "WARNING: -itempatt has been deprecated, please use -testpatt testpatt/itempatt method, new testpatt is "newval) (hash-table-set! args:arg-hash "-testpatt" newval) (hash-table-delete! args:arg-hash "-itempatt"))) (on-exit (lambda () - (debug:print 18 "DB Stats") - (debug:print 18 "Cmd\tCount\tTot time\tAvg") - (for-each (lambda (cmd) - (let ((cmd-dat (hash-table-ref *db-stats* cmd))) - (debug:print 18 cmd "\t" (vector-ref cmd-dat 0) "\t" (vector-ref cmd-dat 1) "\t" (/ (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))))) + (rmt:print-db-stats) (if *dbstruct-db* (db:close-all *dbstruct-db*)) (if *megatest-db* (sqlite3:finalize! *megatest-db*)))) ;;====================================================================== ;; Misc general calls Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -7,11 +7,11 @@ ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== -(use json) +(use json format) (declare (unit rmt)) (declare (uses api)) (declare (uses tdb)) (declare (uses http-transport)) @@ -77,25 +77,71 @@ (if res (db:string->obj res) (let ((new-connection-info (client:setup run-id))) (debug:print 0 "WARNING: Communication failed, trying call to http-transport:client-api-send-receive again.") (rmt:send-receive cmd run-id params)))) - (begin + (let ((max-avg-qry (string->number (or (configf:lookup *configdat* "server" "server-query-threshold") "800")))) (debug:print-info 4 "no server and read-only query, bypassing normal channel") - (if (rmt:write-frequency-over-limit? cmd run-id)(server:kind-run run-id)) + ;; (if (rmt:write-frequency-over-limit? cmd run-id)(server:kind-run run-id)) + (let ((curr-max (rmt:get-max-query-average))) + (if (> (cdr curr-max) max-avg-qry) + (begin + (debug:print-info 0 "Max average query, " (inexact->exact (round (cdr curr-max))) "ms (" (car curr-max) ") exceeds " max-avg-qry ", try starting server ...") + (server:kind-run run-id)))) (rmt:open-qry-close-locally cmd run-id params))))) -(define (rmt:update-db-stats cmd duration) +(define (rmt:update-db-stats rawcmd params duration) (mutex-lock! *db-stats-mutex*) - (let ((stat-vec (hash-table-ref/default *db-stats* cmd #f))) + (let* ((cmd (if (eq? rawcmd 'general-call) (car params) rawcmd)) + (stat-vec (hash-table-ref/default *db-stats* cmd #f))) (if (not stat-vec) (let ((newvec (vector 0 0))) (hash-table-set! *db-stats* cmd newvec) (set! stat-vec newvec))) (vector-set! stat-vec 0 (+ (vector-ref stat-vec 0) 1)) (vector-set! stat-vec 1 (+ (vector-ref stat-vec 1) duration))) (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 "DB Stats\n========") + (debug:print 18 (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 (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))))))) + +(define (rmt:get-max-query-average) + (mutex-lock! *db-stats-mutex*) + (let* ((cmds (hash-table-keys *db-stats*)) + (res (if (null? cmds) + (cons 'none 0) + (let loop ((cmd (car cmds)) + (tal (cdr cmds)) + (max-cmd (car cmds)) + (res 0)) +;; (if (member cmd '(delete-tests-in-state)) ;; black list these outliers +;; (if (null? tal) +;; (if (> tot 20) +;; (cons +;; + (let* ((cmd-dat (hash-table-ref *db-stats* cmd)) + (tot (vector-ref cmd-dat 0)) + (curravg (/ (vector-ref cmd-dat 1) (vector-ref cmd-dat 0))) ;; count is never zero by construction + (currmax (max res curravg)) + (newmax-cmd (if (> curravg res) cmd max-cmd))) + (if (null? tal) + (if (> tot 10) + (cons newmax-cmd currmax) + (cons 'none 0)) + (loop (car tal)(cdr tal) newmax-cmd currmax))))))) + (mutex-unlock! *db-stats-mutex*) + res)) (define (rmt:open-qry-close-locally cmd run-id params) (let* ((dbdir (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) (dbstruct-local (if *dbstruct-db* *dbstruct-db* @@ -105,11 +151,11 @@ (db-file-path (db:dbfile-path 0))) ;; (read-only (not (file-read-access? db-file-path))) (let* ((start (current-milliseconds)) (res (api:execute-requests dbstruct-local (symbol->string cmd) params)) (duration (- (current-milliseconds) start))) - (rmt:update-db-stats cmd duration) + (rmt:update-db-stats cmd params duration) res))) (define (rmt:send-receive-no-auto-client-setup connection-info cmd run-id params) (let* ((run-id (if run-id run-id 0)) (jparams (db:obj->string params)) ;; (rmt:dat->json-str params))