Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -303,53 +303,10 @@ (cons 'none 0)) (loop (car tal)(cdr tal) newmax-cmd currmax))))))) (mutex-unlock! *db-stats-mutex*) res)) -(define (rmt:open-qry-close-locally log-port multi-sync-mutex cmd run-id params #!key (remretries 5)) - (let* ((qry-is-write (not (member cmd api:read-only-queries))) - (db-file-path (db:dbfile-path)) ;; 0)) - (dbstruct-local (db:setup #t)) ;; make-dbr:dbstruct path: dbdir local: #t))) - (read-only (not (file-write-access? db-file-path))) - (start (current-milliseconds)) - (resdat (if (not (and read-only qry-is-write)) - (let ((v (api:execute-requests dbstruct-local (vector (symbol->string cmd) params)))) - (handle-exceptions ;; there has been a long history of receiving strange errors from values returned by the client when things go wrong.. - exn ;; This is an attempt to detect that situation and recover gracefully - (begin - (debug:print0 log-port "ERROR: bad data from server " v " message: " ((condition-property-accessor 'exn 'message) exn)) - (vector #t '())) ;; should always get a vector but if something goes wrong return a dummy - (if (and (vector? v) - (> (vector-length v) 1)) - (let ((newvec (vector (vector-ref v 0)(vector-ref v 1)))) - newvec) ;; by copying the vector while inside the error handler we should force the detection of a corrupted record - (vector #t '())))) ;; we could also check that the returned types are valid - (vector #t '()))) - (success (vector-ref resdat 0)) - (res (vector-ref resdat 1)) - (duration (- (current-milliseconds) start))) - (if (and read-only qry-is-write) - (debug:print 0 log-port "ERROR: attempt to write to read-only database ignored. cmd=" cmd)) - (if (not success) - (if (> remretries 0) - (begin - (debug:print-error 0 log-port "local query failed. Trying again.") - (thread-sleep! (/ (random 5000) 1000)) ;; some random delay - (rmt:open-qry-close-locally log-port multi-sync-mutex cmd run-id params remretries: (- remretries 1))) - (begin - (debug:print-error 0 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, the watchdog is responsible for syncing it - (if qry-is-write - (let ((start-time (current-seconds))) - (mutex-lock! multi-sync-mutex) - ;; (set! *db-last-access* start-time) ;; THIS IS PROBABLY USELESS? (we are on a client) - (mutex-unlock! multi-sync-mutex))))) - res)) - (define (rmt:send-receive-no-auto-client-setup connection-info cmd run-id params) (let* ((run-id (if run-id run-id 0)) (res (handle-exceptions exn #f @@ -906,7 +863,10 @@ (rmt:send-receive 'test-get-archive-block-info #f (list archive-block-id))) (set-functions rmt:send-receive remote-server-url-set! http-transport:close-connections remote-conndat-set! debug:print debug:print-info + debug:print-error remote-ro-mode remote-ro-mode-set! - remote-ro-mode-checked-set! remote-ro-mode-checked) + remote-ro-mode-checked-set! remote-ro-mode-checked + db:dbfile-path db:setup + api:execute-requests api:read-only-queries) Index: rmtmod.scm ================================================================== --- rmtmod.scm +++ rmtmod.scm @@ -39,27 +39,90 @@ (define (remote-ro-mode-set! . params) #f) (define (remote-ro-mode-checked-set! . params) #f) (define (remote-ro-mode-checked . params) #f) (define (debug:print . params) #f) (define (debug:print-info . params) #f) +(define (debug:print-error . params) #f) +(define (db:dbfile-path . params) #f) +(define (db:setup . params) #f) +(define (api:execute-requests . params) #f) +(define (api:read-only-queries . params) #f) (define (set-functions send-receive rsus close-connections rcs dbgp dbgpinfo + dbgperr ro-mode ro-mode-set ro-mode-checked-set ro-mode-checked + + dbfile-path dbsetup + exec-req read-only-queries ) (set! rmt:send-receive send-receive) (set! remote-server-url-set! rsus) (set! http-transport:close-connections close-connections) (set! remote-conndat-set! rcs) + ;; print stuff (set! debug:print dbgp) (set! debug:print-info dbgpinfo) + (set! debug:print-error dbgperr) + ;; (set! remote-ro-mode ro-mode) (set! remote-ro-mode-set! ro-mode-set) (set! remote-ro-mode-checked-set! ro-mode-checked-set) - (set! remote-ro-mode-checked ro-mode-checked)) + (set! remote-ro-mode-checked ro-mode-checked) + ;; db stuff for local db access + (set! db:dbfile-path dbfile-path) + (set! db:setup dbsetup) + (set! apt:execute-requests exec-req) + (set! api:read-only-queries read-only-queries) + ) + +(define (rmt:open-qry-close-locally log-port multi-sync-mutex cmd run-id params #!key (remretries 5)) + (let* ((qry-is-write (not (member cmd api:read-only-queries))) + (db-file-path (db:dbfile-path)) ;; 0)) + (dbstruct-local (db:setup #t)) ;; make-dbr:dbstruct path: dbdir local: #t))) + (read-only (not (file-write-access? db-file-path))) + (start (current-milliseconds)) + (resdat (if (not (and read-only qry-is-write)) + (let ((v (api:execute-requests dbstruct-local (vector (symbol->string cmd) params)))) + (handle-exceptions ;; there has been a long history of receiving strange errors from values returned by the client when things go wrong.. + exn ;; This is an attempt to detect that situation and recover gracefully + (begin + (debug:print 0 log-port "ERROR: bad data from server " v " message: " ((condition-property-accessor 'exn 'message) exn)) + (vector #t '())) ;; should always get a vector but if something goes wrong return a dummy + (if (and (vector? v) + (> (vector-length v) 1)) + (let ((newvec (vector (vector-ref v 0)(vector-ref v 1)))) + newvec) ;; by copying the vector while inside the error handler we should force the detection of a corrupted record + (vector #t '())))) ;; we could also check that the returned types are valid + (vector #t '()))) + (success (vector-ref resdat 0)) + (res (vector-ref resdat 1)) + (duration (- (current-milliseconds) start))) + (if (and read-only qry-is-write) + (debug:print 0 log-port "ERROR: attempt to write to read-only database ignored. cmd=" cmd)) + (if (not success) + (if (> remretries 0) + (begin + (debug:print-error 0 log-port "local query failed. Trying again.") + (thread-sleep! (/ (random 5000) 1000)) ;; some random delay + (rmt:open-qry-close-locally log-port multi-sync-mutex cmd run-id params remretries: (- remretries 1))) + (begin + (debug:print-error 0 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, the watchdog is responsible for syncing it + #;(if qry-is-write + (let ((start-time (current-seconds))) + (mutex-lock! multi-sync-mutex) + (set! *db-last-access* start-time) ;; THIS IS PROBABLY USELESS? (we are on a client) + (mutex-unlock! multi-sync-mutex))))) + res)) + + (define (rmtmod:calc-ro-mode runremote *toppath*) (if (and runremote (remote-ro-mode-checked runremote)) (remote-ro-mode runremote)