@@ -18,18 +18,21 @@ ;; ;;====================================================================== (declare (unit api)) (declare (uses db)) +(declare (uses apimod)) + (declare (uses debugprint)) (declare (uses commonmod)) (declare (uses dbmod)) (declare (uses dbfile)) (declare (uses tasks)) (declare (uses tcp-transportmod)) (import commonmod) +(import apimod) (import dbmod) (import dbfile) (import debugprint) (import tcp-transportmod) @@ -38,255 +41,16 @@ posix matchable s11n typed-records) -;; allow these queries through without starting a server -;; -(define api:read-only-queries - '(get-key-val-pairs - get-var - get-keys - get-key-vals - test-toplevel-num-items - get-test-info-by-id - get-test-state-status-by-id - get-steps-info-by-id - get-data-info-by-id - test-get-rundir-from-test-id - get-count-tests-running-for-testname - get-count-tests-running - get-count-tests-running-in-jobgroup - get-previous-test-run-record - get-matching-previous-test-run-records - test-get-logfile-info - test-get-records-for-index-file - get-testinfo-state-status - test-get-top-process-pid - test-get-paths-matching-keynames-target-new - get-prereqs-not-met - get-count-tests-running-for-run-id - get-run-info - get-run-status - get-run-state - get-run-stats - get-run-times - get-target - get-targets - ;; register-run - get-tests-tags - get-test-times - get-tests-for-run - get-tests-for-run-state-status - get-test-id - get-tests-for-runs-mindata - get-tests-for-run-mindata - get-run-name-from-id - get-runs - simple-get-runs - get-num-runs - get-runs-cnt-by-patt - get-all-run-ids - get-prev-run-ids - get-run-ids-matching-target - get-runs-by-patt - get-steps-data - get-steps-for-test - read-test-data - read-test-data-varpatt - login - tasks-get-last - testmeta-get-record - have-incompletes? - get-changed-record-ids - get-all-runids - get-changed-record-test-ids - get-changed-record-run-ids - get-run-record-ids - get-not-completed-cnt)) - -(define api:write-queries - '( - get-keys-write ;; dummy "write" query to force server start - - ;; SERVERS - ;; start-server - ;; kill-server - - ;; TESTS - test-set-state-status-by-id - delete-test-records - delete-old-deleted-test-records - test-set-state-status - test-set-top-process-pid - set-state-status-and-roll-up-items - - update-pass-fail-counts - top-test-set-per-pf-counts ;; (db:top-test-set-per-pf-counts (db:get-db *db* 5) 5 "runfirst") - - ;; RUNS - register-run - set-tests-state-status - delete-run - lock/unlock-run - update-run-event_time - mark-incomplete - set-state-status-and-roll-up-run - ;; STEPS - teststep-set-status! - delete-steps-for-test - ;; TEST DATA - test-data-rollup - csv->test-data - - ;; MISC - sync-cachedb->db - drop-all-triggers - create-all-triggers - update-tesdata-on-repilcate-db - - ;; TESTMETA - testmeta-add-record - testmeta-update-field - - ;; TASKS - tasks-add - tasks-set-state-given-param-key - )) - -(define *db-write-mutexes* (make-hash-table)) -(define *server-signature* #f) - -(define *api-threads* '()) -(define (api:register-thread th-in) - (set! *api-threads* (cons (cons th-in (current-seconds)) *api-threads*))) - -(define (api:unregister-thread th-in) - (set! *api-threads* (filter (lambda (thdat) - (not (eq? th-in (car thdat)))) - *api-threads*))) - -(define (api:remove-dead-or-terminated) - (set! *api-threads* (filter (lambda (thdat) - (not (member (thread-state (car thdat)) '(terminated dead)))) - *api-threads*))) - -(define (api:get-count-threads-alive) - (length *api-threads*)) - -(define *api:last-stats-print* 0) -(define *api-print-db-stats-mutex* (make-mutex)) -(define (api:print-db-stats) - (debug:print-info 0 *default-log-port* "Started periodic db stats printer") - (let loop () - (mutex-lock! *api-print-db-stats-mutex*) - (if (> (- (current-seconds) *api:last-stats-print*) 15) - (begin - (rmt:print-db-stats) - (set! *api:last-stats-print* (current-seconds)))) - (mutex-unlock! *api-print-db-stats-mutex*) - (thread-sleep! 5) - (loop))) - -(define *api:queue-mutex* (make-mutex)) -(define *api:in-queue* '()) -(define *api:out-queue* '()) - -(define (api:start-queue-processor) - ;; look for work in in-queue - ;; process it - ;; put result in out-queue - ;; sleep 20ms - - #t) - -(defstuct api:queue-item - (proc #f) - (cmd #f) - (params #f) - (start-time (current-seconds)) - (end-time #f) - (id #f)) - -(define (api:add-queue-item proc cmd params) - #f) + +;; QUEUE METHOD (define (api:tcp-dispatch-request-make-handler-new dbstruct) ;; cmd run-id params) - - ;; put proc into in-queue - ;; poll out-queue for result evey 25ms - ;; time out with big message - - (assert *toppath* "FATAL: api:tcp-dispatch-request-make-handler called but *toppath* not set.") - (if (not *server-signature*) - (set! *server-signature* (tt:mk-signature *toppath*))) - (lambda (indat) - (let* ((result - (let* ((numthreads (api:get-count-threads-alive)) - (delay-wait (if (> numthreads 10) - (- numthreads 10) - 0)) - (normal-proc (lambda (cmd run-id params) - (case cmd - ((ping) *server-signature*) - (else - (api:dispatch-request dbstruct cmd run-id params)))))) - (set! *api-process-request-count* numthreads) - (set! *db-last-access* (current-seconds)) -;; (if (not (eq? numthreads numthreads)) -;; (begin -;; (api:remove-dead-or-terminated) -;; (let ((threads-now (api:get-count-threads-alive))) -;; (debug:print 0 *default-log-port* "WARNING: numthreads="numthreads", numthreads="numthreads", remaining="threads-now) -;; (set! numthreads threads-now)))) - (match indat - ((cmd run-id params meta) - (let* ((start-t (current-milliseconds)) - (db-ok (let* ((dbfname (dbmod:run-id->dbfname run-id)) - (ok (equal? dbfname (dbr:dbstruct-dbfname dbstruct)))) - (case cmd - ((ping) #t) ;; we are fine - (else - (assert ok "FATAL: database file and run-id not aligned."))))) - (ttdat *server-info*) - (server-state (tt-state ttdat)) - (maxthreads 20) ;; make this a parameter? - (status (cond - ((and (> numthreads maxthreads) - (> (random 100) 70)) ;; allow a 30% probability to go through so we can figure out what is going wrong in main.db server. - 'busy) - ;; ((> numthreads 5) 'loaded) ;; this gets transmitted to the client which calls tt:backoff-incr to slow stuff down. - (else 'ok))) - (errmsg (case status - ((busy) (conc "Server overloaded, "numthreads" threads in flight")) - ((loaded) (conc "Server loaded, "numthreads" threads in flight")) - (else #f))) - (result (case status - ((busy) - (if (eq? cmd 'ping) - (normal-proc cmd run-id params) - ;; numthreads must be greater than 5 for busy - (* 0.1 (- numthreads maxthreads)) ;; was 15 - return a number for the remote to delay - )) ;; (- numthreads 29)) ;; call back in as many seconds - ((loaded) - ;; (if (eq? (rmt:transport-mode) 'tcp) - ;; (thread-sleep! 0.5)) - (normal-proc cmd run-id params)) - (else - (normal-proc cmd run-id params)))) - (meta (case cmd - ((ping) `((sstate . ,server-state))) - (else `((wait . ,delay-wait))))) - (payload (list status errmsg result meta))) - ;; (cmd run-id params meta) - (db:add-stats cmd run-id params (- (current-milliseconds) start-t)) - payload)) - (else - (assert #f "FATAL: failed to deserialize indat "indat)))))) - result))) - -(define api:tcp-dispatch-request-make-handler api:tcp-dispatch-request-make-handler-old) + (api:tcp-dispatch-request-make-handler-core dbstruct api:dispatch-request)) + ;; indat is (cmd run-id params meta) ;; ;; WARNING: Do not print anything in the lambda of this function as it ;; reads/writes to current in/out port @@ -363,11 +127,11 @@ ;; (serialize payload) (api:unregister-thread (current-thread)) result))) - +(define api:tcp-dispatch-request-make-handler api:tcp-dispatch-request-make-handler-old) ;; choose -old or -new (define *api-halt-writes* #f) (define (api:dispatch-request dbstruct cmd run-id params) (if (not *no-sync-db*)