@@ -155,101 +155,105 @@ ;; ;; - returns #( flag result ) ;; (define (api:execute-requests dbstruct dat) (db:open-no-sync-db) ;; sets *no-sync-db* -;; (handle-exceptions -;; exn -;; (let ((call-chain (get-call-chain))) -;; (debug:print 0 *default-log-port* "WARNING: api:execute-requests received an exception from peer, dat=" dat ", exn=" exn) -;; (print-call-chain (current-error-port)) -;; (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + ;; (handle-exceptions + ;; exn + ;; (let ((call-chain (get-call-chain))) + ;; (debug:print 0 *default-log-port* "WARNING: api:execute-requests received an exception from peer, dat=" dat ", exn=" exn) + ;; (print-call-chain (current-error-port)) + ;; (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) ;; (vector #f (vector exn call-chain dat))) ;; return some stuff for debug if an exception happens (if (> *api-process-request-count* 200) (begin (if (common:low-noise-print 30 "too many threads") (debug:print 0 *default-log-port* "WARNING: "*api-process-request-count*" threads, potential overload, adding 0.5 sec delay.")) (thread-sleep! 0.5) ;; take a nap )) - (cond - ((not (vector? dat)) ;; it is an error to not receive a vector - (vector #f (vector #f "remote must be called with a vector"))) - #;((> *api-process-request-count* 200) ;; 20) - (debug:print 0 *default-log-port* "WARNING: api:execute-requests received an overloaded message.") - (set! *server-overloaded* #t) - (vector #f (vector #f 'overloaded))) ;; the inner vector is what gets returned. nope, don't know why. please refactor! - (else - (let* ((cmd-in (vector-ref dat 0)) - (cmd (if (symbol? cmd-in) - cmd-in - (string->symbol cmd-in))) - (params (vector-ref dat 1)) - (run-id (if (null? params) - 0 - (car params))) - (write-mutex (if (hash-table-exists? *db-write-mutexes* run-id) - (hash-table-ref *db-write-mutexes* run-id) - (let* ((newmutex (make-mutex))) - (hash-table-set! *db-write-mutexes* run-id newmutex) - newmutex))) - (start-t (current-milliseconds)) - (readonly-mode (dbr:dbstruct-read-only dbstruct)) - (readonly-command (member cmd api:read-only-queries)) - (writecmd-in-readonly-mode (and readonly-mode (not readonly-command)))) - (if (not readonly-command) - (mutex-lock! write-mutex)) - (let* ((tmppath (dbr:dbstruct-tmppath dbstruct)) - (clean-run-id (cond - ((number? run-id) run-id) - ((equal? run-id #f) "main") - (else "other"))) - (crumbfile (dbfile:wait-for-qif tmppath clean-run-id (cons cmd params))) - (res - (if writecmd-in-readonly-mode - (conc "attempt to run write command "cmd" on a read-only database") - (api:dispatch-request dbstruct cmd run-id params)))) - (delete-file* crumbfile) - (if (not readonly-command) - (mutex-unlock! write-mutex)) - - ;; save all stats - (let ((delta-t (- (current-milliseconds) - start-t)) - (modified-cmd (if (eq? cmd 'general-call) - (string->symbol (conc "general-call-" (car params))) - cmd))) - (hash-table-set! *db-api-call-time* modified-cmd - (cons delta-t (hash-table-ref/default *db-api-call-time* modified-cmd '())))) - (if writecmd-in-readonly-mode - (begin - #;(common:telemetry-log (conc "api-out:"(->string cmd)) - payload: `((params . ,params) - (ok-res . #t))) - (vector #f res)) - (begin - #;(common:telemetry-log (conc "api-out:"(->string cmd)) - payload: `((params . ,params) - (ok-res . #f))) - (vector #t res)))))))) + (cond + ((not (vector? dat)) ;; it is an error to not receive a vector + (vector #f (vector #f "remote must be called with a vector"))) + #;((> *api-process-request-count* 200) ;; 20) + (debug:print 0 *default-log-port* "WARNING: api:execute-requests received an overloaded message.") + (set! *server-overloaded* #t) + (vector #f (vector #f 'overloaded))) ;; the inner vector is what gets returned. nope, don't know why. please refactor! + (else + (let* ((cmd-in (vector-ref dat 0)) + (cmd (if (symbol? cmd-in) + cmd-in + (string->symbol cmd-in))) + (params (vector-ref dat 1)) + (run-id (if (null? params) + 0 + (car params))) + (write-mutex (if (hash-table-exists? *db-write-mutexes* run-id) + (hash-table-ref *db-write-mutexes* run-id) + (let* ((newmutex (make-mutex))) + (hash-table-set! *db-write-mutexes* run-id newmutex) + newmutex))) + (start-t (current-milliseconds)) + (readonly-mode (dbr:dbstruct-read-only dbstruct)) + (readonly-command (member cmd api:read-only-queries)) + (writecmd-in-readonly-mode (and readonly-mode (not readonly-command)))) + (if (not readonly-command) + (mutex-lock! write-mutex)) + (let* ((tmppath (dbr:dbstruct-tmppath dbstruct)) + (clean-run-id (cond + ((number? run-id) run-id) + ((equal? run-id #f) "main") + (else "other"))) + (crumbfile (dbfile:wait-for-qif tmppath clean-run-id (cons cmd params))) + (res + (if writecmd-in-readonly-mode + (conc "attempt to run write command "cmd" on a read-only database") + (api:dispatch-request dbstruct cmd run-id params)))) + (delete-file* crumbfile) + (if (not readonly-command) + (mutex-unlock! write-mutex)) + + ;; save all stats + (let ((delta-t (- (current-milliseconds) + start-t)) + (modified-cmd (if (eq? cmd 'general-call) + (string->symbol (conc "general-call-" (car params))) + cmd))) + (hash-table-set! *db-api-call-time* modified-cmd + (cons delta-t (hash-table-ref/default *db-api-call-time* modified-cmd '())))) + (if writecmd-in-readonly-mode + (begin + #;(common:telemetry-log (conc "api-out:"(->string cmd)) + payload: `((params . ,params) + (ok-res . #t))) + (vector #f res)) + (begin + #;(common:telemetry-log (conc "api-out:"(->string cmd)) + payload: `((params . ,params) + (ok-res . #f))) + (vector #t res)))))))) ;; indat is (cmd run-id params meta) +;; +;; WARNING: Do not print anything in this function as it reads/writes to current in/out port +;; (define (api:tcp-dispatch-request-make-handler dbstruct) ;; cmd run-id params) (lambda () (let* ((indat (deserialize))) (set! *api-process-request-count* (+ *api-process-request-count* 1)) (match indat ((cmd run-id params meta) (let* ((status (cond - ((> *api-process-request-count* 50) 'busy) - ((> *api-process-request-count* 25) 'loaded) + ;; turn off busy throttling while trying to get things stable + ;; ((> *api-process-request-count* 50) 'busy) + ;; ((> *api-process-request-count* 25) 'loaded) (else 'ok))) (errmsg (case status ((busy) (conc "Server overloaded, "*api-process-request-count*" threads in flight")) ((loaded) (conc "Server loaded, "*api-process-request-count*" threads in flight")) (else #f))) (result (case status - ((busy) #f) + ((busy loaded) #f) (else (case cmd ((ping) (tt:mk-signature *toppath*)) (else (api:dispatch-request dbstruct cmd run-id params)))))) @@ -259,10 +263,11 @@ (else (assert #f "FATAL: failed to deserialize indat "indat)))))) (define (api:dispatch-request dbstruct cmd run-id params) + (db:open-no-sync-db) (case cmd ;;=============================================== ;; READ/WRITE QUERIES ;;===============================================