00fd18bc62
- fix connection-pool for nested tx, fix race condition - ensure connected? always nonblocking - added and reorganized some doc sections - added grouping, contracts to in-query - added rows->dict
59 lines
1.9 KiB
Racket
59 lines
1.9 KiB
Racket
#lang racket/base
|
|
(require racket/contract
|
|
racket/class
|
|
ffi/unsafe/atomic
|
|
"../private/generic/interfaces.rkt"
|
|
"../private/generic/common.rkt")
|
|
|
|
(define high-latency-connection%
|
|
(class* locking% (connection<%>)
|
|
(init-private connection
|
|
latency
|
|
sleep-atomic?)
|
|
(inherit call-with-lock)
|
|
(super-new)
|
|
|
|
(define-syntax-rule (define-forward defmethod (sleep-factor method arg ...) ...)
|
|
(begin
|
|
(defmethod (method arg ...)
|
|
(call-with-lock 'method
|
|
(lambda ()
|
|
(let ([c connection])
|
|
(unless c (error/not-connected 'method))
|
|
(when (positive? sleep-factor)
|
|
(if sleep-atomic?
|
|
(call-as-atomic (lambda () (sleep (* sleep-factor latency))))
|
|
(sleep (* sleep-factor latency))))
|
|
(send c method arg ...)))))
|
|
...))
|
|
|
|
(define-forward define/public
|
|
(0 get-dbsystem)
|
|
(2 query fsym stmt cursor?) ;; 2 because may require implicit prepare
|
|
(1 prepare fsym stmt close-on-exec?)
|
|
(1 fetch/cursor fsym stmt fetch-size)
|
|
(0 get-base)
|
|
(0 free-statement stmt need-lock?)
|
|
(0 transaction-status fsym)
|
|
(1 start-transaction fsym isolation cwt?)
|
|
(1 end-transaction fsym mode cwt?)
|
|
(1 list-tables fsym schema))
|
|
|
|
(define/override (connected?) (and connection (send connection connected?)))
|
|
|
|
(define/public (disconnect)
|
|
(set! connection #f))))
|
|
|
|
(define (high-latency-connection connection latency
|
|
#:sleep-atomic? [sleep-atomic? #f])
|
|
(new high-latency-connection%
|
|
[connection connection]
|
|
[latency latency]
|
|
[sleep-atomic? sleep-atomic?]))
|
|
|
|
(provide/contract
|
|
[high-latency-connection
|
|
(->* (connection? (>=/c 0))
|
|
(#:sleep-atomic? any/c)
|
|
connection?)])
|