From f4d712ac71151ccf7b76dd546f3f0da561cb41eb Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Wed, 31 Aug 2011 23:07:02 -0600 Subject: [PATCH] db: made sql data serializable --- collects/db/private/generic/place-client.rkt | 76 ++++++-------------- collects/db/private/generic/place-server.rkt | 59 ++++++++------- collects/db/private/generic/sql-data.rkt | 27 +++++-- 3 files changed, 71 insertions(+), 91 deletions(-) diff --git a/collects/db/private/generic/place-client.rkt b/collects/db/private/generic/place-client.rkt index d22dd81472..3f51cca579 100644 --- a/collects/db/private/generic/place-client.rkt +++ b/collects/db/private/generic/place-client.rkt @@ -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])))) diff --git a/collects/db/private/generic/place-server.rkt b/collects/db/private/generic/place-server.rkt index dba93176d4..2e6e24c1c2 100644 --- a/collects/db/private/generic/place-server.rkt +++ b/collects/db/private/generic/place-server.rkt @@ -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 ::= (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 ::= (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%))) diff --git a/collects/db/private/generic/sql-data.rkt b/collects/db/private/generic/sql-data.rkt index 6336173377..732972fd64 100644 --- a/collects/db/private/generic/sql-data.rkt +++ b/collects/db/private/generic/sql-data.rkt @@ -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))