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

db: added support for postgresql 9.2 types (json, ranges)

Browse Source 
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
This commit is contained in:
Ryan Culpepper 2012-09-12 12:52:33 -04:00
parent c675cf47f0
commit 9d34f0f147
23 changed files with 1016 additions and 805 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/db/TODO
View File

@ -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)

3
collects/db/main.rkt
View File

@ -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"))

45
collects/db/private/generic/common.rkt
View File

@ -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))
string<?
#:key symbol->string
#: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)
string<?
#:key symbol->string
#:cache-keys? #t)))
(define/public (get-type-list) null)))
;; ----------------------------------------
;; Notice/notification handler maker
;; make-handler : output-port/symbol string -> string string -> void

6
collects/db/private/generic/functions.rkt
View File

@ -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

5
collects/db/private/generic/interfaces.rkt
View File

@ -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))

3
collects/db/private/generic/prepared.rkt
View File

@ -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)])))
;; ----

88
collects/db/private/generic/sql-convert.rkt
View File

@ -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,9 +24,14 @@
(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)
(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)])
@ -72,7 +39,28 @@
[(den** twos) (factor-out den* 2)])
(and (= 1 den**)
(let ([tens (max fives twos)])
(cons (* n (expt 10 tens)) tens))))))
(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))

56
collects/db/private/mysql/dbsystem.rkt
View File

@ -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*)
string<?
#:key symbol->string))
(define type-list
(append (map (lambda (t) (list t 0))
'(tinytext text mediumtext longtext var-binary))
type-list*))
;; decimal, date typeids not used (?)

20
collects/db/private/mysql/message.rkt
View File

@ -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)

16
collects/db/private/odbc/connection.rkt
View File

@ -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.

95
collects/db/private/odbc/dbsystem.rkt
View File

@ -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

48
collects/db/private/postgresql/connection.rkt
View File

@ -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)])
(parameterize ((use-integer-datetimes? integer-datetimes?))
(rows-result (map field-dvec->field-info field-dvecs)
(map (lambda (data) (bytes->row data type-readers))
rows)))]
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.

964
collects/db/private/postgresql/dbsystem.rkt
View File

File diff suppressed because it is too large Load Diff

1
collects/db/private/postgresql/message.rkt
View File

@ -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

6
collects/db/private/sqlite3/dbsystem.rkt
View File

@ -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))

1
collects/db/scribblings/config.rkt
View File

@ -2,7 +2,6 @@
(require scribble/manual
scribble/eval
unstable/sandbox
racket/runtime-path
(for-label racket/base
racket/contract))
(provide (all-defined-out)

12
collects/db/scribblings/log-for-sql-types.rktd
View File

@ -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"))

35
collects/db/scribblings/notes.scrbl
View File

@ -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}

28
collects/db/scribblings/sql-types.scrbl
View File

@ -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")
]
}

28
collects/db/scribblings/util.scrbl
View File

@ -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?])]

26
collects/db/util/postgresql.rkt
View File

@ -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?)])

202
collects/tests/db/db/sql-types.rkt
View File

@ -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)
(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))))
(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)")])
(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 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))))))))
(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))
(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-roundtrip c (sql-interval 1 2 3 4 5 6 45000))))))
(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)

53
collects/tests/db/gen/sql-types.rkt
View File

@ -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))))