317 lines
9.8 KiB
Racket
317 lines
9.8 KiB
Racket
#lang racket/base
|
|
(require (for-syntax racket/base
|
|
syntax/parse
|
|
syntax/parse/experimental/template)
|
|
racket/dict
|
|
syntax/location
|
|
racket/contract/base)
|
|
|
|
;; ============================================================
|
|
|
|
(require "private/generic/interfaces.rkt"
|
|
"private/generic/sql-data.rkt")
|
|
|
|
(provide (struct-out simple-result)
|
|
(struct-out rows-result)
|
|
statement-binding?
|
|
(struct-out exn:fail:sql))
|
|
|
|
(provide sql-null
|
|
sql-null?
|
|
sql-null->false
|
|
false->sql-null)
|
|
|
|
(provide/contract
|
|
[struct sql-date ([year exact-integer?]
|
|
[month (integer-in 0 12)]
|
|
[day (integer-in 0 31)])]
|
|
[struct sql-time ([hour (integer-in 0 23)]
|
|
[minute (integer-in 0 59)]
|
|
[second (integer-in 0 61)] ;; leap seconds
|
|
[nanosecond (integer-in 0 (sub1 #e1e9))]
|
|
[tz (or/c #f exact-integer?)])]
|
|
[struct sql-timestamp ([year exact-integer?]
|
|
[month (integer-in 0 12)]
|
|
[day (integer-in 0 31)]
|
|
[hour (integer-in 0 23)]
|
|
[minute (integer-in 0 59)]
|
|
[second (integer-in 0 61)]
|
|
[nanosecond (integer-in 0 (sub1 #e1e9))]
|
|
[tz (or/c #f exact-integer?)])]
|
|
[struct sql-interval ([years exact-integer?]
|
|
[months exact-integer?]
|
|
[days exact-integer?]
|
|
[hours exact-integer?]
|
|
[minutes exact-integer?]
|
|
[seconds exact-integer?]
|
|
[nanoseconds exact-integer?])]
|
|
|
|
[sql-day-time-interval?
|
|
(-> any/c boolean?)]
|
|
[sql-year-month-interval?
|
|
(-> any/c boolean?)]
|
|
[sql-interval->sql-time
|
|
(->* (sql-interval?) (any/c)
|
|
any)]
|
|
[sql-time->sql-interval
|
|
(-> sql-time? sql-day-time-interval?)]
|
|
|
|
[make-sql-bits
|
|
(-> exact-nonnegative-integer? sql-bits?)]
|
|
[sql-bits?
|
|
(-> any/c boolean?)]
|
|
[sql-bits-length
|
|
(-> sql-bits? exact-nonnegative-integer?)]
|
|
[sql-bits-ref
|
|
(-> sql-bits? exact-nonnegative-integer? boolean?)]
|
|
[sql-bits-set!
|
|
(-> sql-bits? exact-nonnegative-integer? boolean? void?)]
|
|
[sql-bits->list
|
|
(-> sql-bits? (listof boolean?))]
|
|
[list->sql-bits
|
|
(-> (listof boolean?) sql-bits?)]
|
|
[sql-bits->string
|
|
(-> sql-bits? string?)]
|
|
[string->sql-bits
|
|
(-> string? sql-bits?)])
|
|
|
|
;; ============================================================
|
|
|
|
(require "private/generic/functions.rkt")
|
|
|
|
(define fetch-size/c
|
|
(or/c exact-positive-integer? +inf.0))
|
|
|
|
(define grouping-field/c (or/c string? exact-nonnegative-integer?))
|
|
(define group/c (or/c grouping-field/c (vectorof grouping-field/c)))
|
|
(define grouping/c (or/c group/c (listof group/c)))
|
|
|
|
(define group-mode/c
|
|
(listof (or/c 'list 'preserve-null)))
|
|
|
|
(define in-query/c
|
|
(->* (connection? statement?)
|
|
(#:fetch fetch-size/c
|
|
#:group grouping/c
|
|
#:group-mode group-mode/c)
|
|
#:rest list?
|
|
sequence?))
|
|
|
|
(define here-mod-path (quote-module-path))
|
|
|
|
(define-syntax contracted-in-query
|
|
(make-provide/contract-transformer
|
|
(quote-syntax in-query/c)
|
|
(quote-syntax in-query)
|
|
(quote-syntax in-query)
|
|
(quote-syntax here-mod-path)))
|
|
|
|
(define-sequence-syntax in-query*
|
|
(lambda () #'contracted-in-query)
|
|
(lambda (stx)
|
|
(syntax-parse stx
|
|
[[(var ...) (~and form
|
|
(in-query (~or (~optional (~seq #:fetch fetch-size))
|
|
(~optional (~seq #:group grouping-fields))
|
|
(~optional (~seq #:group-mode group-mode))
|
|
(~between arg:expr 2 +inf.0))
|
|
...))]
|
|
#:declare fetch-size (expr/c #'fetch-size/c #:context #'form) #:role "fetch size argument"
|
|
#:declare grouping-fields (expr/c #'grouping/c #:context #'form) #:role "grouping fields argument"
|
|
#:declare group-mode (expr/c #'group-mode/c #:context #'form) #:role "group mode argument"
|
|
#:with (c stmt q-arg ...) #'(arg ...)
|
|
#:declare c (expr/c #'connection? #:context #'form) #:role "connection argument"
|
|
#:declare stmt (expr/c #'statement? #:context #'form) #:role "statement argument"
|
|
(template
|
|
[(var ...) (in-query-helper (length '(var ...)) c.c stmt.c q-arg ...
|
|
(?? (?@ #:fetch fetch-size.c))
|
|
(?? (?@ #:group grouping-fields.c))
|
|
(?? (?@ #:group-mode group-mode.c)))])]
|
|
[_ #f])))
|
|
|
|
(provide (rename-out [in-query* in-query]))
|
|
|
|
(provide/contract
|
|
[connection?
|
|
(-> any/c any)]
|
|
[disconnect
|
|
(-> connection? any)]
|
|
[connected?
|
|
(-> connection? any)]
|
|
[connection-dbsystem
|
|
(-> connection? dbsystem?)]
|
|
[dbsystem?
|
|
(-> any/c any)]
|
|
[dbsystem-name
|
|
(-> dbsystem? symbol?)]
|
|
[dbsystem-supported-types
|
|
(-> dbsystem? (listof symbol?))]
|
|
|
|
[statement?
|
|
(-> any/c any)]
|
|
[prepared-statement?
|
|
(-> any/c any)]
|
|
[prepared-statement-parameter-types
|
|
(-> prepared-statement? (or/c list? #f))]
|
|
[prepared-statement-result-types
|
|
(-> prepared-statement? (or/c list? #f))]
|
|
|
|
[query-exec
|
|
(->* (connection? statement?) () #:rest list? any)]
|
|
[query-rows
|
|
(->* (connection? statement?)
|
|
(#:group grouping/c
|
|
#:group-mode group-mode/c)
|
|
#:rest list? (listof vector?))]
|
|
[query-list
|
|
(->* (connection? statement?) () #:rest list? list?)]
|
|
[query-row
|
|
(->* (connection? statement?) () #:rest list? vector?)]
|
|
[query-maybe-row
|
|
(->* (connection? statement?) () #:rest list? (or/c #f vector?))]
|
|
[query-value
|
|
(->* (connection? statement?) () #:rest list? any)]
|
|
[query-maybe-value
|
|
(->* (connection? statement?) () #:rest list? any)]
|
|
[query
|
|
(->* (connection? statement?) () #:rest list? any)]
|
|
|
|
[prepare
|
|
(-> connection? (or/c string? virtual-statement?) any)]
|
|
[bind-prepared-statement
|
|
(-> prepared-statement? list? any)]
|
|
|
|
[rename virtual-statement* virtual-statement
|
|
(-> (or/c string? (-> dbsystem? string?))
|
|
virtual-statement?)]
|
|
[virtual-statement?
|
|
(-> any/c boolean?)]
|
|
|
|
[start-transaction
|
|
(->* (connection?)
|
|
(#:isolation (or/c 'serializable 'repeatable-read 'read-committed 'read-uncommitted #f)
|
|
#:option any/c)
|
|
void?)]
|
|
[commit-transaction
|
|
(-> connection? void?)]
|
|
[rollback-transaction
|
|
(-> connection? void?)]
|
|
[in-transaction?
|
|
(-> connection? boolean?)]
|
|
[needs-rollback?
|
|
(-> connection? boolean?)]
|
|
[call-with-transaction
|
|
(->* (connection? (-> any))
|
|
(#:isolation (or/c 'serializable 'repeatable-read 'read-committed 'read-uncommitted #f)
|
|
#:option any/c)
|
|
any)]
|
|
|
|
[prop:statement
|
|
(struct-type-property/c
|
|
(-> any/c connection?
|
|
statement?))]
|
|
|
|
[list-tables
|
|
(->* (connection?)
|
|
(#:schema (or/c 'search-or-current 'search 'current))
|
|
(listof string?))]
|
|
[table-exists?
|
|
(->* (connection? string?)
|
|
(#:schema (or/c 'search-or-current 'search 'current)
|
|
#:case-sensitive? any/c)
|
|
boolean?)]
|
|
|
|
[group-rows
|
|
(->* (rows-result?
|
|
#:group grouping/c)
|
|
(#:group-mode (listof (or/c 'list 'preserve-null #|deprecated:|# 'preserve-null-rows)))
|
|
rows-result?)]
|
|
|
|
[rows->dict
|
|
(->* (rows-result? #:key grouping/c #:value grouping/c)
|
|
(#:value-mode group-mode/c)
|
|
dict?)]
|
|
)
|
|
|
|
;; ============================================================
|
|
|
|
(require "private/generic/connect-util.rkt")
|
|
|
|
(provide/contract
|
|
[kill-safe-connection
|
|
(-> connection? connection?)]
|
|
[virtual-connection
|
|
(->* ((or/c (-> connection?) connection-pool?))
|
|
()
|
|
connection?)]
|
|
[connection-pool
|
|
(->* ((-> connection?))
|
|
(#:max-connections (or/c (integer-in 1 10000) +inf.0)
|
|
#:max-idle-connections (or/c (integer-in 1 10000) +inf.0))
|
|
connection-pool?)]
|
|
[connection-pool?
|
|
(-> any/c boolean?)]
|
|
[connection-pool-lease
|
|
(->* (connection-pool?)
|
|
((or/c custodian? evt?))
|
|
connection?)])
|
|
|
|
;; ============================================================
|
|
|
|
(require "private/generic/dsn.rkt")
|
|
|
|
(provide dsn-connect) ;; can't express "or any kw at all" w/ ->* contract
|
|
(provide/contract
|
|
[struct data-source
|
|
([connector connector?]
|
|
[args arglist?]
|
|
[extensions (listof (list/c symbol? writable-datum?))])]
|
|
[current-dsn-file (parameter/c path-string?)]
|
|
[get-dsn
|
|
(->* (symbol?) (any/c #:dsn-file path-string?) any)]
|
|
[put-dsn
|
|
(->* (symbol? (or/c data-source? #f)) (#:dsn-file path-string?) void?)]
|
|
[postgresql-data-source
|
|
(->* ()
|
|
(#:user string?
|
|
#:database string?
|
|
#:server string?
|
|
#:port exact-positive-integer?
|
|
#:socket (or/c string? 'guess)
|
|
#:password (or/c string? #f)
|
|
#:allow-cleartext-password? boolean?
|
|
#:ssl (or/c 'yes 'optional 'no)
|
|
#:notice-handler (or/c 'output 'error)
|
|
#:notification-handler (or/c 'output 'error)
|
|
#:debug? any/c)
|
|
data-source?)]
|
|
[mysql-data-source
|
|
(->* ()
|
|
(#:user string?
|
|
#:database (or/c string? #f)
|
|
#:server string?
|
|
#:port exact-positive-integer?
|
|
#:socket (or/c string? 'guess)
|
|
#:password (or/c string? #f)
|
|
#:notice-handler (or/c 'output 'error)
|
|
#:debug? any/c)
|
|
data-source?)]
|
|
[sqlite3-data-source
|
|
(->* ()
|
|
(#:database (or/c string? 'memory 'temporary)
|
|
#:mode (or/c 'read-only 'read/write 'create)
|
|
#:busy-retry-limit (or/c exact-nonnegative-integer? +inf.0)
|
|
#:busy-retry-delay (and/c rational? (not/c negative?))
|
|
#:use-place boolean?)
|
|
data-source?)]
|
|
[odbc-data-source
|
|
(->* ()
|
|
(#:dsn string?
|
|
#:user string?
|
|
#:password string?
|
|
#:notice-handler (or/c 'output 'error)
|
|
#:strict-parameter-types? boolean?
|
|
#:character-mode (or/c 'wchar 'utf-8 'latin-1)
|
|
#:use-place boolean?)
|
|
data-source?)])
|