From 9d34f0f147f73e0fbe22e3669fed4c1c80fecf61 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Wed, 12 Sep 2012 12:52:33 -0400 Subject: [PATCH] db: added support for postgresql 9.2 types (json, ranges) Other major changes: - pg code now uses only binary format - pg timestamptz now always UTC (tz = 0), added doc section - added contracts to most pg "can't-convert" errors --- collects/db/TODO | 4 + collects/db/main.rkt | 3 +- collects/db/private/generic/common.rkt | 45 +- collects/db/private/generic/functions.rkt | 6 +- collects/db/private/generic/interfaces.rkt | 5 +- collects/db/private/generic/prepared.rkt | 3 +- collects/db/private/generic/sql-convert.rkt | 102 +- collects/db/private/mysql/dbsystem.rkt | 56 +- collects/db/private/mysql/message.rkt | 20 +- collects/db/private/odbc/connection.rkt | 16 + collects/db/private/odbc/dbsystem.rkt | 95 +- collects/db/private/postgresql/connection.rkt | 52 +- collects/db/private/postgresql/dbsystem.rkt | 1014 ++++++++--------- collects/db/private/postgresql/message.rkt | 1 - collects/db/private/sqlite3/dbsystem.rkt | 6 +- collects/db/scribblings/config.rkt | 1 - .../db/scribblings/log-for-sql-types.rktd | 12 +- collects/db/scribblings/notes.scrbl | 35 + collects/db/scribblings/sql-types.scrbl | 28 +- collects/db/scribblings/util.scrbl | 28 + collects/db/util/postgresql.rkt | 26 +- collects/tests/db/db/sql-types.rkt | 210 +++- collects/tests/db/gen/sql-types.rkt | 53 +- 23 files changed, 1016 insertions(+), 805 deletions(-) diff --git a/collects/db/TODO b/collects/db/TODO index 67f6b852ce..8ecf6fdc92 100644 --- a/collects/db/TODO +++ b/collects/db/TODO @@ -1,4 +1,8 @@ +- postgresql: send no-arg queries without prepare step (?) + +- add under-the-hood doc section (eg, debugging, adjusting statement cache) + - type annotations - two modes: mandatory and opportunistic - on result fields (eg sqlite, convert to date) diff --git a/collects/db/main.rkt b/collects/db/main.rkt index 2983da5e2c..fa9a326140 100644 --- a/collects/db/main.rkt +++ b/collects/db/main.rkt @@ -1,6 +1,5 @@ #lang racket/base -(require (for-syntax racket/base) - unstable/lazy-require +(require unstable/lazy-require racket/contract/base "base.rkt") (provide (all-from-out "base.rkt")) diff --git a/collects/db/private/generic/common.rkt b/collects/db/private/generic/common.rkt index 5775ca7b6a..379541b956 100644 --- a/collects/db/private/generic/common.rkt +++ b/collects/db/private/generic/common.rkt @@ -4,6 +4,7 @@ ffi/unsafe/atomic "interfaces.rkt") (provide define-type-table + dbsystem-base% locking% debugging% transactions% @@ -20,38 +21,44 @@ ;; Defining type tables -(define-syntax-rule (define-type-table (supported-types - type-alias->type +(define-syntax-rule (define-type-table (type-list typeid->type - type->typeid describe-typeid) - (typeid type (alias ...) supported?) ...) + (typeid type since-version) ...) + ;; since-version is #f is this library does not support it, + ;; *DBMS* version number of introduction (0 for "virtually forever") (begin - (define all-types '((type supported?) ...)) - (define supported-types - (sort (map car (filter cadr all-types)) - stringstring - #:cache-keys? #t)) - (define (type-alias->type x) - (case x - ((alias ...) 'type) ... - (else x))) + (define type-list '((type since-version) ...)) (define (typeid->type x) (case x ((typeid) 'type) ... (else #f))) - (define (type->typeid x) - (case x - ((type) 'typeid) ... - (else #f))) (define (describe-typeid x) (let ([t (typeid->type x)] - [ok? (case x ((typeid) supported?) ... (else #f))]) + [ok? (case x ((typeid) (and since-version #t)) ... (else #f))]) (list ok? t x))))) ;; ---------------------------------------- +(define dbsystem-base% + (class object% + (super-new) + (define/public (get-known-types version) + (let* ([all-types (get-type-list)] + [supported-types + (filter (lambda (type+version) + (let ([since-version (cadr type+version)]) + (and since-version + (>= version since-version)))) + all-types)]) + (sort (map car supported-types) + stringstring + #:cache-keys? #t))) + (define/public (get-type-list) null))) + +;; ---------------------------------------- + ;; Notice/notification handler maker ;; make-handler : output-port/symbol string -> string string -> void diff --git a/collects/db/private/generic/functions.rkt b/collects/db/private/generic/functions.rkt index 46cba5c88e..0c30671b1d 100644 --- a/collects/db/private/generic/functions.rkt +++ b/collects/db/private/generic/functions.rkt @@ -1,6 +1,5 @@ #lang racket/base -(require (for-syntax racket/base) - racket/vector +(require racket/vector racket/class racket/promise unstable/error @@ -23,7 +22,8 @@ (send x get-short-name)) (define (dbsystem-supported-types x) - (send x get-known-types)) + ;; FIXME: make version sensitive? + (send x get-known-types +inf.0)) ;; == Misc procedures diff --git a/collects/db/private/generic/interfaces.rkt b/collects/db/private/generic/interfaces.rkt index 4a851c281a..80b360f90d 100644 --- a/collects/db/private/generic/interfaces.rkt +++ b/collects/db/private/generic/interfaces.rkt @@ -59,7 +59,7 @@ field-dvecs->typeids ;; (listof field-dvec) -> (listof typeid) ;; inspection only - get-known-types ;; -> (listof symbol) + get-known-types ;; real -> (listof symbol) describe-params ;; (listof typeid) -> (listof TypeDesc) describe-fields)) ;; (listof field-dvec) -> (listof TypeDesc) @@ -266,10 +266,11 @@ producing plain old exn:fail. "type" type "typeid" typeid)) -(define (error/no-convert fsym sys type param [note #f]) +(define (error/no-convert fsym sys type param [note #f] #:contract [ctc #f]) (raise-misc-error fsym "cannot convert given value to SQL type" '("given" value) param "type" type + "expected" (and ctc (format "~.s" ctc)) "dialect" sys "note" note)) diff --git a/collects/db/private/generic/prepared.rkt b/collects/db/private/generic/prepared.rkt index 6a8519cf87..3dbc6142e8 100644 --- a/collects/db/private/generic/prepared.rkt +++ b/collects/db/private/generic/prepared.rkt @@ -93,10 +93,9 @@ (when (not (= given-len expected-len)) (error/stmt-arity fsym expected-len given-len))) (for/list ([handler (in-list param-handlers)] - [index (in-naturals)] [param (in-list params)]) (cond [(sql-null? param) sql-null] - [else (handler fsym index param)]))) + [else (handler fsym param)]))) ;; ---- diff --git a/collects/db/private/generic/sql-convert.rkt b/collects/db/private/generic/sql-convert.rkt index 0953b8b993..d813070490 100644 --- a/collects/db/private/generic/sql-convert.rkt +++ b/collects/db/private/generic/sql-convert.rkt @@ -1,50 +1,12 @@ #lang racket/base -(require "interfaces.rkt") +(require racket/math) + +(provide exact->decimal-string ;; odbc, tests (?) + exact->scaled-integer ;; pg, odbc + inexact->scaled-integer) ;; pg ;; ======================================== -(provide parse-decimal ;; used by pg, mysql - parse-exact-fraction) ;; used by pg - -(define (parse-decimal s) - (cond [(equal? s "NaN") +nan.0] - [(regexp-match #rx"^-?([0-9]*)$" s) - ;; big integer - => (lambda (m) - (string->number s))] - [(regexp-match #rx"^-?([0-9]*)\\.([0-9]*)$" s) - => (lambda (m) - (+ (string->number (cadr m)) - (parse-exact-fraction (caddr m))))] - [else - (error/internal* 'parse-decimal "cannot parse as decimal" - '("string" value) s)])) - -(define (parse-exact-fraction s) - ;; eg: (parse-exact-fraction "12") = 12/100 - (/ (string->number s) - (expt 10 (string-length s)))) - -;; ======================================== - -(provide marshal-decimal ;; pg, odbc (?!) - exact->decimal-string ;; tests (?) - exact->scaled-integer) ;; odbc - -(define (marshal-decimal f i n) - (cond [(not (real? n)) - (marshal-error f i "numeric" n)] - [(eqv? n +nan.0) - "NaN"] - [(or (eqv? n +inf.0) (eqv? n -inf.0)) - (marshal-error f i "numeric" n)] - [(or (integer? n) (inexact? n)) - (number->string n)] - [(exact? n) - ;; Bleah. - (or (exact->decimal-string n) - (number->string (exact->inexact n)))])) - ;; exact->decimal-string : exact -> string or #f ;; always includes decimal point (define (exact->decimal-string n) @@ -62,17 +24,43 @@ (make-string (- ex (string-length ma-str)) #\0) ma-str)))))) -;; exact->scaled-integer : rational -> (cons int nat) or #f +;; exact->scaled-integer : exact-rational -> (cons int int) or #f ;; Given x, returns (cons M E) s.t. x = (M * 10^-E) -(define (exact->scaled-integer n) - (let* ([whole-part (truncate n)] - [fractional-part (- (abs n) (abs whole-part))] - [den (denominator fractional-part)]) - (let*-values ([(den* fives) (factor-out den 5)] - [(den** twos) (factor-out den* 2)]) - (and (= 1 den**) - (let ([tens (max fives twos)]) - (cons (* n (expt 10 tens)) tens)))))) +(define (exact->scaled-integer n [trim-integers? #f]) + (if (and trim-integers? (integer? n)) + (let*-values ([(n* fives) (factor-out n 5)] + [(n** twos) (factor-out n* 2)]) + (let ([tens (min fives twos)]) + (cons (/ n (expt 10 tens)) (- tens)))) + (let* ([whole-part (truncate n)] + [fractional-part (- (abs n) (abs whole-part))] + [den (denominator fractional-part)]) + (let*-values ([(den* fives) (factor-out den 5)] + [(den** twos) (factor-out den* 2)]) + (and (= 1 den**) + (let ([tens (max fives twos)]) + (cons (* n (expt 10 tens)) tens))))))) + +;; inexact->scaled-integer : inexact-rational -> (cons int int) +;; Given x, returns (cons M E) s.t. x ~= (M * 10^-E) +(define (inexact->scaled-integer x) + ;; FIXME: as a hacky alternative, could just parse result of number->string + (if (zero? x) + (cons 0 0) + ;; nonzero, inexact + ;; 16 digits ought to be enough (and not too much) + (let* ([E0 (order-of-magnitude x)] + ;; x = y * 10^E0 where y in [1,10) + [E1 (add1 E0)] + ;; x = y * 10^E1 where y in [0.1,1) + [E (- E1 16)] + ;; x ~= M * 10^E where M in [10^15,10^16) + [M (inexact->exact (truncate (* x (expt 10 (- E)))))] + ;; trim zeroes from M + [M*+E* (exact->scaled-integer M #t)] + [M* (car M*+E*)] + [E* (cdr M*+E*)]) + (cons M* (- E* E))))) (define (factor-out-v1 n factor) (define (loop n acc) @@ -92,11 +80,3 @@ (values q (+ n n)))) (values n 0))) (loop n factor)) - -;; ======================================== - -(provide marshal-error) - -;; marshal-error : string datum -> (raises error) -(define (marshal-error f i type datum) - (error/no-convert f #f type datum)) diff --git a/collects/db/private/mysql/dbsystem.rkt b/collects/db/private/mysql/dbsystem.rkt index 90c0f34a25..628ceb11e4 100644 --- a/collects/db/private/mysql/dbsystem.rkt +++ b/collects/db/private/mysql/dbsystem.rkt @@ -10,10 +10,10 @@ classify-my-sql) (define mysql-dbsystem% - (class* object% (dbsystem<%>) + (class* dbsystem-base% (dbsystem<%>) (define/public (get-short-name) 'mysql) - (define/public (get-known-types) supported-types) + (define/override (get-type-list) type-list) (define/public (has-support? option) (case option @@ -61,7 +61,7 @@ ;; ======================================== -(define (check-param fsym index param) +(define (check-param fsym param) (unless (or (string? param) (rational? param) (bytes? param) @@ -120,35 +120,33 @@ ;; ======================================== -(define-type-table (supported-types* - type-alias->type +(define-type-table (type-list* typeid->type - type->typeid describe-typeid) - (newdecimal decimal () #t) - (tiny tinyint () #t) - (short smallint () #t) - (int24 mediumint () #t) - (long integer (int) #t) - (longlong bigint () #t) - (float real () #t) - (double double () #t) - (newdate date () #t) - (time time () #t) - (datetime datetime () #t) - (varchar varchar () #t) - (var-string var-string () #t) - (tiny-blob tinyblob () #t) - (medium-blob mediumblob () #t) - (long-blob longblob () #t) - (blob blob () #t) - (bit bit () #t) - (geometry geometry () #t)) + (newdecimal decimal 0) + (tiny tinyint 0) + (short smallint 0) + (int24 mediumint 0) + (long integer 0) + (longlong bigint 0) + (float real 0) + (double double 0) + (newdate date 0) + (time time 0) + (datetime datetime 0) + (varchar varchar 0) + (var-string var-string 0) + (tiny-blob tinyblob 0) + (medium-blob mediumblob 0) + (long-blob longblob 0) + (blob blob 0) + (bit bit 0) + (geometry geometry 0)) -(define supported-types - (sort (append '(tinytext text mediumtext longtext var-binary) supported-types*) - stringstring)) +(define type-list + (append (map (lambda (t) (list t 0)) + '(tinytext text mediumtext longtext var-binary)) + type-list*)) ;; decimal, date typeids not used (?) diff --git a/collects/db/private/mysql/message.rkt b/collects/db/private/mysql/message.rkt index 99ec802501..a428348c68 100644 --- a/collects/db/private/mysql/message.rkt +++ b/collects/db/private/mysql/message.rkt @@ -7,7 +7,6 @@ Based on protocol documentation here: (require racket/match racket/port "../generic/sql-data.rkt" - "../generic/sql-convert.rkt" "../generic/interfaces.rkt" "../../util/private/geometry.rkt") (provide write-packet @@ -744,6 +743,25 @@ computed string on the server can be. See also: (else (error/internal 'get-result "unknown type" "type" type)))) +(define (parse-decimal s) + (cond [(equal? s "NaN") +nan.0] + [(regexp-match #rx"^-?([0-9]*)$" s) + ;; big integer + => (lambda (m) + (string->number s))] + [(regexp-match #rx"^-?([0-9]*)\\.([0-9]*)$" s) + => (lambda (m) + (+ (string->number (cadr m)) + (parse-exact-fraction (caddr m))))] + [else + (error/internal* 'parse-decimal "cannot parse as decimal" + '("string" value) s)])) + +(define (parse-exact-fraction s) + ;; eg: (parse-exact-fraction "12") = 12/100 + (/ (string->number s) + (expt 10 (string-length s)))) + (define (supported-result-typeid? typeid) (case typeid ((tiny short int24 long longlong float double) #t) diff --git a/collects/db/private/odbc/connection.rkt b/collects/db/private/odbc/connection.rkt index a607f18bf5..30414008f9 100644 --- a/collects/db/private/odbc/connection.rkt +++ b/collects/db/private/odbc/connection.rkt @@ -690,6 +690,22 @@ ((notice) (on-notice sqlstate message)))))) +;; ======================================== + +(define (marshal-decimal f n) + (cond [(not (real? n)) + (error/no-convert f #f "numeric" n)] + [(eqv? n +nan.0) + "NaN"] + [(or (eqv? n +inf.0) (eqv? n -inf.0)) + (error/no-convert f #f "numeric" n)] + [(or (integer? n) (inexact? n)) + (number->string n)] + [(exact? n) + ;; Bleah. + (or (exact->decimal-string n) + (number->string (exact->inexact n)))])) + #| Historical note: I tried using ODBC async execution to avoid blocking all Racket threads for a long time. diff --git a/collects/db/private/odbc/dbsystem.rkt b/collects/db/private/odbc/dbsystem.rkt index 35ec44970b..902658c012 100644 --- a/collects/db/private/odbc/dbsystem.rkt +++ b/collects/db/private/odbc/dbsystem.rkt @@ -11,9 +11,9 @@ classify-odbc-sql) (define odbc-dbsystem% - (class* object% (dbsystem<%>) + (class* dbsystem-base% (dbsystem<%>) (define/public (get-short-name) 'odbc) - (define/public (get-known-types) supported-types) + (define/override (get-type-list) type-list) (define/public (has-support? x) #f) (define/public (get-parameter-handlers param-typeids) @@ -81,7 +81,7 @@ (define-syntax-rule (defchecks get-check [(typeid name pred ...) ...] [(*typeid *name *fun) ...]) (define get-check - (let ([name (mk-check typeid (lambda (z) (or (pred z) ...)))] ... + (let ([name (mk-check typeid (lambda (z) (or (pred z) ...)) #:contract-parts '(pred ...))] ... [*name *fun] ...) (lambda (x) (case x @@ -91,13 +91,16 @@ (lambda (fsym index param) (error/unsupported-type fsym x)))))))) -(define (mk-check typeid pred) - (lambda (fsym index param) +(define (mk-check typeid pred #:contract-parts [ctc-parts #f]) + (lambda (fsym param) (unless (pred param) - (error/no-convert fsym "ODBC" (typeid->type typeid) param)) + (error/no-convert fsym "ODBC" (typeid->type typeid) param + #:contract (cond [(= (length ctc-parts) 1) + (car ctc-parts)] + [else (cons 'or/c ctc-parts)]))) param)) -(define (check-numeric fsym index param) +(define (check-numeric fsym param) (define (bad note) (error/no-convert fsym "ODBC" "numeric" param note)) (unless (rational? param) (bad "")) @@ -138,52 +141,50 @@ ;; ---- -(define-type-table (supported-types - type-alias->type +(define-type-table (type-list typeid->type - type->typeid describe-typeid) - (0 unknown () #t) - (1 character (char) #t) - (2 numeric () #t) - (3 decimal () #t) - (4 integer (int) #t) - (5 smallint () #t) - (6 float () #t) - (7 real () #t) - (8 double () #t) - (9 datetime () #t) - (12 varchar () #t) - (91 date () #t) - (92 time () #t) - (93 timestamp () #t) - (-1 longvarchar () #t) - (-2 binary () #t) - (-3 varbinary () #t) - (-4 longvarbinary () #t) - (-5 bigint () #t) - (-6 tinyint () #t) - (-7 bit1 () #t) ;; not bit(n), always single bit - (-8 wchar () #t) - (-9 wvarchar () #t) - (-10 wlongvarchar () #t) + (0 unknown 0) + (1 character 0) + (2 numeric 0) + (3 decimal 0) + (4 integer 0) + (5 smallint 0) + (6 float 0) + (7 real 0) + (8 double 0) + (9 datetime 0) + (12 varchar 0) + (91 date 0) + (92 time 0) + (93 timestamp 0) + (-1 longvarchar 0) + (-2 binary 0) + (-3 varbinary 0) + (-4 longvarbinary 0) + (-5 bigint 0) + (-6 tinyint 0) + (-7 bit1 0) ;; not bit(n), always single bit + (-8 wchar 0) + (-9 wvarchar 0) + (-10 wlongvarchar 0) ;; Unsupported types - (101 interval-year () #f) - (102 interval-month () #f) - (103 interval-day () #f) - (104 interval-hour () #f) - (105 interval-minute () #f) - (106 interval-second () #f) - (107 interval-year-month () #f) - (108 interval-day-hour () #f) - (109 interval-day-minute () #f) - (110 interval-day-second () #f) - (111 interval-hour-minute () #f) - (112 interval-hour-second () #f) - (113 interval-minute-second () #f)) + (101 interval-year #f) + (102 interval-month #f) + (103 interval-day #f) + (104 interval-hour #f) + (105 interval-minute #f) + (106 interval-second #f) + (107 interval-year-month #f) + (108 interval-day-hour #f) + (109 interval-day-minute #f) + (110 interval-day-second #f) + (111 interval-hour-minute #f) + (112 interval-hour-second #f) + (113 interval-minute-second #f)) (define (supported-typeid? x) (case x diff --git a/collects/db/private/postgresql/connection.rkt b/collects/db/private/postgresql/connection.rkt index cc8bc33288..e4cb16290a 100644 --- a/collects/db/private/postgresql/connection.rkt +++ b/collects/db/private/postgresql/connection.rkt @@ -1,7 +1,6 @@ #lang racket/base (require racket/class racket/match - racket/vector file/md5 openssl unstable/error @@ -31,6 +30,7 @@ (define inport #f) (define outport #f) (define process-id #f) + (define integer-datetimes? 'unknown) ;; see connect:after-auth (inherit call-with-lock call-with-lock* @@ -91,7 +91,7 @@ (lambda (e) ;; Anything but exn:fail:sql (raised by recv-message) indicates ;; a communication error. - ;; FIXME: alternatively, have check-ready-for-query set an ok flag + ;; Alternative: could have check-ready-for-query set a done-reading flag. (unless (exn:fail:sql? e) (disconnect* #f)) (raise e))]) @@ -148,6 +148,8 @@ (disconnect* #f) (raise-misc-error fsym "client character encoding changed, disconnecting" '("new encoding" value) value))] + [(equal? name "integer_datetimes") + (set! integer-datetimes? (equal? value "on"))] [else (void)])])) ;; == Connection management @@ -174,7 +176,9 @@ ;; == System (define/public (get-dbsystem) - dbsystem) + (if integer-datetimes? + dbsystem/integer-datetimes + dbsystem/floating-point-datetimes)) ;; ======================================== @@ -229,13 +233,37 @@ (let ([r (recv-message 'postgresql-connect)]) (match r [(struct ReadyForQuery (status)) - (void)] + (connect:after-auth)] [(struct BackendKeyData (pid secret)) (set! process-id pid) (connect:expect-ready-for-query)] [_ (error/comm 'postgresql-connect "after authentication")]))) + ;; connect:after-auth : -> void + (define/private (connect:after-auth) + (when (eq? integer-datetimes? 'unknown) + ;; According to http://www.postgresql.org/docs/8.4/static/libpq-status.html + ;; (see PQparameterStatus), versions of PostgreSQL before 8.0 do not send + ;; (or AFAICT even *have*) the "integer_datetimes" parameter on startup. + ;; Version 7.4.8 from Ubuntu 5.10 uses integer datetimes, no config var. + ;; Version 7.4.6 from Fedora Core 3 uses floating-point, no config var. + ;; So determine by trying query w/ integer; if wrong result, try float. + (dprintf " ** testing datetime representation\n") + (let ([r (internal-query1 'postgresql-connect "select time '12:34:56'")]) + (define (test-config) + (match (query1:process-result 'postgresql-connect r) + [(rows-result _ (list (vector (sql-time 12 34 56 0 #f)))) #t] + [_ #f])) + (set! integer-datetimes? #t) + (unless (test-config) + (set! integer-datetimes? #f) + (unless (test-config) + (error/internal 'postgresql-connect + "unable to determine server datetime representation"))) + (dprintf " ** datetime representation = ~a\n" + (if integer-datetimes? "integer" "floating-point"))))) + ;; ============================================================ ;; == Query @@ -374,9 +402,10 @@ (match result [(vector 'rows field-dvecs rows) (let ([type-readers (query1:get-type-readers fsym field-dvecs)]) - (rows-result (map field-dvec->field-info field-dvecs) - (map (lambda (data) (bytes->row data type-readers)) - rows)))] + (parameterize ((use-integer-datetimes? integer-datetimes?)) + (rows-result (map field-dvec->field-info field-dvecs) + (map (lambda (data) (bytes->row data type-readers)) + rows))))] [(vector 'cursor field-dvecs stmt portal) (let ([pst (statement-binding-pst stmt)] [type-readers (query1:get-type-readers fsym field-dvecs)]) @@ -414,7 +443,8 @@ (when (unbox end-box) (cursor:close fsym pst portal)) rows)])))]) - (and rows (map (lambda (data) (bytes->row data type-readers)) rows)))))) + (parameterize ((use-integer-datetimes? integer-datetimes?)) + (and rows (map (lambda (data) (bytes->row data type-readers)) rows))))))) (define/private (cursor:close fsym pst portal) (let ([close-on-exec? (send pst get-close-on-exec?)]) @@ -605,12 +635,6 @@ ;; ======================================== -;; nosupport : string -> string -(define (nosupport str) - (string-append "not supported: " str)) - -;; ======================================== - ;; md5-password : string (U string (list 'hash string)) bytes -> string ;; Compute the MD5 hash of a password in the form expected by the PostgreSQL ;; backend. diff --git a/collects/db/private/postgresql/dbsystem.rkt b/collects/db/private/postgresql/dbsystem.rkt index 1525758030..8883fc5d36 100644 --- a/collects/db/private/postgresql/dbsystem.rkt +++ b/collects/db/private/postgresql/dbsystem.rkt @@ -1,9 +1,9 @@ #lang racket/base (require racket/class racket/list - racket/string racket/match (prefix-in srfi: srfi/19) + json "../generic/interfaces.rkt" "../generic/common.rkt" "../generic/sql-data.rkt" @@ -12,16 +12,19 @@ "../../util/geometry.rkt" "../../util/postgresql.rkt" (only-in "message.rkt" field-dvec->typeid)) -(provide dbsystem +(provide dbsystem/integer-datetimes + dbsystem/floating-point-datetimes typeid->type-reader typeid->format + use-integer-datetimes? classify-pg-sql) (define postgresql-dbsystem% - (class* object% (dbsystem<%>) + (class* dbsystem-base% (dbsystem<%>) + (init-field integer-datetimes?) (define/public (get-short-name) 'postgresql) - (define/public (get-known-types) supported-types) + (define/override (get-type-list) type-list) (define/public (has-support? option) (case option @@ -30,9 +33,14 @@ (else #f))) (define/public (get-parameter-handlers param-typeids) - (map (lambda (param-typeid) - (typeid->type-writer param-typeid)) - param-typeids)) + (let ([writers (map typeid->type-writer param-typeids)]) + (if integer-datetimes? + writers + (map (lambda (w) + (lambda (f x) + (parameterize ((use-integer-datetimes? #f)) + (w f x)))) + writers)))) (define/public (field-dvecs->typeids dvecs) (map field-dvec->typeid dvecs)) @@ -46,8 +54,10 @@ (super-new))) -(define dbsystem - (new postgresql-dbsystem%)) +(define dbsystem/integer-datetimes + (new postgresql-dbsystem% (integer-datetimes? #t))) +(define dbsystem/floating-point-datetimes + (new postgresql-dbsystem% (integer-datetimes? #f))) ;; ======================================== @@ -92,122 +102,175 @@ ("START TRANSACTION" start) ))) -;; ======================================== +;; ============================================================ + +(define-syntax-rule (type-table (type-list typeid->type describe-typeid) + (typeid->format typeid->type-reader typeid->type-writer) + (typeid type since-version fmt reader writer) ...) + (begin (define-type-table (type-list typeid->type describe-typeid) + (typeid type since-version) ...) + (define (typeid->type-reader fsym tid) + (let ([result + (case tid + ((typeid) reader) ... + (else #f))]) + (or result (error/unsupported-type fsym tid (typeid->type tid))))) + (define (typeid->type-writer tid) + (let ([result + (case tid + ((typeid) writer) ... + (else #f))]) + (or result (make-unsupported-writer tid (typeid->type tid))))) + (define (typeid->format tid) + (case tid + ((typeid) fmt) ... + (else 0))))) + +(define (make-unsupported-writer x t) + (lambda (fsym . args) + (error/unsupported-type fsym x t))) + +;; ============================================================ ;; Derived from -;; http://www.us.postgresql.org/users-lounge/docs/7.2/postgres/datatype.html +;; http://www.postgresql.org/docs/current/static/datatype.html ;; and ;; result of "SELECT oid, typname, typelem FROM pg_type;" -(define-type-table (supported-types - type-alias->type - typeid->type - type->typeid - describe-typeid) - (16 boolean (bool) #t) - (17 bytea () #t) - (18 char1 () #t) - (19 name () #t) - (20 bigint (int8) #t) - (21 smallint (int2) #t) - (23 integer (int4) #t) - (25 text () #t) - (26 oid () #t) - (700 real (float4) #t) - (701 double (float8) #t) - (1042 character (bpchar) #t) - (1043 varchar () #t) - (1082 date () #t) - (1083 time () #t) - (1114 timestamp () #t) - (1184 timestamptz() #t) - (1186 interval () #t) - (1266 timetz () #t) - (1700 decimal (numeric) #t) +(type-table (type-list typeid->type describe-typeid) + (typeid->format typeid->type-reader typeid->type-writer) + (16 boolean 0 1 recv-boolean send-boolean) + (17 bytea 0 1 recv-bytea send-bytea) + (18 char1 0 1 recv-char1 send-char1) + (19 name 0 1 recv-string send-string) + (20 bigint 0 1 recv-integer send-int8) + (21 smallint 0 1 recv-integer send-int2) + (23 integer 0 1 recv-integer send-int4) + (25 text 0 1 recv-string send-string) + (26 oid 0 1 recv-integer send-int4) + (700 real 0 1 recv-float send-float4) + (701 double 0 1 recv-float send-float8) + (1042 character 0 1 recv-string send-string) + (1043 varchar 0 1 recv-string send-string) + (1082 date 0 1 recv-date send-date) + (1083 time 0 1 recv-time send-time) + (1114 timestamp 0 1 recv-timestamp send-timestamp) + (1184 timestamptz 0 1 recv-timestamptz send-timestamptz) + (1186 interval 0 1 recv-interval send-interval) + (1266 timetz 0 1 recv-timetz send-timetz) + (1700 decimal 0 1 recv-numeric send-numeric) + (1560 bit 0 1 recv-bits send-bits) + (1562 varbit 0 1 recv-bits send-bits) + (114 json 9.2 1 recv-json send-json) - (1560 bit () #t) - (1562 varbit () #t) + (600 point 0 1 recv-point send-point) + (601 lseg 0 1 recv-lseg send-lseg) + (602 path 0 1 recv-path send-path) + (603 box 0 1 recv-box send-box) + (604 polygon 0 1 recv-polygon send-polygon) + (718 circle 0 1 recv-circle send-circle) - (600 point () #t) - (601 lseg () #t) - (602 path () #t) - (603 box () #t) - (604 polygon () #t) - (718 circle () #t) + (3904 int4range 9.2 1 (recv-range 23) (send-range 23)) + (3926 int8range 9.2 1 (recv-range 20) (send-range 20)) + (3906 numrange 9.2 1 (recv-range 1700) (send-range 1700)) + (3908 tsrange 9.2 1 (recv-range 1114) (send-range 1114)) + (3910 tstzrange 9.2 1 (recv-range 1184) (send-range 1184)) + (3912 daterange 9.2 1 (recv-range 1082) (send-range 1082)) ;; "string" literals have type unknown; just treat as string - (705 unknown () #t) + (705 unknown 0 1 recv-string send-string) - (1000 boolean-array () #t) - (1001 bytea-array () #t) - (1002 char1-array () #t) - (1003 name-array () #t) - (1005 smallint-array (int2-array) #t) - (1007 integer-array (int4-array) #t) - (1009 text-array () #t) - (1028 oid-array () #t) - (1014 character-array (bpchar-array) #t) - (1015 varchar-array () #t) - (1016 bigint-array (int8-array) #t) - (1017 point-array () #t) - (1018 lseg-array () #t) - (1019 path-array () #t) - (1020 box-array () #t) - (1021 real-array (float4-array) #t) - (1022 double-array (float8-array) #t) - (1027 polygon-array () #t) - (1561 bit-array () #t) - (1563 varbit-array () #t) - (719 circle-array () #t) + ;; Array types - (1115 timestamp-array () #t) - (1182 date-array () #t) - (1183 time-array () #t) - (1185 timestamptz-array () #t) - (1187 interval-array () #t) - (1231 decimal-array (numeric-array) #t) - (1270 timetz-array () #t) + (1000 boolean-array 0 1 recv-array (send-array 16)) + (1001 bytea-array 0 1 recv-array (send-array 17)) + (1002 char1-array 0 1 recv-array (send-array 18)) + (1003 name-array 0 1 recv-array (send-array 19)) + (1005 smallint-array 0 1 recv-array (send-array 21)) + (1007 integer-array 0 1 recv-array (send-array 23)) + (1009 text-array 0 1 recv-array (send-array 25)) + (1028 oid-array 0 1 recv-array (send-array 26)) + (1014 character-array 0 1 recv-array (send-array 1042)) + (1015 varchar-array 0 1 recv-array (send-array 1043)) + (1016 bigint-array 0 1 recv-array (send-array 20)) + (1017 point-array 0 1 recv-array (send-array 600)) + (1018 lseg-array 0 1 recv-array (send-array 601)) + (1019 path-array 0 1 recv-array (send-array 602)) + (1020 box-array 0 1 recv-array (send-array 603)) + (1021 real-array 0 1 recv-array (send-array 700)) + (1022 double-array 0 1 recv-array (send-array 701)) + (1027 polygon-array 0 1 recv-array (send-array 604)) + (719 circle-array 0 1 recv-array (send-array 718)) + (1561 bit-array 0 1 recv-array (send-array 1560)) + (1563 varbit-array 0 1 recv-array (send-array 1562)) + (199 json-array 9.2 1 recv-array (send-array 114)) + + (1115 timestamp-array 0 1 recv-array (send-array 1114)) + (1182 date-array 0 1 recv-array (send-array 1082)) + (1183 time-array 0 1 recv-array (send-array 1083)) + (1185 timestamptz-array 0 1 recv-array (send-array 1184)) + (1187 interval-array 0 1 recv-array (send-array 1186)) + (1231 decimal-array 0 1 recv-array (send-array 1700)) + (1270 timetz-array 0 1 recv-array (send-array 1266)) + + (3905 int4range-array 9.2 1 recv-array (send-array 3904)) + (3927 int8range-array 9.2 1 recv-array (send-array 3926)) + (3907 numrange-array 9.2 1 recv-array (send-array 3906)) + (3909 tsrange-array 9.2 1 recv-array (send-array 3908)) + (3911 tstzrange-array 9.2 1 recv-array (send-array 3910)) + (3913 daterange-array 9.2 1 recv-array (send-array 3912)) + + (2275 cstring 0 1 recv-string send-string) + ;; Receive but do not send + (2249 record #f 1 recv-record #f) + (2287 record-array #f 1 recv-array #f) ;; The following types are not supported. ;; (But putting their names here yields better not-supported errors.) - (142 xml () #f) - (143 xml-array () #f) - (628 line () #f) - (629 line-array () #f) - (650 cidr () #f) - (651 cidr-array () #f) - (702 abstime () #f) - (703 reltime () #f) - (704 tinterval () #f) - (790 money () #f) - (829 macaddr () #f) - (869 inet () #f) - (791 money-array () #f) - (1023 abstime-array () #f) - (1024 reltime-array () #f) - (1025 tinterval-array () #f) - (1040 macaddr-array () #f) - (1041 inet-array () #f) - (2249 record () #f) - (2287 record-array () #f) - (2950 uuid () #f) - (2951 uuid-array () #f)) + (142 xml #f 0 #f #f) + (143 xml-array #f 0 #f #f) -;; ============================================================ + (628 line #f 0 #f #f) + (629 line-array #f 0 #f #f) + (650 cidr #f 0 #f #f) + (651 cidr-array #f 0 #f #f) + (702 abstime #f 0 #f #f) + (703 reltime #f 0 #f #f) + (704 tinterval #f 0 #f #f) + (790 money #f 0 #f #f) + (829 macaddr #f 0 #f #f) + (869 inet #f 0 #f #f) + (791 money-array #f 0 #f #f) + (1023 abstime-array #f 0 #f #f) + (1024 reltime-array #f 0 #f #f) + (1025 tinterval-array #f 0 #f #f) + (1040 macaddr-array #f 0 #f #f) + (1041 inet-array #f 0 #f #f) + (2950 uuid #f 0 #f #f) + (2951 uuid-array #f 0 #f #f)) + +;; ---------------------------------------- #| -BINARY VS TEXT FORMAT +BINARY DATA FORMAT -For most types, we send and receive data in binary format -only. However, datetime types are tricky enough that binary format -isn't worth it (yet). Also decimal/numeric. +We send and receive data in binary format only. + +Some datetime types (see below) have two binary formats: integer +microseconds vs floating-point seconds since a particular point in +time. The integer format is indicated by the server +variable "integer_datetimes=on", the default since about 2008. If the +variable is off or not present, use floats. The relevant send/recv +functions depend on use-integer-datetimes? parameter. Domain typeids never seem to appear as result typeids, but do appear as parameter typeids. ---- +Notes on binary formats, mostly from $PG/src/include/utils/*.[ch] + bit, varbit = len:int4 byte* (0-padded on *left*) date = int4 (days since 2000-01-01) @@ -217,165 +280,22 @@ time = (int8 or float8) timetz = (int8 or float8) zone-secs:int4 interval = (usecs:int8 or secs:float8) days:int4 months:int4 - (time*, timestamp* depend on "SHOW integer_datetimes") + (time*, timestamp*, interval depend on "integer_datetimes" parameter, but date does not) inet, cidr = family:byte bits:byte is_cidr:byte addrlen:byte addr:be-integer is_cidr is ignored record = cols:int4 (typeoid:int4 len/-1:int4 data:byte^len)^cols +range = flags:byte (len:int4 data:byte^len)^{0..2} + |# -;; Text readers +(define POSTGRESQL-JD-ADJUST 2451545) ;; from $PG/src/include/utils/datetime.h -(define (parse-date d) - (srfi-date->sql-date - (srfi:string->date d "~Y-~m-~d"))) +(define use-integer-datetimes? (make-parameter #t)) -(define time/ns-rx #rx"^[0-9]*:[0-9]*:[0-9]*\\.([0-9]*)") -(define timestamp/ns-rx #rx"^.* [0-9]*:[0-9]*:[0-9]*\\.([0-9]*)") - -(define (ns-of t rx) - (let ([m (regexp-match rx t)]) - (if m - (* #e1e9 (parse-exact-fraction (cadr m))) - 0))) - -(define (parse-time t) - (srfi-date->sql-time - (srfi:string->date t "~k:~M:~S") - (ns-of t time/ns-rx))) - -(define (parse-time-tz t) - (srfi-date->sql-time-tz - (srfi:string->date t "~k:~M:~S~z") - (ns-of t time/ns-rx))) - -(define (parse-timestamp t) - (srfi-date->sql-timestamp - (srfi:string->date t "~Y-~m-~d ~k:~M:~S") - (ns-of t timestamp/ns-rx))) - -(define (parse-timestamp-tz t) - (srfi-date->sql-timestamp-tz - (srfi:string->date t "~Y-~m-~d ~k:~M:~S~z") - (ns-of t timestamp/ns-rx))) - -(define interval-rx - (regexp - (string-append "^" - "[\"]?" ;; when in array - "(?:(-?[0-9]*) years? *)?" - "(?:(-?[0-9]*) mons? *)?" - "(?:(-?[0-9]*) days? *)?" - "(?:(-?)([0-9]*):([0-9]*):([0-9]*)(?:\\.([0-9]*))?)?" - "[\"]?" ;; when in array - "$"))) - -(define (parse-interval s) - (define (to-num m) - (if m (string->number m) 0)) - (define match-result (regexp-match interval-rx s)) - (match match-result - [(list _whole years months days tsign hours mins secs fsec) - (let* ([years (to-num years)] - [months (to-num months)] - [days (to-num days)] - [sg (if (equal? tsign "-") - +)] - [hours (sg (to-num hours))] - [mins (sg (to-num mins))] - [secs (sg (to-num secs))] - [nsecs (if fsec - (let ([flen (string-length fsec)]) - (* (string->number (substring fsec 0 (min flen 9))) - (expt 10 (- 9 (min flen 9))))) - 0)]) - (sql-interval years months days hours mins secs nsecs))])) - -(define ((c-parse-array parse-elt) buf start end) - ;; NOTE: we assume that array enclosed with "{" and "}", and separator is "," - (let* ([s (bytes->string/utf-8 buf #f start end)] - [vals - (let loop ([s s]) - (cond [(equal? s "{}") '#()] - [(regexp-match? #rx"^{.*}$" s) - (let ([parts (regexp-split #rx"," s 1 (sub1 (string-length s)))]) - (list->vector (map loop parts)))] - [(equal? s "NULL") sql-null] - [else (parse-elt s)]))] - [lengths - ;; NOTE: we assume array is well-formed (dimension lengths consistent) - (cond [(zero? (vector-length vals)) null] - [else - (let loop ([x vals]) - (cond [(vector? x) (cons (vector-length x) (loop (vector-ref x 0)))] - [else null]))])]) - (pg-array (length lengths) lengths (map (lambda (_) 1) lengths) vals))) - -;; Text writers - -(define (marshal-date f i d) - (unless (sql-date? d) - (marshal-error f i "date" d)) - (srfi:date->string (sql-datetime->srfi-date d) "~Y-~m-~d")) - -(define (marshal-time f i t) - (unless (sql-time? t) - (marshal-error f i "time" t)) - (srfi:date->string (sql-datetime->srfi-date t) "~k:~M:~S.~N")) - -(define (marshal-time-tz f i t) - (unless (sql-time? t) - (marshal-error f i "time" t)) - (srfi:date->string (sql-datetime->srfi-date t) "~k:~M:~S.~N~z")) - -(define (marshal-timestamp f i t) - (unless (sql-timestamp? t) - (marshal-error f i "timestamp" t)) - (srfi:date->string (sql-datetime->srfi-date t) "~Y-~m-~d ~k:~M:~S.~N")) - -(define (marshal-timestamp-tz f i t) - (unless (sql-timestamp? t) - (marshal-error f i "timestamp" t)) - (srfi:date->string (sql-datetime->srfi-date t) "~Y-~m-~d ~k:~M:~S.~N~z")) - -(define (marshal-interval f i t) - (define (tag num unit) - (if (zero? num) "" (format "~a ~a " num unit))) - (match t - [(sql-interval years months days hours minutes seconds nanoseconds) - ;; Note: we take advantage of PostgreSQL's liberal interval parser - ;; and we acknowledge its micro-second precision. - (string-append (tag years "years") - (tag months "months") - (tag days "days") - (tag hours "hours") - (tag minutes "minutes") - (tag seconds "seconds") - (tag (quotient nanoseconds 1000) "microseconds"))] - [else - (marshal-error f i "interval" t)])) - -(define ((marshal-array marshal-elt) f i x0) - (define x - (cond [(pg-array? x0) x0] - [(list? x0) (list->pg-array x0)] - [else (marshal-error f i "pg-array" x0)])) - (match x - [(pg-array dims lengths lbounds vals) - (cond [(zero? dims) "{}"] - [else - (let loop ([dims dims] [v vals]) - (cond [(zero? dims) - (if (sql-null? v) - "NULL" - (marshal-elt f #f v))] - [else - (string-append "{" - (string-join (for/list ([v* (in-vector v)]) - (loop (sub1 dims) v*)) - ",") - "}")]))])])) +;; ---------------------------------------- ;; Binary readers ;; Take bytes, start offset, end offset (but most ignore end) @@ -431,29 +351,68 @@ record = cols:int4 (typeoid:int4 len/-1:int4 data:byte^len)^cols (polygon (line-string points) null))) -#| -(require srfi/19) -(define (recv-date x) - (let* ([POSTGRESQL-JD-ADJUST 2451545] ;; from $PG/src/include/utils/datetime.h - [jd (+ (integer-bytes->integer x #t #t 0 4) POSTGRESQL-JD-ADJUST)] - [t (julian-day->date jd 0)]) ;; gives noon on the designated day +(define (recv-date buf start end) + (let* ([jd (+ (integer-bytes->integer buf #t #t start (+ start 4)) POSTGRESQL-JD-ADJUST)] + [t (srfi:julian-day->date jd 0)]) ;; gives noon on the designated day (srfi-date->sql-date t))) -(define-values (recv-time recv-timetz) - (let () - (define (usec->time t tz) - (let*-values ([(t usec) (quotient/remainder t #e1e6)] - [(t sec) (quotient/remainder t 60)] - [(hr min) (quotient/remainder t 60)]) - (make-sql-time hr min sec (* 1000 usec) tz))) - (define (recv-time x) - (usec->time (integer-bytes->integer x #t #t 0 8) #f)) - (define (recv-timetz x) - (let* ([t (integer-bytes->integer x #t #t 0 8)] - [tz (integer-bytes->integer x #t #t 8 12)]) - ;; FIXME: seem to need to invert timezone... why? - (usec->time t (- tz)))) - (values recv-time recv-timetz))) -|# + +(define (get-usec buf start) + (cond [(use-integer-datetimes?) + (let ([usec (integer-bytes->integer buf #t #t start (+ start 8))]) + (cond [(= usec (sub1 (expt 2 63))) +inf.0] + [(= usec (- (expt 2 63))) -inf.0] + [else usec]))] + [else + (let ([sec (floating-point-bytes->real buf #t start (+ start 8))]) + (if (rational? sec) + (inexact->exact (round (* sec #i1e6))) + sec))])) + +(define (usec->hmsn usec) + (let*-values ([(sec usec) (quotient/remainder usec #e1e6)] + [(min sec) (quotient/remainder sec 60)] + [(hr min) (quotient/remainder min 60)]) + (values hr min sec (* #e1e3 usec)))) + +(define (recv-time buf start end) + (let-values ([(hr min sec nsec) (usec->hmsn (get-usec buf start))]) + (make-sql-time hr min sec nsec #f))) + +(define (recv-timetz buf start end) + (let-values ([(hr min sec nsec) (usec->hmsn (get-usec buf start))] + [(tz) (integer-bytes->integer buf #t #t (+ start 8) (+ start 12))]) + ;; FIXME: seem to need to invert timezone... why? + (make-sql-time hr min sec nsec (- tz)))) + +(define (recv-timestamp* buf start end tz) + (define usec-in-day (* #e1e6 60 60 24)) + (let ([usec (get-usec buf start)]) + (cond [(rational? usec) + (let*-values ([(day usec) (quotient/remainder usec usec-in-day)] + [(day usec) (if (negative? usec) + (values (sub1 day) (+ usec-in-day usec)) + (values day usec))] + [(jd) (+ day POSTGRESQL-JD-ADJUST)] + [(hr min sec nsec) (usec->hmsn usec)] + [(sd) (srfi:julian-day->date jd 0)]) + (make-sql-timestamp (srfi:date-year sd) + (srfi:date-month sd) + (srfi:date-day sd) + hr min sec nsec tz))] + ;; Else +/-inf.0 + [else usec]))) + +(define (recv-timestamp buf start end) + (recv-timestamp* buf start end #f)) +(define (recv-timestamptz buf start end) + (recv-timestamp* buf start end 0)) + +(define (recv-interval buf start end) + (let*-values ([(hr min sec nsec) (usec->hmsn (get-usec buf start))] + [(day) (integer-bytes->integer buf #t #t (+ start 8) (+ start 12))] + [(mon) (integer-bytes->integer buf #t #t (+ start 12) (+ start 16))] + [(yr mon) (quotient/remainder mon 12)]) + (make-sql-interval yr mon day hr min sec nsec))) (define (recv-record buf start end) (define (get-int signed?) @@ -503,17 +462,17 @@ record = cols:int4 (typeoid:int4 len/-1:int4 data:byte^len)^cols (set! start (+ start len)))]))]))])]) (pg-array ndim (map car bounds) (map cdr bounds) vals))) -#| -(define (recv-numeric x) - (define (get-int2 start) (integer-bytes->integer x #t #t start (+ 2 start))) +(define (recv-numeric buf start end) + (define (get-int2 offset [signed? #t]) + (integer-bytes->integer buf signed? #t (+ start offset) (+ start offset 2))) (let* ([NBASE #e1e4] [NUMERIC_POS #x0000] [NUMERIC_NEG #x4000] [NUMERIC_NAN #xC000] [digits (get-int2 0)] [weight (get-int2 2)] - [sign (get-int2 4)] - [dscale (get-int2 6)] + [sign (get-int2 4 #f)] + [dscale (get-int2 6)] ;; "display scale", can ignore [unscaled-digits (for/list ([offset (in-range 8 (+ 8 (* 2 digits)) 2)]) (get-int2 offset))] @@ -527,289 +486,316 @@ record = cols:int4 (typeoid:int4 len/-1:int4 data:byte^len)^cols [(= sign NUMERIC_NEG) (- abs-number)] [(= sign NUMERIC_NAN) - +nan.0]))) -|# + +nan.0] + [else (error/internal 'recv-numeric "bad sign: ~e" sign)]))) -(define-values (c-parse-date - c-parse-time - c-parse-time-tz - c-parse-timestamp - c-parse-timestamp-tz - c-parse-interval - c-parse-decimal) - (let ([c (lambda (f) (lambda (buf start end) (f (bytes->string/utf-8 buf #f start end))))]) - (values (c parse-date) - (c parse-time) - (c parse-time-tz) - (c parse-timestamp) - (c parse-timestamp-tz) - (c parse-interval) - (c parse-decimal)))) +(define (recv-json buf start end) + (bytes->jsexpr (subbytes buf start end))) + +(define (recv-range elttype) + (define EMPTY #x01) + (define LB_INC #x02) + (define UB_INC #x04) + (define LB_INF #x08) + (define UB_INF #x10) + (define reader (typeid->type-reader 'recv-range elttype)) + (lambda (buf start end) + (let* ([flags (bytes-ref buf start)] + [is-empty? (not (zero? (bitwise-and flags EMPTY)))] + [has-lb? (and (not is-empty?) (zero? (bitwise-and flags LB_INF)))] + [has-ub? (and (not is-empty?) (zero? (bitwise-and flags UB_INF)))] + [includes-lb? (not (zero? (bitwise-and flags LB_INC)))] + [includes-ub? (not (zero? (bitwise-and flags UB_INC)))]) + ;; get-bound : boolean nat -> (values datum nat) + (define (get-bound has? start) + (cond [has? + (let* ([len (integer-bytes->integer buf #t #t start (+ start 4))] + [data-start (+ start 4)] + [data-end (+ data-start len)] + [data (reader buf data-start data-end)]) + (values data data-end))] + [else + (values #f start)])) + (let*-values ([(next-start) (+ start 1)] + [(lb next-start) (get-bound has-lb? next-start)] + [(ub next-start) (get-bound has-ub? next-start)]) + ;; expect next-start = end + (if is-empty? + (pg-empty-range) + (pg-range lb includes-lb? ub includes-ub?)))))) ;; Binary writers -(define (send-boolean f i x) +(define (send-boolean f x) (case x ((#t) (bytes 1)) ((#f) (bytes 0)) - (else (send-error f i "boolean" x)))) + (else (send-error f "boolean" x #:contract 'boolean?)))) -(define (send-bits f i x) - (unless (sql-bits? x) (send-error f i "bits" x)) +(define (send-bits f x) + (unless (sql-bits? x) (send-error f "bits" x #:contract 'sql-bits?)) (let-values ([(len bv start) (align-sql-bits x 'left)]) (bytes-append (integer->integer-bytes len 4 #t #t) (if (zero? start) bv (subbytes bv start))))) -(define (send-char1 f i x) +(define (send-char1 f x) (let ([n (if (char? x) (char->integer x) x)]) - (unless (uint8? n) (send-error f i "char1" x)) + (unless (uint8? n) (send-error f "char1" x)) (bytes n))) -(define (send-bytea f i x) - (unless (bytes? x) (send-error f i "bytea" x)) +(define (send-bytea f x) + (unless (bytes? x) (send-error f "bytea" x #:contract 'bytes?)) x) -(define (send-string f i x) - (unless (string? x) (send-error f i "string" x)) +(define (send-string f x) + (unless (string? x) (send-error f "string" x #:contract 'string?)) (string->bytes/utf-8 x)) -(define (send-int2 f i n) - (unless (int16? n) (send-error f i "int2" n)) +(define (send-int2 f n) + (unless (int16? n) (send-error f "int2" n #:contract 'int16?)) (integer->integer-bytes n 2 #t #t)) -(define (send-int4 f i n) - (unless (int32? n) (send-error f i "int4" n)) +(define (send-int4 f n) + (unless (int32? n) (send-error f "int4" n #:contract 'int32?)) (integer->integer-bytes n 4 #t #t)) -(define (send-int8 f i n) - (unless (int64? n) (send-error f i "int8" n)) +(define (send-int8 f n) + (unless (int64? n) (send-error f "int8" n #:contract 'int64?)) (integer->integer-bytes n 8 #t #t)) -(define (send-float* f i n type size) - (unless (real? n) (send-error f i type n)) +(define (send-float* f n type size) + (unless (real? n) (send-error f type n #:contract 'real?)) (real->floating-point-bytes n size #t)) -(define (send-float4 f i n) - (send-float* f i n "float4" 4)) +(define (send-float4 f n) + (send-float* f n "float4" 4)) -(define (send-float8 f i n) - (send-float* f i n "float8" 8)) +(define (send-float8 f n) + (send-float* f n "float8" 8)) (define (float8 x) (real->floating-point-bytes x 8 #t)) -(define (send-point f i x) - (unless (point? x) (send-error f i "point" x)) +(define (send-point f x) + (unless (point? x) (send-error f "point" x #:contract 'point?)) (bytes-append (float8 (point-x x)) (float8 (point-y x)))) -(define (send-box f i x) - (unless (pg-box? x) (send-error f i "box" x)) - (bytes-append (send-point f #f (pg-box-ne x)) - (send-point f #f (pg-box-sw x)))) -(define (send-circle f i x) - (unless (pg-circle? x) (send-error f i "circle" x)) - (bytes-append (send-point f #f (pg-circle-center x)) +(define (send-box f x) + (unless (pg-box? x) (send-error f "box" x #:contract 'pg-box?)) + (bytes-append (send-point f (pg-box-ne x)) + (send-point f (pg-box-sw x)))) +(define (send-circle f x) + (unless (pg-circle? x) (send-error f "circle" x #:contract 'pg-circle?)) + (bytes-append (send-point f (pg-circle-center x)) (float8 (pg-circle-radius x)))) -(define (send-lseg f i x) - (unless (line? x) (send-error f i "lseg" x)) +(define (send-lseg f x) + (unless (line? x) (send-error f "lseg" x #:contract 'line?)) (let ([points (line-string-points x)]) - (bytes-append (send-point f #f (car points)) - (send-point f #f (cadr points))))) -(define (send-path f i x) - (unless (pg-path? x) (send-error f i "path" x)) + (bytes-append (send-point f (car points)) + (send-point f (cadr points))))) +(define (send-path f x) + (unless (pg-path? x) (send-error f "path" x #:contract 'pg-path?)) (apply bytes-append (bytes (if (pg-path-closed? x) 1 0)) (integer->integer-bytes (length (pg-path-points x)) 4 #t #t) (for/list ([p (in-list (pg-path-points x))]) - (send-point f #f p)))) -(define (send-polygon f i x) - (unless (polygon? x) (send-error f i "polygon" x)) + (send-point f p)))) +(define (send-polygon f x) + (unless (polygon? x) (send-error f "polygon" x #:contract 'polygon?)) (let* ([points0 (line-string-points (polygon-exterior x))] [points (drop-right points0 1)]) ;; drop closing copy of first point (apply bytes-append (integer->integer-bytes (length points) 4 #t #t) (for/list ([p (in-list points)]) - (send-point f #f p))))) + (send-point f p))))) -(define ((send-array elttype) f i x0) +(define (send-date f x) + (cond [(sql-date? x) + (let* ([d (sql-datetime->srfi-date x)] + ;; julian day starts at noon of date, so round up (ceiling) + [jd (ceiling (srfi:date->julian-day d))] + [jd* (- jd POSTGRESQL-JD-ADJUST)]) + (integer->integer-bytes jd* 4 #t #t))] + [else (send-error f "date" x #:contract 'sql-date?)])) + +(define (hmsn->usec-bytes hr min sec nsec) + (let* ([min (+ min (* hr 60))] + [sec (+ sec (* min 60))] + [usec (+ (quotient nsec #e1e3) (* sec #e1e6))]) + (cond [(use-integer-datetimes?) + (integer->integer-bytes usec 8 #t #t)] + [else + (let ([sec (/ usec #i1e6)]) + (real->floating-point-bytes sec 8 #t))]))) + +(define (send-time f x) + (match x + [(sql-time h m s ns _tz) + (hmsn->usec-bytes h m s ns)] + [_ (send-error f "time" x #:contract 'sql-time?)])) + +(define (send-timetz f x) + (match x + [(sql-time h m s ns (? values tz)) + (bytes-append (hmsn->usec-bytes h m s ns) + ;; FIXME: seem to need to invert timezone (see also recv-timetz) + (integer->integer-bytes (- tz) 4 #t #t))] + [_ (send-error f "time with time zone" x + #:contract '(and/c sql-time? sql-time-tz))])) + +(define (send-timestamp* f x tz?) + (match x + [(sql-timestamp yr mon day hr min sec nsec (? (if tz? values void) tz)) + (let* ([sd (srfi:make-date 0 0 0 12 day mon yr 0)] + [jd (srfi:date->julian-day sd)] + [jd* (- jd POSTGRESQL-JD-ADJUST)] + [hr (+ hr (* jd* 24))] + [sec (- sec (or tz 0))]) + (hmsn->usec-bytes hr min sec nsec))] + [+inf.0 + (if (use-integer-datetimes?) + (integer->integer-bytes (sub1 (expt 2 63)) 8 #t #t) + (real->floating-point-bytes +inf.0 8 #t))] + [-inf.0 + (if (use-integer-datetimes?) + (integer->integer-bytes (- (expt 2 63)) 8 #t #t) + (real->floating-point-bytes -inf.0 8 #t))] + [_ + (let ([type (if tz? "timestamp with time zone" "timestamp without time zone")] + [ctc (if tz? '(and/c sql-timestamp? sql-timestamp-tz) 'sql-timestamp?)]) + (send-error f type x #:contract ctc))])) + +(define (send-timestamp f x) (send-timestamp* f x #f)) +(define (send-timestamptz f x) (send-timestamp* f x #t)) + +(define (send-interval f x) + (match x + [(sql-interval yr mon day hr min sec nsec) + (let ([mon (+ mon (* yr 12))]) + (bytes-append (hmsn->usec-bytes hr min sec nsec) + (integer->integer-bytes day 4 #t #t) + (integer->integer-bytes mon 4 #t #t)))] + [_ (send-error f "interval" x #:contract 'sql-interval?)])) + +;; round-up-to : nat nat>0 -> nat +;; round n up to the nearest multiple of m +(define (round-up-to n m) + (let ([rem (remainder n m)]) + (if (zero? rem) n (+ n (- m rem))))) + +;; numeric: digits:int2 weight:int2 sign:int2 dscale:int2 {digit:int2}^digits +;; (abs x) = * NBASE^(digits-(weight+1)) +;; = SUM {i in 0..} { digit_i * NBASE^(weight-i) } +(define (send-numeric f x) + (define NBASE #e1e4) + (define NBASE_MAGN 4) + (define NUMERIC_POS #x0000) + (define NUMERIC_NEG #x4000) + (define NUMERIC_NAN #xC000) + (define (mkint2 n [signed? #t]) + (integer->integer-bytes n 2 signed? #t)) + (define (nat->bigits n) + (let loop ([n n] [tail null]) + (cond [(zero? n) tail] + [else (let-values ([(rest bigit) (quotient/remainder n NBASE)]) + (loop rest (cons bigit tail)))]))) + (define (make-numeric bigit-count weight neg? dscale bigits) + (let ([sign-part (if neg? NUMERIC_NEG NUMERIC_POS)]) + (apply bytes-append + (map mkint2 (list* bigit-count weight sign-part dscale bigits))))) + + (cond [(rational? x) + (let* ([orig-x x] + [neg? (negative? x)] + [x (abs x)] + [M+E + (or (and (exact? x) (exact->scaled-integer x #t)) + (inexact->scaled-integer (exact->inexact x)))]) + ;; x = M*10^-E + (let* ([M (car M+E)] + [E (cdr M+E)] + ;; round E up to multiple of NBASE_MAGN + [E* (round-up-to E NBASE_MAGN)] + [M* (* M (expt 10 (- E* E)))] + [bigits (nat->bigits M*)] + ;; E* = #bigits - weight - 1 + ;; so weight = #bigits - E* - 1 + [bigit-count (length bigits)] + [weight (- bigit-count (quotient E* NBASE_MAGN) 1)] + [dscale (max 0 E)]) + (make-numeric bigit-count weight neg? dscale bigits)))] + [(eqv? x +nan.0) + (let ([NUMERIC_NAN #xC000]) + (bytes-append (mkint2 0) + (mkint2 0) + (mkint2 NUMERIC_NAN #f) + (mkint2 0)))] + [else + (send-error f "numeric" x #:contract '(or/c rational? +nan.0))])) + +(define (send-array elttype) ;; NOTE: elttype must have binary writer (define writer (typeid->type-writer elttype)) - (define x - (cond [(pg-array? x0) x0] - [(list? x0) (list->pg-array x0)] - [else (send-error f i "pg-array" x0)])) - (match x - [(pg-array ndim counts lbounds vals) - (let ([out (open-output-bytes)]) - (write-bytes (integer->integer-bytes ndim 4 #t #t) out) - (write-bytes (integer->integer-bytes 0 4 #t #t) out) - (write-bytes (integer->integer-bytes elttype 4 #t #t) out) - (for ([count (in-list counts)] - [lbound (in-list lbounds)]) - (write-bytes (integer->integer-bytes count 4 #t #t) out) - (write-bytes (integer->integer-bytes lbound 4 #t #t) out)) - (unless (zero? ndim) - (let loop ([n ndim] [vals vals]) - (cond [(zero? n) - (cond [(sql-null? vals) - (write-bytes (integer->integer-bytes -1 4 #t #t) out)] - [else - (let ([b (writer f #f vals)]) - (write-bytes (integer->integer-bytes (bytes-length b) 4 #t #t) out) - (write-bytes b out))])] - [else - (for ([v (in-vector vals)]) - (loop (sub1 n) v))]))) - (get-output-bytes out))])) + (lambda (f x0) + (define x + (cond [(pg-array? x0) x0] + [(list? x0) (list->pg-array x0)] + [else (send-error f "pg-array" x0 #:contract '(or/c list? pg-array?))])) + (match x + [(pg-array ndim counts lbounds vals) + (let ([out (open-output-bytes)]) + (write-bytes (integer->integer-bytes ndim 4 #t #t) out) + (write-bytes (integer->integer-bytes 0 4 #t #t) out) + (write-bytes (integer->integer-bytes elttype 4 #t #t) out) + (for ([count (in-list counts)] + [lbound (in-list lbounds)]) + (write-bytes (integer->integer-bytes count 4 #t #t) out) + (write-bytes (integer->integer-bytes lbound 4 #t #t) out)) + (unless (zero? ndim) + (let loop ([n ndim] [vals vals]) + (cond [(zero? n) + (cond [(sql-null? vals) + (write-bytes (integer->integer-bytes -1 4 #t #t) out)] + [else + (let ([b (writer f vals)]) + (write-bytes (integer->integer-bytes (bytes-length b) 4 #t #t) out) + (write-bytes b out))])] + [else + (for ([v (in-vector vals)]) + (loop (sub1 n) v))]))) + (get-output-bytes out))]))) + +(define (send-json f x) + (unless (jsexpr? x) + (send-error f "json" x #:contract 'jsexpr?)) + (jsexpr->bytes x)) + +(define (send-range elttype) + (define EMPTY #x01) + (define LB_INC #x02) + (define UB_INC #x04) + (define LB_INF #x08) + (define UB_INF #x10) + (define writer (typeid->type-writer elttype)) + (lambda (f x) + (match x + [(pg-range lb includes-lb? ub includes-ub?) + (let* ([flags (+ (if lb 0 LB_INF) + (if ub 0 UB_INF) + (if includes-lb? LB_INC 0) + (if includes-ub? UB_INC 0))] + [lb-bytes (and lb (writer f lb))] + [ub-bytes (and ub (writer f ub))]) + (bytes-append (bytes flags) + (if lb-bytes + (integer->integer-bytes (bytes-length lb-bytes) 4 #t #t) + #"") + (or lb-bytes #"") + (if ub-bytes + (integer->integer-bytes (bytes-length ub-bytes) 4 #t #t) + #"") + (or ub-bytes #"")))] + [(pg-empty-range) + (bytes 1)]))) ;; send-error : string datum -> (raises error) -(define (send-error f i type datum) - (error/no-convert f "PostgreSQL" type datum)) - -;; == Readers and writers == - -(define (typeid->type-reader fsym typeid) - (case typeid - ((16) recv-boolean) - ((17) recv-bytea) - ((18) recv-char1) - ((19) recv-string) - ((20) recv-integer) - ((21) recv-integer) - ((23) recv-integer) - ((25) recv-string) - ((26) recv-integer) - ((700) recv-float) - ((701) recv-float) - ((1042) recv-string) - ((1043) recv-string) - ((600) recv-point) - ((601) recv-lseg) - ((602) recv-path) - ((603) recv-box) - ((604) recv-polygon) - ((718) recv-circle) - ((1560) recv-bits) - ((1562) recv-bits) - ((2249) recv-record) - - ((1000) recv-array) ;; _bool - ((1001) recv-array) ;; _bytea - ((1002) recv-array) ;; _char - ((1003) recv-array) ;; _name - ((1005) recv-array) ;; _int2 - ((1007) recv-array) ;; _int4 - ((1009) recv-array) ;; _text - ((1028) recv-array) ;; _oid - ((1014) recv-array) ;; _bpchar - ((1015) recv-array) ;; _varchar - ((1016) recv-array) ;; _int8 - ((1017) recv-array) ;; _point - ((1018) recv-array) ;; _lseg - ((1019) recv-array) ;; _path - ((1020) recv-array) ;; _box - ((1021) recv-array) ;; _float4 - ((1022) recv-array) ;; _float8 - ((1027) recv-array) ;; _polygon - ((1561) recv-array) ;; _bit - ((1563) recv-array) ;; _varbit - ((2287) recv-array) ;; _record - ((719) recv-array) ;; _circle - - ((1082) c-parse-date) - ((1083) c-parse-time) - ((1114) c-parse-timestamp) - ((1184) c-parse-timestamp-tz) - ((1186) c-parse-interval) - ((1266) c-parse-time-tz) - ((1700) c-parse-decimal) - - ((1115) (c-parse-array parse-timestamp)) - ((1182) (c-parse-array parse-date)) - ((1183) (c-parse-array parse-time)) - ((1185) (c-parse-array parse-timestamp-tz)) - ((1187) (c-parse-array parse-interval)) - ((1231) (c-parse-array parse-decimal)) - ((1270) (c-parse-array parse-time-tz)) - - ;; "string" literals have type unknown; just treat as string - ((705) recv-string) - (else (error/unsupported-type fsym typeid (typeid->type typeid))))) - -(define (typeid->type-writer typeid) - (case typeid - ((16) send-boolean) - ((17) send-bytea) - ((18) send-char1) - ((19) send-string) - ((20) send-int8) - ((21) send-int2) - ((23) send-int4) - ((25) send-string) - ((26) send-int4) - ((700) send-float4) - ((701) send-float8) - ((1042) send-string) - ((1043) send-string) - ((600) send-point) - ((601) send-lseg) - ((602) send-path) - ((603) send-box) - ((604) send-polygon) - ((718) send-circle) - ((1560) send-bits) - ((1562) send-bits) - - ((1000) (send-array 16)) ;; _bool - ((1001) (send-array 17)) ;; _bytea - ((1002) (send-array 18)) ;; _char - ((1003) (send-array 19)) ;; _name - ((1005) (send-array 21)) ;; _int2 - ((1007) (send-array 23)) ;; _int4 - ((1009) (send-array 25)) ;; _text - ((1028) (send-array 26)) ;; _oid - ((1014) (send-array 1042)) ;; _bpchar - ((1015) (send-array 1043)) ;; _varchar - ((1016) (send-array 20)) ;; _int8 - ((1017) (send-array 600)) ;; _point - ((1018) (send-array 601)) ;; _lseg - ((1019) (send-array 602)) ;; _path - ((1020) (send-array 603)) ;; _box - ((1021) (send-array 700)) ;; _float4 - ((1022) (send-array 701)) ;; _float8 - ((1027) (send-array 604)) ;; _polygon - ((1263) (send-array 2275)) ;; _cstring - ((1561) (send-array 1560)) ;; _bit - ((1563) (send-array 1562)) ;; _varbit - ((719) (send-array 718)) ;; _circle - - ((1082) marshal-date) - ((1083) marshal-time) - ((1114) marshal-timestamp) - ((1184) marshal-timestamp-tz) - ((1186) marshal-interval) - ((1266) marshal-time-tz) - ((1700) marshal-decimal) - - ((1115) (marshal-array marshal-timestamp)) - ((1182) (marshal-array marshal-date)) - ((1183) (marshal-array marshal-time)) - ((1185) (marshal-array marshal-timestamp-tz)) - ((1187) (marshal-array marshal-interval)) - ((1231) (marshal-array marshal-decimal)) - ((1270) (marshal-array marshal-time-tz)) - - ;; "string" literals have type unknown; just treat as string - ((705) send-string) - (else (make-unsupported-writer typeid (typeid->type typeid))))) - -(define (typeid->format x) - (case x - ((16 17 18 19 20 21 23 25 26 700 701 1042 1043 705) 1) - ((600 601 602 603 604 718 1560 1562 2249) 1) - ((1000 1001 1002 1003 1005 1007 1009 1028 1010 - 1011 1012 1014 1015 1016 1017 1018 1019 1020 - 1021 1022 1027 1561 1563 2287) 1) - (else 0))) - -(define (make-unsupported-writer x t) - (lambda (fsym . args) - (error/unsupported-type fsym x t))) +(define (send-error f type datum #:contract [ctc #f]) + (error/no-convert f "PostgreSQL" type datum #:contract ctc)) diff --git a/collects/db/private/postgresql/message.rkt b/collects/db/private/postgresql/message.rkt index 060d36d779..8cdaddb850 100644 --- a/collects/db/private/postgresql/message.rkt +++ b/collects/db/private/postgresql/message.rkt @@ -1,7 +1,6 @@ #lang racket/base (require (for-syntax racket/base) racket/match - unstable/error "../generic/interfaces.rkt" "../generic/sql-data.rkt") (provide write-message diff --git a/collects/db/private/sqlite3/dbsystem.rkt b/collects/db/private/sqlite3/dbsystem.rkt index 439745f2e3..1b7833999a 100644 --- a/collects/db/private/sqlite3/dbsystem.rkt +++ b/collects/db/private/sqlite3/dbsystem.rkt @@ -6,9 +6,9 @@ classify-sl-sql) (define sqlite3-dbsystem% - (class* object% (dbsystem<%>) + (class* dbsystem-base% (dbsystem<%>) (define/public (get-short-name) 'sqlite3) - (define/public (get-known-types) '(any)) + (define/override (get-type-list) '((any 0))) (define/public (has-support? x) #f) (define/public (get-parameter-handlers param-typeids) @@ -32,7 +32,7 @@ ;; ======================================== -(define (check-param fsym index param) +(define (check-param fsym param) (unless (or (real? param) (string? param) (bytes? param)) diff --git a/collects/db/scribblings/config.rkt b/collects/db/scribblings/config.rkt index 15f54721bd..d14b4f1866 100644 --- a/collects/db/scribblings/config.rkt +++ b/collects/db/scribblings/config.rkt @@ -2,7 +2,6 @@ (require scribble/manual scribble/eval unstable/sandbox - racket/runtime-path (for-label racket/base racket/contract)) (provide (all-defined-out) diff --git a/collects/db/scribblings/log-for-sql-types.rktd b/collects/db/scribblings/log-for-sql-types.rktd index cdf92400f0..e0444cfb17 100644 --- a/collects/db/scribblings/log-for-sql-types.rktd +++ b/collects/db/scribblings/log-for-sql-types.rktd @@ -74,17 +74,17 @@ (c exn c - "query-value: cannot convert given value to SQL type\n given: 1\n type: string\n dialect: PostgreSQL")) + "query-value: cannot convert given value to SQL type\n given: 1\n type: string\n expected: string?\n dialect: PostgreSQL")) #"" #"") -((query-value c "select NULL") +((query-value pgc "select NULL") ((3) - 0 - () + 1 + (((lib "db/private/generic/sql-data.rkt") . deserialize-info:sql-null-v0)) 0 () () - (c exn c "c: undefined;\n cannot reference undefined identifier")) + (c values c (0))) #"" #"") ((sql-null->false "apple") ((3) 0 () 0 () () (c values c "apple")) #"" #"") @@ -142,7 +142,7 @@ 0 () () - (c values c (0 1969 12 31 19 0 0 0 -18000))) + (c values c (0 1970 1 1 0 0 0 0 0))) #"" #"") ((sql-bits->list (string->sql-bits "1011")) diff --git a/collects/db/scribblings/notes.scrbl b/collects/db/scribblings/notes.scrbl index 9673ed487d..4fae2a7e30 100644 --- a/collects/db/scribblings/notes.scrbl +++ b/collects/db/scribblings/notes.scrbl @@ -67,6 +67,41 @@ PostgreSQL 9.1, this authentication method has been renamed @tt{peer}). The @tt{gss}, @tt{sspi}, @tt{krb5}, @tt{pam}, and @tt{ldap} methods are not supported. +@section[#:tag "postgresql-timestamp-tz"]{PostgreSQL Timestamps and Time Zones} + +PostgreSQL's @tt{timestamp with time zone} type is inconsistent with +the SQL standard (probably), inconsistent with @tt{time with time +zone}, and potentially confusing to PostgreSQL newcomers. + +A @tt{time with time zone} is essentially a @tt{time} structure with +an additional field storing a time zone offset. In contrast, a +@tt{timestamp with time zone} has no fields beyond those of +@tt{timestamp}. Rather, it indicates that its datetime fields should +be interpreted as a UTC time. Thus it represents an absolute point in +time, unlike @tt{timestamp without time zone}, which represents local +date and time in some unknown time zone (possibly---hopefully---known +the the database designer, but unknown to PostgreSQL). + +When a @tt{timestamp with time zone} is created from a source without +time zone information, the session's @tt{TIME ZONE} setting is used to +adjust the source to UTC time. When the source contains time zone +information, it is used to adjust the timestamp to UTC time. In either +case, the time zone information is @emph{discarded} and only the UTC +timestamp is stored. When a @tt{timestamp with time zone} is rendered +as text, it is first adjusted to the time zone specified by the +@tt{TIME ZONE} setting (or by +@hyperlink["http://www.postgresql.org/docs/8.0/static/functions-datetime.html#FUNCTIONS-DATETIME-ZONECONVERT"]{@tt{AT +TIME ZONE}}) and that offset is included in the rendered text. + +This library receives timestamps in binary format, so the time zone +adjustment is not applied, nor is the session's @tt{TIME ZONE} offset +included; thus all @racket[sql-timestamp] values in a query result +have a @racket[tz] field of @racket[0] (for @tt{timestamp with time +zone}) or @racket[#f] (for @tt{timestamp without time +zone}). (Previous versions of this library sent and received +timestamps as text, so they received timestamps with adjusted time +zones.) + @section{MySQL Authentication} diff --git a/collects/db/scribblings/sql-types.scrbl b/collects/db/scribblings/sql-types.scrbl index a1922e1289..b30149bade 100644 --- a/collects/db/scribblings/sql-types.scrbl +++ b/collects/db/scribblings/sql-types.scrbl @@ -7,7 +7,8 @@ "config.rkt" "tabbing.rkt" (for-label (prefix-in srfi: srfi/19) - db db/util/geometry db/util/postgresql)) + db db/util/geometry db/util/postgresql + json)) @(define-runtime-path log-file "log-for-sql-types.rktd") @(define the-eval (make-pg-eval log-file #t)) @@ -66,7 +67,7 @@ along with their corresponding Racket representations. @racket['bigint] @& @tt{int8} @& @racket[exact-integer?] @// @racket['real] @& @tt{float4} @& @racket[real?] @// @racket['double] @& @tt{float8} @& @racket[real?] @// - @racket['decimal] @& @tt{numeric} @& @racket[number?] @// + @racket['decimal] @& @tt{numeric} @& @racket[rational?] or @racket[+nan.0] @// @racket['character] @& @tt{bpchar} @& @racket[string?] @// @racket['varchar] @& @tt{varchar} @& @racket[string?] @// @racket['text] @& @tt{text} @& @racket[string?] @// @@ -74,12 +75,22 @@ along with their corresponding Racket representations. @racket['date] @& @tt{date} @& @racket[sql-date?] @// @racket['time] @& @tt{time} @& @racket[sql-time?] @// @racket['timetz] @& @tt{timetz} @& @racket[sql-time?] @// - @racket['timestamp] @& @tt{timestamp} @& @racket[sql-timestamp?] @// - @racket['timestamptz] @& @tt{timestamptz} @& @racket[sql-timestamp?] @// + @racket['timestamp] @& @tt{timestamp} @& @racket[sql-timestamp?] + or @racket[-inf.0] or @racket[+inf.0] @// + @racket['timestamptz] @& @tt{timestamptz} @& @racket[sql-timestamp?] + or @racket[-inf.0] or @racket[+inf.0] @// @racket['interval] @& @tt{interval} @& @racket[sql-interval?] @// @racket['bit] @& @tt{bit} @& @racket[sql-bits?] @// @racket['varbit] @& @tt{varbit} @& @racket[sql-bits?] @// + @racket['json] @& @tt{json} @& @racket[jsexpr?] @// + @racket['int4range] @& @tt{int4range} @& @racket[pg-range-or-empty?] @// + @racket['int8range] @& @tt{int8range} @& @racket[pg-range-or-empty?] @// + @racket['numrange] @& @tt{numrange} @& @racket[pg-range-or-empty?] @// + @racket['tsrange] @& @tt{tsrange} @& @racket[pg-range-or-empty?] @// + @racket['tstzrange] @& @tt{tstzrange} @& @racket[pg-range-or-empty?] @// + @racket['daterange] @& @tt{daterange} @& @racket[pg-range-or-empty?] @// + @racket['point] @& @tt{point} @& @racket[point?] @// @racket['lseg] @& @tt{lseg} @& @racket[line?] @// @racket['path] @& @tt{path} @& @racket[pg-path?] @// @@ -107,6 +118,13 @@ to the same type. (query-value pgc "select numeric '12345678901234567890'") ] +A SQL @tt{timestamp with time zone} is converted to a Racket +@racket[sql-timestamp] in UTC---that is, with a @racket[tz] field of +@racket[0]. If a Racket @racket[sql-timestamp] without a time zone +(@racket[tz] is @racket[#f]) is given for a parameter of type +@tt{timestamp with time zone}, it is treated as a timestamp in +UTC. See also @secref["postgresql-timestamp-tz"]. + The geometric types such as @racket['point] are represented by structures defined in the @racketmodname[db/util/geometry] and @racketmodname[db/util/postgresql] modules. @@ -323,7 +341,7 @@ SQL @tt{NULL} is translated into the unique @racket[sql-null] value. @racket[eq?]. @examples[#:eval the-eval -(query-value c "select NULL") +(query-value pgc "select NULL") ] } diff --git a/collects/db/scribblings/util.scrbl b/collects/db/scribblings/util.scrbl index bc19d138b2..a790a24438 100644 --- a/collects/db/scribblings/util.scrbl +++ b/collects/db/scribblings/util.scrbl @@ -183,6 +183,34 @@ Returns a @racket[pg-array] of dimension 1 with the contents of @racket[lst]. } +@defstruct*[pg-empty-range ()]{ + +Represents an empty range. +} + +@defstruct*[pg-range + ([lb _range-type] + [includes-lb? boolean?] + [ub _range-type] + [includes-ub? boolean?])]{ + +Represents a range of values from @racket[lb] (lower bound) to +@racket[ub] (upper bound). The @racket[includes-lb?] and +@racket[includes-ub?] fields indicate whether each end of the range is +open or closed. + +The @racket[lb] and @racket[ub] fields must have the same type; the +permissible types are exact integers, real numbers, and +@racket[sql-timestamp]s. Either or both bounds may also be +@racket[#f], which indicates the range is unbounded on that end. +} + +@defproc[(pg-range-or-empty? [v any/c]) boolean?]{ + +Returns @racket[#t] if @racket[v] is a @racket[pg-range] or +@racket[pg-empty-range] instance; otherwise, returns @racket[#f]. +} + @deftogether[[ @defstruct*[pg-box ([ne point?] [sw point?])] diff --git a/collects/db/util/postgresql.rkt b/collects/db/util/postgresql.rkt index dae5765f0e..dcd19b80c2 100644 --- a/collects/db/util/postgresql.rkt +++ b/collects/db/util/postgresql.rkt @@ -1,5 +1,6 @@ #lang racket/base (require racket/contract/base + racket/serialize racket/string unstable/error "geometry.rkt") @@ -17,7 +18,7 @@ point = x y (all float8) polygon = #points:int4 (x y : float8)* |# -(struct pg-box (ne sw) +(serializable-struct pg-box (ne sw) #:transparent #:guard (lambda (ne sw _n) (let ([x1 (point-x ne)] @@ -27,18 +28,18 @@ polygon = #points:int4 (x y : float8)* (values (point (max x1 x2) (max y1 y2)) (point (min x1 x2) (min y1 y2)))))) -(struct pg-circle (center radius) +(serializable-struct pg-circle (center radius) #:transparent #:guard (lambda (center radius _n) (values center (exact->inexact radius)))) -(struct pg-path (closed? points) +(serializable-struct pg-path (closed? points) #:transparent #:guard (lambda (closed? points _n) (values (and closed? #t) points))) -(struct pg-array (dimensions dimension-lengths dimension-lower-bounds contents) +(serializable-struct pg-array (dimensions dimension-lengths dimension-lower-bounds contents) #:transparent #:guard (lambda (ndim counts lbounds vals _n) (unless (= (length counts) ndim) @@ -91,6 +92,14 @@ polygon = #points:int4 (x y : float8)* (pg-array 0 '() '() '#())] [else (pg-array 1 (list (length lst)) '(1) (list->vector lst))])) +(serializable-struct pg-empty-range () + #:transparent) +(serializable-struct pg-range (lb includes-lb? ub includes-ub?) + #:transparent) + +(define (pg-range-or-empty? v) + (or (pg-empty-range? v) (pg-range? v))) + (provide/contract [struct pg-box ([ne point?] [sw point?])] [struct pg-circle ([center point?] [radius (and/c real? (not/c negative?))])] @@ -105,4 +114,11 @@ polygon = #points:int4 (x y : float8)* [pg-array->list (-> pg-array? list?)] [list->pg-array - (-> list? pg-array?)]) + (-> list? pg-array?)] + + [struct pg-empty-range ()] + [struct pg-range ([lb any/c] + [includes-lb? boolean?] + [ub any/c] + [includes-ub? boolean?])] + [pg-range-or-empty? (-> any/c boolean?)]) diff --git a/collects/tests/db/db/sql-types.rkt b/collects/tests/db/db/sql-types.rkt index 21d3449ca7..1d2c294299 100644 --- a/collects/tests/db/db/sql-types.rkt +++ b/collects/tests/db/db/sql-types.rkt @@ -1,7 +1,9 @@ #lang racket/unit (require rackunit racket/class + racket/list racket/math + racket/match racket/string (prefix-in srfi: srfi/19) db/base @@ -21,7 +23,7 @@ (let* ([known-types (if (ANYFLAGS 'sqlite3) '(bigint double text blob) - (send dbsystem get-known-types))] + (send dbsystem get-known-types +inf.0))] [type (for/or ([type types]) (and (member type known-types) type))]) (when type @@ -29,9 +31,18 @@ (parameterize ((current-type type)) (proc)))))) (define (check-timestamptz-equal? a b) - (check srfi:time=? - (srfi:date->time-utc (sql-datetime->srfi-date a)) - (srfi:date->time-utc (sql-datetime->srfi-date b)))) + (cond [(and (sql-timestamp? a) (sql-timestamp? b)) + (check srfi:time=? + (srfi:date->time-utc (sql-datetime->srfi-date a)) + (srfi:date->time-utc (sql-datetime->srfi-date b)))] + [(and (pg-range? a) (pg-range? b)) + (match (list a b) + [(list (pg-range alb ali? aub aui?) (pg-range blb bli? bub bui?)) + (and (check-timestamptz-equal? alb blb) + (check-equal? ali? bli?) + (check-timestamptz-equal? aub bub) + (check-equal? aui? bui?))])] + [else (check-equal? a b)])) (define (check-bits-equal? a b) (check-equal? (sql-bits->string a) (sql-bits->string b))) @@ -108,6 +119,21 @@ (define-check (check-roundtrip c value) (check-roundtrip* c value check-equal?)) +(define (check-value/text* c val text check-val-equal? check-text-equal?) + (cond [(ANYFLAGS 'postgresql) + (let* ([tname (pg-type-name (current-type))] + [q-text->val (sql (format "select ($1::text)::~a" tname))] + [q-val->text (sql (format "select ($1::~a)::text" tname))]) + (when check-val-equal? + (check-val-equal? (query-value c q-text->val text) val)) + (when check-text-equal? + (check-text-equal? (query-value c q-val->text val) text)))] + ;; FIXME: mysql just test val->text since text->val irregular + [else (void)])) + +(define-check (check-value/text c val text) + (check-value/text* c val text check-equal? check-equal?)) + (define-check (check-varchar c str) ;; Check roundtrip (only checks same when arrives back at client) (check-roundtrip c str) @@ -155,6 +181,54 @@ (check-equal? (query-value c (format "select ~a = any ($1)" elt) (list->pg-array lst)) in?)) +(define some-dates + `((,(sql-date 1776 07 04) "1776-07-04") + (,(sql-date 2000 01 01) "2000-01-01") + (,(sql-date 2012 02 14) "2012-02-14"))) + +(define some-times + `((,(sql-time 01 02 03 0 #f) "01:02:03") + (,(sql-time 12 34 56 0 #f) "12:34:56") + (,(sql-time 17 30 01 0 #f) "17:30:01") + (,(sql-time 01 02 03 #e4e7 #f) "01:02:03.04") + (,(sql-time 12 34 56 123456000 #f) "12:34:56.123456"))) + +(define some-timetzs + `((,(sql-time 01 02 03 0 3600) "01:02:03+01") + (,(sql-time 12 34 56 0 3600) "12:34:56+01") + (,(sql-time 17 30 01 0 -7200) "17:30:01-02") + (,(sql-time 01 02 03 #e4e7 3600) "01:02:03.04+01") + (,(sql-time 12 34 56 123456000 3600) "12:34:56.123456+01") + (,(sql-time 12 34 56 123456000 -7200) "12:34:56.123456-02"))) + +(define some-timestamps + `((,(sql-timestamp 2000 01 01 12 34 56 0 #f) "2000-01-01 12:34:56") + (,(sql-timestamp 1776 07 04 12 34 56 0 #f) "1776-07-04 12:34:56") + (,(sql-timestamp 2012 02 14 12 34 56 0 #f) "2012-02-14 12:34:56") + (,(sql-timestamp 2000 01 01 12 34 56 123456000 #f) "2000-01-01 12:34:56.123456") + (,(sql-timestamp 1776 07 04 12 34 56 123456000 #f) "1776-07-04 12:34:56.123456") + (,(sql-timestamp 2012 02 14 12 34 56 123456000 #f) "2012-02-14 12:34:56.123456") + (-inf.0 "-infinity") + (+inf.0 "infinity"))) + +(define some-timestamptzs + `((,(sql-timestamp 2000 01 01 12 34 56 0 -14400) "2000-01-01 12:34:56-04") + (,(sql-timestamp 1776 07 04 12 34 56 0 -14400) "1776-07-04 12:34:56-04") + (,(sql-timestamp 2012 02 14 12 34 56 0 7200) "2012-02-14 12:34:56+02") + (,(sql-timestamp 2000 01 01 12 34 56 123456000 14400) "2000-01-01 12:34:56.123456+04") + (,(sql-timestamp 1776 07 04 12 34 56 123456000 -14400) "1776-07-04 12:34:56.123456-04") + (,(sql-timestamp 2012 02 14 12 34 56 123456000 -7200) "2012-02-14 12:34:56.123456-02") + (-inf.0 "-infinity") + (+inf.0 "infinity"))) + +(define some-intervals + `((,(sql-interval 0 0 3 4 5 6 0) "3 days 04:05:06") + (,(sql-interval 87 1 0 0 0 0 0) "87 years 1 mon") + (,(sql-interval 1 2 3 4 5 6 45000) "1 year 2 mons 3 days 04:05:06.000045") + (,(sql-interval 0 0 -3 -4 -5 -6 0) "-3 days -04:05:06") + (,(sql-interval -87 -1 0 0 0 0 0) "-87 years -1 mons") + (,(sql-interval -1 -2 3 4 5 6 45000) "-1 years -2 mons +3 days 04:05:06.000045"))) + (define test (test-suite "SQL types (roundtrip, etc)" (type-test-case '(bool boolean) @@ -182,12 +256,13 @@ (when (ANYFLAGS 'mysql) ;; Test able to read large blobs ;; (depends on max_allowed_packet, though) - (let ([r (query-value c "select cast(repeat('a', 10000000) as binary)")]) - (check-pred bytes? r) - (check-equal? r (make-bytes 10000000 (char->integer #\a)))) - (let ([r (query-value c "select cast(repeat('a', 100000000) as binary)")]) - (check-pred bytes? r) - (check-equal? r (make-bytes 100000000 (char->integer #\a)))))))) + (define max-allowed-packet (query-value c "select @@session.max_allowed_packet")) + (for ([N (in-list '(#e1e7 #e1e8))]) + (when (<= N max-allowed-packet) + (let* ([q (format "select cast(repeat('a', ~s) as binary)" N)] + [r (query-value c q)]) + (check-pred bytes? r) + (check-equal? r (make-bytes N (char->integer #\a)))))))))) (type-test-case '(text) (call-with-connection (lambda (c) @@ -302,50 +377,48 @@ (type-test-case '(date) (call-with-connection (lambda (c) - (check-roundtrip c (make-sql-date 1980 08 17))))) + (for ([d+s some-dates]) + (check-roundtrip c (car d+s)) + (check-value/text c (car d+s) (cadr d+s)))))) (type-test-case '(time) (call-with-connection (lambda (c) - (check-roundtrip c (make-sql-time 12 34 56 0 #f)) - (unless (eq? dbsys 'odbc) ;; ODBC time has no fractional part - (check-roundtrip c (make-sql-time 12 34 56 123456000 #f)) - (check-roundtrip c (make-sql-time 12 34 56 100000000 #f)) - (check-roundtrip c (make-sql-time 12 34 56 000001000 #f)))))) + (for ([t+s some-times]) + (unless (and (eq? dbsys 'odbc) (> (sql-time-nanosecond (car t+s)) 0)) + ;; ODBC time has no fractional part + (check-roundtrip c (car t+s)) + (check-value/text c (car t+s) (cadr t+s))))))) (type-test-case '(timetz) (call-with-connection (lambda (c) - (check-roundtrip c (make-sql-time 12 34 56 0 3600)) - (check-roundtrip c (make-sql-time 12 34 56 123456000 3600)) - (check-roundtrip c (make-sql-time 12 34 56 100000000 3600)) - (check-roundtrip c (make-sql-time 12 34 56 000001000 3600))))) + (for ([t+s some-timetzs]) + (check-roundtrip c (car t+s)) + (check-value/text c (car t+s) (cadr t+s)))))) (type-test-case '(timestamp datetime) (call-with-connection (lambda (c) - (check-roundtrip c (make-sql-timestamp 1980 08 17 12 34 56 0 #f)) - (check-roundtrip c (make-sql-timestamp 1980 08 17 12 34 56 123456000 #f)) - (check-roundtrip c (make-sql-timestamp 1980 08 17 12 34 56 100000000 #f)) - (check-roundtrip c (make-sql-timestamp 1980 08 17 12 34 56 000001000 #f))))) - ;; Bizarrely, PostgreSQL converts timestamptz to a standard timezone - ;; when returning them, but it doesn't for timetz. + (for ([t+s some-timestamps]) + (when (or (TESTFLAGS 'postgresql) (sql-timestamp? (car t+s))) + ;; Only postgresql supports +/-inf.0 + (check-roundtrip c (car t+s)) + (check-value/text c (car t+s) (cadr t+s))))))) (type-test-case '(timestamptz) (call-with-connection (lambda (c) - (check-roundtrip* c (make-sql-timestamp 1980 08 17 12 34 56 0 3600) - check-timestamptz-equal?) - (check-roundtrip* c (make-sql-timestamp 1980 08 17 12 34 56 123456000 3600) - check-timestamptz-equal?) - (check-roundtrip* c (make-sql-timestamp 1980 08 17 12 34 56 100000000 3600) - check-timestamptz-equal?) - (check-roundtrip* c (make-sql-timestamp 1980 08 17 12 34 56 000001000 3600) - check-timestamptz-equal?)))) + (for ([t+s some-timestamptzs]) + (check-roundtrip* c (car t+s) check-timestamptz-equal?) + (check-value/text* c (car t+s) (cadr t+s) check-timestamptz-equal? #f))))) (type-test-case '(interval) (call-with-connection (lambda (c) - (check-roundtrip c (sql-interval 0 0 3 4 5 6 0)) - (check-roundtrip c (sql-interval 87 1 0 0 0 0 0)) - (when (memq dbsys '(postgresql)) - (check-roundtrip c (sql-interval 1 2 3 4 5 6 45000)))))) + (for ([i+s some-intervals]) + (when (or (memq dbsys '(postgresql)) + (sql-day-time-interval? i+s) + (sql-year-month-interval? i+s)) + (check-roundtrip c (car i+s)) + (when (memq dbsys '(postgresql)) + (check-value/text c (car i+s) (cadr i+s)))))))) (type-test-case '(varbit bit) (call-with-connection @@ -398,6 +471,67 @@ (lambda (c) (check-roundtrip c (pg-circle (point 1 2) 45)))))) + (when (TESTFLAGS 'postgresql 'pg92) + (type-test-case '(json) + (call-with-connection + (lambda (c) + (define some-jsexprs + (list #t #f 0 1 -2 pi "" "hello" "good\nbye" 'null + (hasheq 'a 1 'b 2 'c 'null) + (list #t #f 'null "a" "b"))) + (for ([j some-jsexprs]) + (check-roundtrip c j))))) + (type-test-case '(int4range) + (call-with-connection + (lambda (c) + (check-roundtrip c (pg-empty-range)) + ;; for now, only test things in canonical form... (FIXME) + (check-roundtrip c (pg-range 0 #t 5 #f)) + (check-roundtrip c (pg-range #f #f -57 #f)) + (check-roundtrip c (pg-range 1234 #t #f #f))))) + (type-test-case '(int8range) + (call-with-connection + (lambda (c) + (check-roundtrip c (pg-empty-range)) + ;; for now, only test things in canonical form... (FIXME) + (check-roundtrip c (pg-range 0 #t 5 #f)) + (check-roundtrip c (pg-range #f #f -57 #f)) + (check-roundtrip c (pg-range 1234 #t #f #f)) + (check-roundtrip c (pg-range (expt 2 60) #t (expt 2 61) #f))))) + ;; FIXME: numrange + (type-test-case '(daterange) + (call-with-connection + (lambda (c) + (define d1 (car (first some-dates))) + (define d2 (car (second some-dates))) + (define d3 (car (third some-dates))) + (check-roundtrip c (pg-empty-range)) + ;; for now, only test things in canonical form... (FIXME?) + (check-roundtrip c (pg-range d1 #t d3 #f)) + (check-roundtrip c (pg-range #f #f d2 #f)) + (check-roundtrip c (pg-range d3 #t #f #f))))) + (type-test-case '(tsrange) + (call-with-connection + (lambda (c) + (define ts1 (car (second some-timestamps))) + (define ts2 (car (first some-timestamps))) + (define ts3 (car (third some-timestamps))) + (check-roundtrip c (pg-empty-range)) + (check-roundtrip c (pg-range ts1 #t ts2 #t)) + (check-roundtrip c (pg-range ts1 #f ts3 #f)) + (check-roundtrip c (pg-range ts2 #f ts3 #t))))) + (type-test-case '(tstzrange) + (call-with-connection + (lambda (c) + (define ts1 (car (second some-timestamptzs))) + (define ts2 (car (first some-timestamptzs))) + (define ts3 (car (third some-timestamptzs))) + (check-roundtrip c (pg-empty-range)) + (check-roundtrip* c (pg-range ts1 #t ts2 #t) check-timestamptz-equal?) + (check-roundtrip* c (pg-range ts1 #f ts3 #f) check-timestamptz-equal?) + (check-roundtrip* c (pg-range ts2 #f ts3 #t) check-timestamptz-equal?))))) + + ;; --- Arrays --- (type-test-case '(boolean-array) (call-with-connection (lambda (c) diff --git a/collects/tests/db/gen/sql-types.rkt b/collects/tests/db/gen/sql-types.rkt index c2b8109e7c..032aa3a0a8 100644 --- a/collects/tests/db/gen/sql-types.rkt +++ b/collects/tests/db/gen/sql-types.rkt @@ -5,62 +5,11 @@ db/base db/private/generic/sql-convert "../config.rkt") -(require/expose - db/private/postgresql/dbsystem - (parse-date - parse-time - parse-time-tz - parse-timestamp - parse-timestamp-tz)) (provide sql-types:test) (define sql-types:test (test-suite "SQL support utilities" - (test-suite "Parsing SQL types" - (test-case "date" - (check-equal? (parse-date "1980-08-17") - (make-sql-date 1980 08 17))) - (test-case "time" - (check-equal? (parse-time "12:34:56") - (make-sql-time 12 34 56 0 #f)) - (check-equal? (parse-time "12:34:56.789") - (make-sql-time 12 34 56 789000000 #f)) - (check-equal? (parse-time "12:34:56.000789") - (make-sql-time 12 34 56 000789000 #f))) - (test-case "timetz" - (check-equal? (parse-time-tz "12:34:56+0123") - (make-sql-time 12 34 56 0 4980)) - (check-equal? (parse-time-tz "12:34:56.789+0123") - (make-sql-time 12 34 56 789000000 4980)) - (check-equal? (parse-time-tz "12:34:56.000789-0123") - (make-sql-time 12 34 56 000789000 -4980))) - (test-case "timestamp" - (check-equal? - (parse-timestamp "1980-08-17 12:34:56") - (make-sql-timestamp 1980 08 17 12 34 56 0 #f)) - (check-equal? - (parse-timestamp "1980-08-17 12:34:56.123") - (make-sql-timestamp 1980 08 17 12 34 56 123000000 #f)) - (check-equal? - (parse-timestamp "1980-08-17 12:34:56.000123") - (make-sql-timestamp 1980 08 17 12 34 56 000123000 #f))) - (test-case "timestamp-with-time-zone" - (check-equal? - (parse-timestamp-tz "1980-08-17 12:34:56+0123") - (make-sql-timestamp 1980 08 17 12 34 56 0 4980)) - (check-equal? - (parse-timestamp-tz "1980-08-17 12:34:56.123+0123") - (make-sql-timestamp 1980 08 17 12 34 56 123000000 4980)) - (check-equal? - (parse-timestamp-tz "1980-08-17 12:34:56.000123-0123") - (make-sql-timestamp 1980 08 17 12 34 56 000123000 -4980))) - (test-case "numeric" - (check-equal? (parse-decimal "12345678901234567890") - 12345678901234567890) - (check-equal? (parse-decimal "-12345678901234567890") - -12345678901234567890))) - (test-suite "Auxiliaries" (test-case "exact->decimal-string" (check-equal? (exact->decimal-string 12) "12") (check-equal? (exact->decimal-string 1000) "1000") @@ -76,4 +25,4 @@ (check-equal? (exact->scaled-integer 1/4) (cons 25 2)) (check-equal? (exact->scaled-integer 1/10) (cons 1 1)) (check-equal? (exact->scaled-integer 1/20) (cons 5 2)) - (check-equal? (exact->scaled-integer 1/3) #f))))) + (check-equal? (exact->scaled-integer 1/3) #f))))