suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

db: made sql data serializable

Browse Source
This commit is contained in:
Ryan Culpepper 2011-08-31 23:07:02 -06:00
parent 69a56ef683
commit f4d712ac71
3 changed files with 71 additions and 91 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

76
collects/db/private/generic/place-client.rkt
View File

@ -4,15 +4,18 @@
racket/place
racket/promise
racket/vector
racket/serialize
ffi/unsafe/atomic
"interfaces.rkt"
"prepared.rkt"
"sql-data.rkt")
(provide place-connect
place-proxy-connection%
place-proxy-connection%)
sql-datum->sexpr
sexpr->sql-datum)
(define (pchan-put chan datum)
(place-channel-put chan (serialize datum)))
(define (pchan-get chan)
(deserialize (place-channel-get chan)))
(define connection-server-channel
(delay/sync
@ -22,7 +25,7 @@
(let-values ([(channel other-channel) (place-channel)])
(place-channel-put (force connection-server-channel)
(list 'connect other-channel connection-spec))
(match (place-channel-get channel)
(match (pchan-get channel)
[(list 'ok)
(new proxy% (channel channel))]
[(list 'error message)
@ -41,10 +44,10 @@
(call-with-lock* method-name (lambda () (call* method-name args #f)) #f #f))
(define/private (call* method-name args need-connected?)
(cond [channel
(place-channel-put channel (cons method-name args))
(match (place-channel-get channel)
(pchan-put channel (cons method-name args))
(match (pchan-get channel)
[(cons 'values vals)
(apply values (for/list ([val (in-list vals)]) (translate-result val)))]
(apply values (for/list ([val (in-list vals)]) (sexpr->result val)))]
[(list 'error message)
(raise (make-exn:fail message (current-continuation-marks)))])]
[need-connected?
@ -67,13 +70,18 @@
(call 'query fsym
(match stmt
[(? string?) (list 'string stmt)]
[(statement-binding pst _meta params)
(list 'statement-binding
(send pst get-handle)
(map sql-datum->sexpr params))])))
[(statement-binding pst meta params)
(list 'statement-binding (send pst get-handle) meta params)])))
(define/public (prepare fsym stmt close-on-exec?)
(call 'prepare fsym stmt close-on-exec?))
(define/public (transaction-status fsym)
(call 'transaction-status fsym))
(define/public (start-transaction fsym iso)
(call 'start-transaction fsym iso))
(define/public (end-transaction fsym mode)
(call 'end-transaction fsym mode))
(define/public (list-tables fsym schema)
(call 'list-tables fsym schema))
(define/public (free-statement pst)
(start-atomic)
@ -83,27 +91,12 @@
(when channel
(call/d 'free-statement handle))))
(define/public (transaction-status fsym)
(call 'transaction-status fsym))
(define/public (start-transaction fsym iso)
(call 'start-transaction fsym iso))
(define/public (end-transaction fsym mode)
(call 'end-transaction fsym mode))
(define/public (list-tables fsym schema)
(call 'list-tables fsym schema))
(define/private (translate-result x)
(define/private (sexpr->result x)
(match x
[(list 'simple-result y)
(simple-result y)]
[(list 'rows-result h rows)
(let ([rows
(for/list ([row (in-list rows)])
(vector-map sexpr->sql-datum row))])
(rows-result h rows))]
(rows-result h rows)]
[(list 'prepared-statement handle close-on-exec? param-typeids result-dvecs)
(new prepared-statement%
(handle handle)
@ -111,27 +104,4 @@
(param-typeids param-typeids)
(result-dvecs result-dvecs)
(owner this))]
[_ x]))
))
(define (sql-datum->sexpr x)
(match x
[(? sql-null?)
'sql-null]
[(sql-date Y M D)
(list 'sql-date Y M D)]
[(sql-time h m s ns tz)
(list 'sql-time h m s ns tz)]
[(sql-timestamp Y M D h m s ns tz)
(list 'sql-timestamp Y M D h m s ns tz)]
;; FIXME: add sql-interval when implemented for odbc
[_ x]))
(define (sexpr->sql-datum x)
(match x
['sql-null sql-null]
[(list 'sql-date Y M D) (sql-date Y M D)]
[(list 'sql-time h m s ns tz) (sql-time h m s ns tz)]
[(list 'sql-timestamp Y M D h m s ns tz)
(sql-timestamp Y M D h m s ns tz)]
[else x]))
[_ x]))))

59
collects/db/private/generic/place-server.rkt
View File

@ -3,6 +3,7 @@
racket/class
racket/match
racket/place
racket/serialize
"lazy-require.rkt"
"interfaces.rkt"
"prepared.rkt"
@ -10,6 +11,11 @@
"place-client.rkt")
(provide connection-server)
(define (pchan-put chan datum)
(place-channel-put chan (serialize datum)))
(define (pchan-get chan)
(deserialize (place-channel-get chan)))
#|
Connection creation protocol
@ -37,8 +43,7 @@ where <connect-spec> ::= (list 'sqlite3 path/sym mode-sym delay-num limit-num)
[(list 'connect conn-chan connect-spec)
(with-handlers ([exn:fail?
(lambda (e)
(place-channel-put conn-chan
(list 'error (exn-message e))))])
(pchan-put conn-chan (list 'error (exn-message e))))])
(let* ([c
(match connect-spec
[(list 'sqlite3 db mode busy-retry-delay busy-retry-limit)
@ -60,7 +65,7 @@ where <connect-spec> ::= (list 'sqlite3 path/sym mode-sym delay-num limit-num)
#:character-mode char-mode
#:use-place #f)])]
[p (new proxy-server% (connection c) (channel conn-chan))])
(place-channel-put conn-chan (list 'ok))
(pchan-put conn-chan (list 'ok))
(thread (lambda () (send p serve)))))]))
#|
@ -87,53 +92,45 @@ server -> client: (or (list 'values result ...)
(define/private (serve1)
(with-handlers ([exn?
(lambda (e)
(place-channel-put channel (list 'error (exn-message e))))])
(pchan-put channel (list 'error (exn-message e))))])
(call-with-values
(lambda ()
(match (place-channel-get channel)
(match (pchan-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)]
[(list 'query fsym stmt)
(send connection query fsym (sexpr->statement stmt))]
[msg
(define-syntax-rule (forward-methods (method (arg translate) ...) ...)
(define-syntax-rule (forward-methods (method arg ...) ...)
(match msg
[(list 'method arg ...)
(send connection method (translate arg) ...)]
...))
(define-syntax-rule (id x) x)
[(list 'method arg ...)
(send connection method arg ...)]
...))
(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)))]))
(prepare w s m)
(list-tables w s)
(start-transaction w m)
(end-transaction w m)
(transaction-status w))]))
(lambda results
(let ([results (for/list ([result (in-list results)]) (translate-result result))])
(place-channel-put channel (cons 'values results)))))))
(let ([results (for/list ([result (in-list results)]) (result->sexpr result))])
(pchan-put channel (cons 'values results)))))))
(define/private (translate-in-stmt x)
(define/private (sexpr->statement 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))]))
[(list 'string s) s]
[(list 'statement-binding pstmt-index meta args)
(statement-binding (hash-ref pstmt-table pstmt-index) meta args)]))
(define/private (translate-result x)
(define/private (result->sexpr 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%)))

27
collects/db/private/generic/sql-data.rkt
View File

@ -1,4 +1,5 @@
#lang racket/base
(require racket/serialize)
(provide (all-defined-out))
;; SQL Data
@ -10,8 +11,15 @@
(define sql-null
(let ()
(define-struct sql-null ())
(make-sql-null)))
(struct sql-null ()
;; must deserialize to singleton, so can't just use serializable-struct
#:property prop:serializable
(make-serialize-info (lambda _ '#())
#'deserialize-info:sql-null-v0
#f
(or (current-load-relative-directory)
(current-directory))))
(sql-null)))
(define (sql-null? x)
(eq? x sql-null))
@ -26,6 +34,11 @@
sql-null
x))
(define deserialize-info:sql-null-v0
(make-deserialize-info
(lambda _ sql-null)
(lambda () (error 'deserialize-sql-null "cannot have cycles"))))
;; ----------------------------------------
;; Dates and times
@ -44,15 +57,15 @@
- timezone offset too limited
|#
(define-struct sql-date (year month day) #:transparent)
(define-struct sql-time (hour minute second nanosecond tz) #:transparent)
(define-struct sql-timestamp
(define-serializable-struct sql-date (year month day) #:transparent)
(define-serializable-struct sql-time (hour minute second nanosecond tz) #:transparent)
(define-serializable-struct sql-timestamp
(year month day hour minute second nanosecond tz)
#:transparent)
;; Intervals must be "pre-multiplied" rather than carry extra sign field.
;; Rationale: postgresql, at least, allows mixture of signs, eg "1 month - 30 days"
(define-struct sql-interval
(define-serializable-struct sql-interval
(years months days hours minutes seconds nanoseconds)
#:transparent
#:guard (lambda (years months days hours minutes seconds nanoseconds _name)
@ -131,7 +144,7 @@ byte. (Because that's PostgreSQL's binary format.) For example:
(bytes 128 3) represents 1000000 0000011
|#
(struct sql-bits (length bv offset))
(serializable-struct sql-bits (length bv offset))
(define (make-sql-bits len)
(sql-bits len (make-bytes (/ceiling len 8) 0) 0))