148 lines
5.6 KiB
Racket
148 lines
5.6 KiB
Racket
#lang racket/base
|
|
(require (for-syntax racket/base)
|
|
racket/class
|
|
racket/match
|
|
racket/place
|
|
"lazy-require.rkt"
|
|
"interfaces.rkt"
|
|
"prepared.rkt"
|
|
"sql-data.rkt"
|
|
"place-client.rkt")
|
|
(provide connection-server)
|
|
|
|
#|
|
|
Connection creation protocol
|
|
|
|
client -> server on client-chan: (list 'connect conn-chan <connect-options>)
|
|
server -> client on conn-chan: (or (list 'ok)
|
|
(list 'error string))
|
|
|
|
where <connect-spec> ::= (list 'sqlite3 path/sym mode-sym delay-num limit-num)
|
|
| (list 'odbc string string/#f string/#f boolean symbol)
|
|
|#
|
|
(define (connection-server client-chan)
|
|
(let loop ()
|
|
(serve client-chan)
|
|
(loop)))
|
|
|
|
(define-lazy-require-definer define-main "../../main.rkt")
|
|
|
|
(define-main
|
|
sqlite3-connect
|
|
odbc-connect
|
|
odbc-driver-connect)
|
|
|
|
(define (serve client-chan)
|
|
(match (place-channel-get client-chan)
|
|
[(list 'connect conn-chan connect-spec)
|
|
(with-handlers ([exn:fail?
|
|
(lambda (e)
|
|
(place-channel-put conn-chan
|
|
(list 'error (exn-message e))))])
|
|
(let* ([c
|
|
(match connect-spec
|
|
[(list 'sqlite3 db mode busy-retry-delay busy-retry-limit)
|
|
(sqlite3-connect #:database db
|
|
#:mode mode
|
|
#:busy-retry-delay busy-retry-delay
|
|
#:busy-retry-limit busy-retry-limit
|
|
#:use-place #f)]
|
|
[(list 'odbc dsn user password strict-param? char-mode)
|
|
(odbc-connect #:dsn dsn
|
|
#:user user
|
|
#:password password
|
|
#:strict-parameter-types? strict-param?
|
|
#:character-mode char-mode
|
|
#:use-place #f)]
|
|
[(list 'odbc-driver connection-string strict-param? char-mode)
|
|
(odbc-driver-connect connection-string
|
|
#:strict-parameter-types? strict-param?
|
|
#:character-mode char-mode
|
|
#:use-place #f)])]
|
|
[p (new proxy-server% (connection c) (channel conn-chan))])
|
|
(place-channel-put conn-chan (list 'ok))
|
|
(thread (lambda () (send p serve)))))]))
|
|
|
|
#|
|
|
Connection methods protocol
|
|
|
|
client -> server: (list '<method-name> arg ...)
|
|
server -> client: (or (list 'values result ...)
|
|
(list 'error string))
|
|
|#
|
|
|
|
(define proxy-server%
|
|
(class object%
|
|
(init-field connection
|
|
channel)
|
|
(super-new)
|
|
|
|
(define pstmt-table (make-hash)) ;; int => prepared-statement
|
|
(define pstmt-counter 0)
|
|
|
|
(define/public (serve)
|
|
(serve1)
|
|
(when connection (serve)))
|
|
|
|
(define/private (serve1)
|
|
(with-handlers ([exn?
|
|
(lambda (e)
|
|
(place-channel-put channel (list 'error (exn-message e))))])
|
|
(call-with-values
|
|
(lambda ()
|
|
(match (place-channel-get channel)
|
|
[(list 'disconnect)
|
|
(send connection disconnect)
|
|
(set! connection #f)]
|
|
[(list 'free-statement pstmt-index)
|
|
(send connection free-statement (hash-ref pstmt-table pstmt-index))
|
|
(hash-remove! pstmt-table pstmt-index)]
|
|
[msg
|
|
(define-syntax-rule (forward-methods (method (arg translate) ...) ...)
|
|
(match msg
|
|
[(list 'method arg ...)
|
|
(send connection method (translate arg) ...)]
|
|
...))
|
|
(define-syntax-rule (id x) x)
|
|
(forward-methods (connected?)
|
|
(query (w id) (s translate-in-stmt))
|
|
(prepare (w id) (s id) (m id))
|
|
(list-tables (w id) (s id))
|
|
(start-transaction (w id) (m id))
|
|
(end-transaction (w id) (m id))
|
|
(transaction-status (w id)))]))
|
|
(lambda results
|
|
(let ([results (for/list ([result (in-list results)]) (translate-result result))])
|
|
(place-channel-put channel (cons 'values results)))))))
|
|
|
|
(define/private (translate-in-stmt x)
|
|
(match x
|
|
[(list 'string s)
|
|
s]
|
|
[(list 'statement-binding pstmt-index args)
|
|
(statement-binding (hash-ref pstmt-table pstmt-index)
|
|
null
|
|
(map sexpr->sql-datum args))]))
|
|
|
|
(define/private (translate-result x)
|
|
(match x
|
|
[(simple-result y)
|
|
(list 'simple-result y)]
|
|
[(rows-result h rows)
|
|
(for ([row (in-list rows)])
|
|
(for ([i (in-range (vector-length row))])
|
|
(let* ([x (vector-ref row i)]
|
|
[nx (sql-datum->sexpr x)])
|
|
(unless (eq? x nx) (vector-set! row i nx)))))
|
|
(list 'rows-result h rows)]
|
|
;; FIXME: Assumes prepared-statement is concrete class, not interface.
|
|
[(? (lambda (x) (is-a? x prepared-statement%)))
|
|
(let ([pstmt-index (begin (set! pstmt-counter (add1 pstmt-counter)) pstmt-counter)])
|
|
(hash-set! pstmt-table pstmt-index x)
|
|
(list 'prepared-statement
|
|
pstmt-index
|
|
(get-field close-on-exec? x)
|
|
(get-field param-typeids x)
|
|
(get-field result-dvecs x)))]
|
|
[_ x]))))
|