├── .gitignore ├── LICENSE ├── README.md ├── db-doc ├── db │ ├── info.rkt │ └── scribblings │ │ ├── config.rkt │ │ ├── connect.scrbl │ │ ├── db.scrbl │ │ ├── log-for-connect.rktd │ │ ├── log-for-query.rktd │ │ ├── log-for-sql-types.rktd │ │ ├── log-for-using-db.rktd │ │ ├── log-for-util.rktd │ │ ├── notes.scrbl │ │ ├── query.scrbl │ │ ├── sql-types.scrbl │ │ ├── tabbing.rkt │ │ ├── using-db.scrbl │ │ └── util.scrbl └── info.rkt ├── db-lib ├── db │ ├── TODO │ ├── base.rkt │ ├── cassandra.rkt │ ├── info.rkt │ ├── main.rkt │ ├── mysql.rkt │ ├── odbc.rkt │ ├── postgresql.rkt │ ├── private │ │ ├── cassandra │ │ │ ├── connection.rkt │ │ │ ├── dbsystem.rkt │ │ │ ├── main.rkt │ │ │ └── message.rkt │ │ ├── generic │ │ │ ├── connect-util.rkt │ │ │ ├── dsn.rkt │ │ │ ├── functions2.rkt │ │ │ ├── place-client.rkt │ │ │ ├── place-server.rkt │ │ │ └── sql-convert.rkt │ │ ├── mysql │ │ │ ├── connection.rkt │ │ │ ├── dbsystem.rkt │ │ │ ├── main.rkt │ │ │ └── message.rkt │ │ ├── odbc │ │ │ ├── connection.rkt │ │ │ ├── dbsystem.rkt │ │ │ ├── ffi-constants.rkt │ │ │ ├── ffi.rkt │ │ │ └── main.rkt │ │ ├── postgresql │ │ │ ├── connection.rkt │ │ │ ├── dbsystem.rkt │ │ │ ├── main.rkt │ │ │ ├── message.rkt │ │ │ └── util.rkt │ │ └── sqlite3 │ │ │ └── place.rkt │ ├── sqlite3.rkt │ ├── unsafe │ │ └── sqlite3.rkt │ └── util │ │ ├── cassandra.rkt │ │ ├── datetime.rkt │ │ ├── geometry.rkt │ │ ├── mysql.rkt │ │ ├── postgresql.rkt │ │ ├── private │ │ └── geometry.rkt │ │ └── testing.rkt └── info.rkt ├── db-test ├── info.rkt └── tests │ └── db │ ├── all-tests.rkt │ ├── bin │ └── docker-util.sh │ ├── config.rkt │ ├── db │ ├── concurrent.rkt │ ├── connection.rkt │ ├── query.rkt │ ├── special.rkt │ └── sql-types.rkt │ ├── gen │ ├── misc.rkt │ ├── odbc.rkt │ ├── query.rkt │ └── sql-types.rkt │ ├── programs │ ├── .gitignore │ ├── cassandra.rkt │ ├── custodian.rkt │ ├── memleak.rkt │ ├── mysql-auth.rkt │ ├── pools.rkt │ ├── sl-insert-id.rkt │ ├── sl-inserts.rkt │ ├── sl-os-thread.rkt │ ├── sl-unsafe.rkt │ ├── sqlite3ext.c │ ├── startup-leak-test.rkt │ └── web-test.rkt │ └── test-dsn.rktd └── db └── info.rkt /.gitignore: -------------------------------------------------------------------------------- 1 | # Racket compiled files 2 | compiled/ 3 | 4 | # common backups, autosaves, lock files, OS meta-files 5 | *~ 6 | \#* 7 | .#* 8 | .DS_Store 9 | *.bak 10 | TAGS 11 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | This component of Racket is distributed under the under the Apache 2.0 2 | and MIT licenses. The user can choose the license under which they 3 | will be using the software. There may be other licenses within the 4 | distribution with which the user must also comply. 5 | 6 | See the files 7 | https://github.com/racket/racket/blob/master/racket/src/LICENSE-APACHE.txt 8 | and 9 | https://github.com/racket/racket/blob/master/racket/src/LICENSE-MIT.txt 10 | for the full text of the licenses. 11 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # db 2 | 3 | This the source for the Racket packages: "db", "db-doc", "db-lib", "db-test". 4 | 5 | ### Contributing 6 | 7 | Contribute to Racket by submitting a [pull request], reporting an 8 | [issue], joining the [development mailing list], or visiting the 9 | IRC or Slack channels. 10 | 11 | ### License 12 | 13 | Racket, including these packages, is free software, see [LICENSE] 14 | for more details. 15 | 16 | By making a contribution, you are agreeing that your contribution 17 | is licensed under the [Apache 2.0] license and the [MIT] license. 18 | 19 | [MIT]: https://github.com/racket/racket/blob/master/racket/src/LICENSE-MIT.txt 20 | [Apache 2.0]: https://www.apache.org/licenses/LICENSE-2.0.txt 21 | [pull request]: https://github.com/racket/db/pulls 22 | [issue]: https://github.com/racket/db/issues 23 | [development mailing list]: https://lists.racket-lang.org 24 | [LICENSE]: LICENSE 25 | -------------------------------------------------------------------------------- /db-doc/db/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection "db") 4 | (define scribblings '(("scribblings/db.scrbl" (multi-page) ("Databases")))) 5 | -------------------------------------------------------------------------------- /db-doc/db/scribblings/config.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require scribble/manual 3 | scribble/eval 4 | (for-label racket/base 5 | racket/contract)) 6 | (provide (all-defined-out) 7 | (for-label (all-from-out racket/base) 8 | (all-from-out racket/contract))) 9 | 10 | (define (tech/reference . pre-flows) 11 | (apply tech #:doc '(lib "scribblings/reference/reference.scrbl") pre-flows)) 12 | 13 | (define (parheading . pre-flows) 14 | (elem (apply bold pre-flows) (hspace 1))) 15 | 16 | (define (wplink path . pre-flows) 17 | (apply hyperlink (string-append "http://en.wikipedia.org/wiki/" path) pre-flows)) 18 | 19 | ;; ---- 20 | 21 | #| 22 | Whenever examples are changed, added, removed, or reordered, the 23 | example log files must be regenerated. To do so, set log-mode below to 24 | 'record and run setup. Regenerating the logs require an environment 25 | that defines the DSN 'db-scribble-env as a PostgreSQL data source. 26 | 27 | Set log-mode back to 'replay before checking in the changes. 28 | 29 | Use one evaluator (and log file) per scribble file, so that when DrDr 30 | runs scribble files individually, they still work. 31 | |# 32 | 33 | (define log-mode 'replay) 34 | 35 | (define (make-pg-eval log-file init?) 36 | (let ([ev (make-log-based-eval log-file log-mode)]) 37 | (ev '(require racket/class 38 | db 39 | db/util/postgresql 40 | db/util/datetime)) 41 | (when init? 42 | (ev '(begin 43 | ;; Must be kept in sync with beginning of using-db.scrbl 44 | (define pgc (dsn-connect 'db-scribble-env)) 45 | (query-exec pgc "create temporary table the_numbers (n integer, d varchar(20))") 46 | (query-exec pgc "insert into the_numbers values (0, 'nothing')") 47 | (query-exec pgc "insert into the_numbers values (1, 'the loneliest number')") 48 | (query-exec pgc "insert into the_numbers values (2, 'company')") 49 | (query-exec pgc "insert into the_numbers values (3, 'a crowd')")))) 50 | ev)) 51 | 52 | #| 53 | The fake eval is for eg connection examples 54 | |# 55 | 56 | (define fake-eval (make-base-eval)) 57 | (fake-eval '(begin (require racket/class) 58 | (define connection% (class object% (super-new))))) 59 | 60 | (define-syntax-rule (fake-examples [example result] ...) 61 | (examples #:eval fake-eval (eval:alts example result) ...)) 62 | -------------------------------------------------------------------------------- /db-doc/db/scribblings/db.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/doc 2 | @(require scribble/manual 3 | scribble/struct 4 | scribble/eval 5 | "config.rkt") 6 | 7 | @title{DB: Database Connectivity} 8 | @author[@author+email["Ryan Culpepper" "ryanc@racket-lang.org"]] 9 | 10 | @section-index["database"] 11 | 12 | @centered{@bold{@italic{A database interface for functional programmers.}}} 13 | 14 | @defmodule[db] 15 | 16 | This library provides a high-level interface to several database 17 | systems. The following database systems are currently supported: 18 | @itemlist[ 19 | 20 | @item{@bold{@as-index{@hyperlink["http://www.postgresql.org"]{PostgreSQL}} 21 | versions 7.4 and later.} This library implements the PostgreSQL wire 22 | protocol, so no native client library is required.} 23 | 24 | @item{@bold{@as-index{@hyperlink["http://www.mysql.com"]{MySQL}} versions 5 and 25 | later.} This library implements the MySQL wire protocol, so no 26 | native client library is required.} 27 | 28 | @item{@bold{@as-index{@hyperlink["http://www.sqlite.org"]{SQLite}} version 29 | 3.} The SQLite native client library is required; see 30 | @secref["sqlite3-requirements"].} 31 | 32 | @item{@bold{@as-index{@hyperlink["http://cassandra.apache.org"]{Cassandra}} 33 | versions 2.1.0 and later.} This library implements the Cassandra wire 34 | protocol (v3), so no native client is required.} 35 | 36 | @item{@bold{@as-index{ODBC}.} An ODBC Driver Manager and appropriate 37 | ODBC drivers are required; see @secref["odbc-requirements"]. The 38 | following database systems are known to work with this library via 39 | ODBC (see @secref["odbc-status"] for details): 40 | @bold{@as-index{@hyperlink["http://www.ibm.com/software/data/db2/"]{DB2}}}, 41 | @bold{@as-index{@hyperlink["http://www.oracle.com"]{Oracle}}}, and 42 | @bold{@as-index{@hyperlink["http://www.microsoft.com/sqlserver/"]{SQL Server}}}.} 43 | ] 44 | 45 | The query operations are functional in spirit: queries return results 46 | or raise exceptions rather than stashing their state into a cursor 47 | object for later navigation and retrieval. Query parameters and result 48 | fields are automatically translated to and from appropriate Racket 49 | values. Resources are managed automatically by the garbage collector 50 | and via custodians. Connections are internally synchronized, so 51 | multiple threads can use a connection simultaneously. 52 | 53 | @bold{Acknowledgments} Thanks to Dave Gurnell, Noel Welsh, Mike Burns, 54 | and Doug Orleans for contributions to @tt{spgsql}, the PostgreSQL-only 55 | predecessor of this library. The SQLite support is based in part on 56 | code from Jay McCarthy's @tt{sqlite} package. 57 | 58 | @include-section["using-db.scrbl"] 59 | @include-section["connect.scrbl"] 60 | @include-section["query.scrbl"] 61 | @include-section["sql-types.scrbl"] 62 | @include-section["util.scrbl"] 63 | @include-section["notes.scrbl"] 64 | 65 | @(close-eval fake-eval) 66 | -------------------------------------------------------------------------------- /db-doc/db/scribblings/log-for-connect.rktd: -------------------------------------------------------------------------------- 1 | ;; This file was created by make-log-based-eval 2 | ((require racket/class db db/util/postgresql db/util/datetime) 3 | ((3) 0 () 0 () () (c values c (void))) 4 | #"" 5 | #"") 6 | ((begin 7 | (define pgc (dsn-connect 'db-scribble-env)) 8 | (query-exec 9 | pgc 10 | "create temporary table the_numbers (n integer, d varchar(20))") 11 | (query-exec pgc "insert into the_numbers values (0, 'nothing')") 12 | (query-exec 13 | pgc 14 | "insert into the_numbers values (1, 'the loneliest number')") 15 | (query-exec pgc "insert into the_numbers values (2, 'company')") 16 | (query-exec pgc "insert into the_numbers values (3, 'a crowd')")) 17 | ((3) 0 () 0 () () (c values c (void))) 18 | #"" 19 | #"") 20 | ((define pool 21 | (connection-pool 22 | (lambda () 23 | (displayln "connecting!") 24 | (sqlite3-connect #:database 'memory)))) 25 | ((3) 0 () 0 () () (c values c (void))) 26 | #"" 27 | #"") 28 | ((define c1 (connection-pool-lease pool)) 29 | ((3) 0 () 0 () () (c values c (void))) 30 | #"connecting!\n" 31 | #"") 32 | ((define c2 (connection-pool-lease pool)) 33 | ((3) 0 () 0 () () (c values c (void))) 34 | #"connecting!\n" 35 | #"") 36 | ((disconnect c1) ((3) 0 () 0 () () (c values c (void))) #"" #"") 37 | ((define c3 (connection-pool-lease pool)) 38 | ((3) 0 () 0 () () (c values c (void))) 39 | #"" 40 | #"") 41 | ((define c 42 | (virtual-connection 43 | (lambda () (printf "connecting!\n") (dsn-connect 'db-scribble-env)))) 44 | ((3) 0 () 0 () () (c values c (void))) 45 | #"" 46 | #"") 47 | ((connected? c) ((3) 0 () 0 () () (q values #f)) #"" #"") 48 | ((query-value c "select 1") 49 | ((3) 0 () 0 () () (q values 1)) 50 | #"connecting!\n" 51 | #"") 52 | ((connected? c) ((3) 0 () 0 () () (q values #t)) #"" #"") 53 | ((void (thread (lambda () (displayln (query-value c "select 2"))))) 54 | ((3) 0 () 0 () () (c values c (void))) 55 | #"connecting!\n2\n" 56 | #"") 57 | ((disconnect c) ((3) 0 () 0 () () (c values c (void))) #"" #"") 58 | ((connected? c) ((3) 0 () 0 () () (q values #f)) #"" #"") 59 | ((query-value c "select 3") 60 | ((3) 0 () 0 () () (q values 3)) 61 | #"connecting!\n" 62 | #"") 63 | ((prepare c "select 2 + $1") 64 | ((3) 65 | 0 66 | () 67 | 0 68 | () 69 | () 70 | (q exn "prepare: cannot prepare statement with virtual connection")) 71 | #"" 72 | #"") 73 | ((query-value c "select 2 + $1" 2) ((3) 0 () 0 () () (q values 4)) #"" #"") 74 | ((define pst (virtual-statement "select 2 + $1")) 75 | ((3) 0 () 0 () () (c values c (void))) 76 | #"" 77 | #"") 78 | ((query-value c pst 3) ((3) 0 () 0 () () (q values 5)) #"" #"") 79 | ((begin (set! c #f) (set! pst #f)) 80 | ((3) 0 () 0 () () (c values c (void))) 81 | #"" 82 | #"") 83 | -------------------------------------------------------------------------------- /db-doc/db/scribblings/log-for-query.rktd: -------------------------------------------------------------------------------- 1 | ;; This file was created by make-log-based-eval 2 | ((require racket/class db db/util/postgresql db/util/datetime) 3 | ((3) 0 () 0 () () (c values c (void))) 4 | #"" 5 | #"") 6 | ((begin 7 | (define pgc (dsn-connect 'db-scribble-env)) 8 | (query-exec 9 | pgc 10 | "create temporary table the_numbers (n integer, d varchar(20))") 11 | (query-exec pgc "insert into the_numbers values (0, 'nothing')") 12 | (query-exec 13 | pgc 14 | "insert into the_numbers values (1, 'the loneliest number')") 15 | (query-exec pgc "insert into the_numbers values (2, 'company')") 16 | (query-exec pgc "insert into the_numbers values (3, 'a crowd')")) 17 | ((3) 0 () 0 () () (c values c (void))) 18 | #"" 19 | #"") 20 | ((define c pgc) ((3) 0 () 0 () () (c values c (void))) #"" #"") 21 | ((query-exec pgc "insert into the_numbers values (42, 'the answer')") 22 | ((3) 0 () 0 () () (c values c (void))) 23 | #"" 24 | #"") 25 | ((query-exec pgc "delete from the_numbers where n = $1" 42) 26 | ((3) 0 () 0 () () (c values c (void))) 27 | #"" 28 | #"") 29 | ((query-rows pgc "select * from the_numbers where n = $1" 2) 30 | ((3) 0 () 0 () () (c values c (c (v! 2 (u . "company"))))) 31 | #"" 32 | #"") 33 | ((query-rows c "select 17") 34 | ((3) 0 () 0 () () (c values c (c (v! 17)))) 35 | #"" 36 | #"") 37 | ((query-list c "select n from the_numbers where n < 2") 38 | ((3) 0 () 0 () () (q values (0 1))) 39 | #"" 40 | #"") 41 | ((query-list c "select 'hello'") 42 | ((3) 0 () 0 () () (c values c (c (u . "hello")))) 43 | #"" 44 | #"") 45 | ((query-row pgc "select * from the_numbers where n = $1" 2) 46 | ((3) 0 () 0 () () (c values c (v! 2 (u . "company")))) 47 | #"" 48 | #"") 49 | ((query-row pgc "select min(n), max(n) from the_numbers") 50 | ((3) 0 () 0 () () (c values c (v! 0 3))) 51 | #"" 52 | #"") 53 | ((query-maybe-row pgc "select * from the_numbers where n = $1" 100) 54 | ((3) 0 () 0 () () (q values #f)) 55 | #"" 56 | #"") 57 | ((query-maybe-row c "select 17") 58 | ((3) 0 () 0 () () (c values c (v! 17))) 59 | #"" 60 | #"") 61 | ((query-value pgc "select timestamp 'epoch'") 62 | ((3) 63 | 1 64 | (((lib "db/private/generic/sql-data.rkt") 65 | . 66 | deserialize-info:sql-timestamp-v0)) 67 | 0 68 | () 69 | () 70 | (c values c (0 1970 1 1 0 0 0 0 #f))) 71 | #"" 72 | #"") 73 | ((query-value pgc "select d from the_numbers where n = $1" 3) 74 | ((3) 0 () 0 () () (c values c (u . "a crowd"))) 75 | #"" 76 | #"") 77 | ((query-maybe-value pgc "select d from the_numbers where n = $1" 100) 78 | ((3) 0 () 0 () () (q values #f)) 79 | #"" 80 | #"") 81 | ((query-maybe-value c "select count(*) from the_numbers") 82 | ((3) 0 () 0 () () (q values 4)) 83 | #"" 84 | #"") 85 | ((for/list ((n (in-query pgc "select n from the_numbers where n < 2"))) n) 86 | ((3) 0 () 0 () () (q values (0 1))) 87 | #"" 88 | #"") 89 | ((call-with-transaction 90 | pgc 91 | (lambda () 92 | (for 93 | (((n d) 94 | (in-query pgc "select * from the_numbers where n < $1" 4 #:fetch 1))) 95 | (printf "~a: ~a\n" n d)))) 96 | ((3) 0 () 0 () () (c values c (void))) 97 | #"0: nothing\n1: the loneliest number\n2: company\n3: a crowd\n" 98 | #"") 99 | ((for ((n (in-query pgc "select * from the_numbers"))) (displayln n)) 100 | ((3) 101 | 0 102 | () 103 | 0 104 | () 105 | () 106 | (q 107 | exn 108 | "in-query: query returned wrong number of columns\n statement: \"select * from the_numbers\"\n expected: 1\n got: 2")) 109 | #"" 110 | #"") 111 | ((define vehicles-result 112 | (rows-result 113 | '(((name . "type")) ((name . "maker")) ((name . "model"))) 114 | `(#("car" "honda" "civic") 115 | #("car" "ford" "focus") 116 | #("car" "ford" "pinto") 117 | #("bike" "giant" "boulder") 118 | #("bike" "schwinn" ,sql-null)))) 119 | ((3) 0 () 0 () () (c values c (void))) 120 | #"" 121 | #"") 122 | ((group-rows vehicles-result #:group '(#("type"))) 123 | ((3) 124 | 2 125 | (((lib "db/private/generic/interfaces.rkt") 126 | . 127 | deserialize-info:rows-result-v0) 128 | ((lib "db/private/generic/sql-data.rkt") . deserialize-info:sql-null-v0)) 129 | 1 130 | ("ford") 131 | () 132 | (c 133 | values 134 | c 135 | (0 136 | (q 137 | ((name . "type")) 138 | ((name . "grouped") (grouped ((name . "maker")) ((name . "model"))))) 139 | (c 140 | (v! 141 | "car" 142 | (c (v! "honda" "civic") c (v! (? . 0) "focus") c (v! (? . 0) "pinto"))) 143 | c 144 | (v! "bike" (c (v! "giant" "boulder") c (v! "schwinn" (1)))))))) 145 | #"" 146 | #"") 147 | ((group-rows 148 | vehicles-result 149 | #:group 150 | '(#("type") #("maker")) 151 | #:group-mode 152 | '(list)) 153 | ((3) 154 | 1 155 | (((lib "db/private/generic/interfaces.rkt") 156 | . 157 | deserialize-info:rows-result-v0)) 158 | 1 159 | ((q name . "grouped")) 160 | () 161 | (c 162 | values 163 | c 164 | (0 165 | (c 166 | (q (name . "type")) 167 | c 168 | (c 169 | (? . 0) 170 | c 171 | (c 172 | grouped 173 | c 174 | (q (name . "maker")) 175 | c 176 | (c (? . 0) q (grouped ((name . "model"))))))) 177 | (c 178 | (v! "car" (c (v! "honda" (q "civic")) c (v! "ford" (q "focus" "pinto")))) 179 | c 180 | (v! "bike" (c (v! "giant" (q "boulder")) c (v! "schwinn" ()))))))) 181 | #"" 182 | #"") 183 | ((rows->dict vehicles-result #:key "model" #:value '#("type" "maker")) 184 | ((3) 185 | 1 186 | (((lib "db/private/generic/sql-data.rkt") . deserialize-info:sql-null-v0)) 187 | 3 188 | ("bike" "car" "ford") 189 | () 190 | (c 191 | values 192 | c 193 | (h 194 | - 195 | (equal) 196 | ((0) v! (? . 0) "schwinn") 197 | ("boulder" v! (? . 0) "giant") 198 | ("pinto" v! (? . 1) (? . 2)) 199 | ("focus" v! (? . 1) (? . 2)) 200 | ("civic" v! (? . 1) "honda")))) 201 | #"" 202 | #"") 203 | ((rows->dict 204 | vehicles-result 205 | #:key 206 | "maker" 207 | #:value 208 | "model" 209 | #:value-mode 210 | '(list)) 211 | ((3) 212 | 0 213 | () 214 | 0 215 | () 216 | () 217 | (c 218 | values 219 | c 220 | (h 221 | - 222 | (equal) 223 | ("ford" q "focus" "pinto") 224 | ("giant" q "boulder") 225 | ("honda" q "civic") 226 | ("schwinn")))) 227 | #"" 228 | #"") 229 | ((let* ((get-name-pst (prepare pgc "select d from the_numbers where n = $1")) 230 | (get-name2 (bind-prepared-statement get-name-pst (list 2))) 231 | (get-name3 (bind-prepared-statement get-name-pst (list 3)))) 232 | (list (query-value pgc get-name2) (query-value pgc get-name3))) 233 | ((3) 0 () 0 () () (c values c (c (u . "company") c (u . "a crowd")))) 234 | #"" 235 | #"") 236 | ((define pst 237 | (virtual-statement 238 | (lambda (dbsys) 239 | (case (dbsystem-name dbsys) 240 | ((postgresql) "select n from the_numbers where n < $1") 241 | ((sqlite3) "select n from the_numbers where n < ?") 242 | (else (error "unknown system")))))) 243 | ((3) 0 () 0 () () (c values c (void))) 244 | #"" 245 | #"") 246 | ((query-list pgc pst 3) ((3) 0 () 0 () () (q values (0 1 2))) #"" #"") 247 | ((query-list pgc pst 3) ((3) 0 () 0 () () (q values (0 1 2))) #"" #"") 248 | ((with-handlers 249 | ((exn:fail:sql? exn:fail:sql-info)) 250 | (query pgc "select * from nosuchtable")) 251 | ((3) 252 | 0 253 | () 254 | 0 255 | () 256 | () 257 | (c 258 | values 259 | c 260 | (c 261 | (c severity u . "ERROR") 262 | c 263 | (c severity* u . "ERROR") 264 | c 265 | (c code u . "42P01") 266 | c 267 | (c message u . "relation \"nosuchtable\" does not exist") 268 | c 269 | (c position u . "15") 270 | c 271 | (c file u . "parse_relation.c") 272 | c 273 | (c line u . "1194") 274 | c 275 | (c routine u . "parserOpenTable")))) 276 | #"" 277 | #"") 278 | -------------------------------------------------------------------------------- /db-doc/db/scribblings/log-for-sql-types.rktd: -------------------------------------------------------------------------------- 1 | ;; This file was created by make-log-based-eval 2 | ((require racket/class db db/util/postgresql db/util/datetime) 3 | ((3) 0 () 0 () () (c values c (void))) 4 | #"" 5 | #"") 6 | ((begin 7 | (define pgc (dsn-connect 'db-scribble-env)) 8 | (query-exec 9 | pgc 10 | "create temporary table the_numbers (n integer, d varchar(20))") 11 | (query-exec pgc "insert into the_numbers values (0, 'nothing')") 12 | (query-exec 13 | pgc 14 | "insert into the_numbers values (1, 'the loneliest number')") 15 | (query-exec pgc "insert into the_numbers values (2, 'company')") 16 | (query-exec pgc "insert into the_numbers values (3, 'a crowd')")) 17 | ((3) 0 () 0 () () (c values c (void))) 18 | #"" 19 | #"") 20 | ((query-value pgc "select count(*) from the_numbers") 21 | ((3) 0 () 0 () () (q values 4)) 22 | #"" 23 | #"") 24 | ((query-value pgc "select false") ((3) 0 () 0 () () (q values #f)) #"" #"") 25 | ((query-value pgc "select 1 + $1" 2) ((3) 0 () 0 () () (q values 3)) #"" #"") 26 | ((query-value pgc "select inet '127.0.0.1'") 27 | ((3) 28 | 0 29 | () 30 | 0 31 | () 32 | () 33 | (q exn "query-value: unsupported type\n type: inet\n typeid: 869")) 34 | #"" 35 | #"") 36 | ((query-value pgc "select cast(inet '127.0.0.1' as varchar)") 37 | ((3) 0 () 0 () () (c values c (u . "127.0.0.1/32"))) 38 | #"" 39 | #"") 40 | ((query-value pgc "select real '+Infinity'") 41 | ((3) 0 () 0 () () (q values +inf.0)) 42 | #"" 43 | #"") 44 | ((query-value pgc "select numeric '12345678901234567890'") 45 | ((3) 0 () 0 () () (q values 12345678901234567890)) 46 | #"" 47 | #"") 48 | ((query-value pgc "select 1 in (1, 2, 3)") 49 | ((3) 0 () 0 () () (q values #t)) 50 | #"" 51 | #"") 52 | ((query-value 53 | pgc 54 | "select 1 = any ($1::integer[])" 55 | (list->pg-array (list 1 2 3))) 56 | ((3) 0 () 0 () () (q values #t)) 57 | #"" 58 | #"") 59 | ((query-value pgc "select 1 = any ($1)" (list 1 2 3)) 60 | ((3) 0 () 0 () () (q values #t)) 61 | #"" 62 | #"") 63 | ((query-value pgc "select $1::integer = any ($2)" 1 (list 1 2 3)) 64 | ((3) 0 () 0 () () (q values #t)) 65 | #"" 66 | #"") 67 | ((query-value pgc "select $1 = any ($2)" 1 (list 1 2 3)) 68 | ((3) 69 | 0 70 | () 71 | 0 72 | () 73 | () 74 | (q 75 | exn 76 | "query-value: cannot convert given value to SQL type\n given: 1\n type: string\n expected: string?\n dialect: PostgreSQL")) 77 | #"" 78 | #"") 79 | ((query-value pgc "select NULL") 80 | ((3) 81 | 1 82 | (((lib "db/private/generic/sql-data.rkt") . deserialize-info:sql-null-v0)) 83 | 0 84 | () 85 | () 86 | (c values c (0))) 87 | #"" 88 | #"") 89 | ((sql-null->false "apple") ((3) 0 () 0 () () (q values "apple")) #"" #"") 90 | ((sql-null->false sql-null) ((3) 0 () 0 () () (q values #f)) #"" #"") 91 | ((sql-null->false #f) ((3) 0 () 0 () () (q values #f)) #"" #"") 92 | ((false->sql-null "apple") ((3) 0 () 0 () () (q values "apple")) #"" #"") 93 | ((false->sql-null #f) 94 | ((3) 95 | 1 96 | (((lib "db/private/generic/sql-data.rkt") . deserialize-info:sql-null-v0)) 97 | 0 98 | () 99 | () 100 | (c values c (0))) 101 | #"" 102 | #"") 103 | ((query-value pgc "select date '25-dec-1980'") 104 | ((3) 105 | 1 106 | (((lib "db/private/generic/sql-data.rkt") . deserialize-info:sql-date-v0)) 107 | 0 108 | () 109 | () 110 | (c values c (0 1980 12 25))) 111 | #"" 112 | #"") 113 | ((query-value pgc "select time '7:30'") 114 | ((3) 115 | 1 116 | (((lib "db/private/generic/sql-data.rkt") . deserialize-info:sql-time-v0)) 117 | 0 118 | () 119 | () 120 | (c values c (0 7 30 0 0 #f))) 121 | #"" 122 | #"") 123 | ((query-value pgc "select timestamp 'epoch'") 124 | ((3) 125 | 1 126 | (((lib "db/private/generic/sql-data.rkt") 127 | . 128 | deserialize-info:sql-timestamp-v0)) 129 | 0 130 | () 131 | () 132 | (c values c (0 1970 1 1 0 0 0 0 #f))) 133 | #"" 134 | #"") 135 | ((query-value pgc "select timestamp with time zone 'epoch'") 136 | ((3) 137 | 1 138 | (((lib "db/private/generic/sql-data.rkt") 139 | . 140 | deserialize-info:sql-timestamp-v0)) 141 | 0 142 | () 143 | () 144 | (c values c (0 1970 1 1 0 0 0 0 0))) 145 | #"" 146 | #"") 147 | -------------------------------------------------------------------------------- /db-doc/db/scribblings/log-for-using-db.rktd: -------------------------------------------------------------------------------- 1 | ;; This file was created by make-log-based-eval 2 | ((require racket/class db db/util/postgresql db/util/datetime) 3 | ((3) 0 () 0 () () (c values c (void))) 4 | #"" 5 | #"") 6 | ((require db) ((3) 0 () 0 () () (c values c (void))) #"" #"") 7 | ((define pgc (dsn-connect 'db-scribble-env)) 8 | ((3) 0 () 0 () () (c values c (void))) 9 | #"" 10 | #"") 11 | ((query-exec 12 | pgc 13 | "create temporary table the_numbers (n integer, d varchar(20))") 14 | ((3) 0 () 0 () () (c values c (void))) 15 | #"" 16 | #"") 17 | ((query-exec pgc "insert into the_numbers values (0, 'nothing')") 18 | ((3) 0 () 0 () () (c values c (void))) 19 | #"" 20 | #"") 21 | ((query-exec pgc "insert into the_numbers values (1, 'the loneliest number')") 22 | ((3) 0 () 0 () () (c values c (void))) 23 | #"" 24 | #"") 25 | ((query-exec pgc "insert into the_numbers values ($1, $2)" (+ 1 1) "company") 26 | ((3) 0 () 0 () () (c values c (void))) 27 | #"" 28 | #"") 29 | ((query pgc "insert into the_numbers values (3, 'a crowd')") 30 | ((3) 31 | 1 32 | (((lib "db/private/generic/interfaces.rkt") 33 | . 34 | deserialize-info:simple-result-v0)) 35 | 0 36 | () 37 | () 38 | (c values c (0 (q (insert-id . #f) (affected-rows . 1))))) 39 | #"" 40 | #"") 41 | ((query pgc "select n, d from the_numbers where n % 2 = 0") 42 | ((3) 43 | 1 44 | (((lib "db/private/generic/interfaces.rkt") 45 | . 46 | deserialize-info:rows-result-v0)) 47 | 0 48 | () 49 | () 50 | (c 51 | values 52 | c 53 | (0 54 | (c 55 | (c (c name u . "n") q (typeid . 23) (type-size . 4) (type-mod . -1)) 56 | c 57 | (c (c name u . "d") q (typeid . 1043) (type-size . -1) (type-mod . 24))) 58 | (c (v! 0 (u . "nothing")) c (v! 2 (u . "company")))))) 59 | #"" 60 | #"") 61 | ((query-rows pgc "select n, d from the_numbers where n % 2 = 0") 62 | ((3) 63 | 0 64 | () 65 | 0 66 | () 67 | () 68 | (c values c (c (v! 0 (u . "nothing")) c (v! 2 (u . "company"))))) 69 | #"" 70 | #"") 71 | ((query-row pgc "select * from the_numbers where n = 0") 72 | ((3) 0 () 0 () () (c values c (v! 0 (u . "nothing")))) 73 | #"" 74 | #"") 75 | ((query-list pgc "select d from the_numbers order by n") 76 | ((3) 77 | 0 78 | () 79 | 0 80 | () 81 | () 82 | (c 83 | values 84 | c 85 | (c 86 | (u . "nothing") 87 | c 88 | (u . "the loneliest number") 89 | c 90 | (u . "company") 91 | c 92 | (u . "a crowd")))) 93 | #"" 94 | #"") 95 | ((query-value pgc "select count(*) from the_numbers") 96 | ((3) 0 () 0 () () (q values 4)) 97 | #"" 98 | #"") 99 | ((query-value pgc "select d from the_numbers where n = 5") 100 | ((3) 101 | 0 102 | () 103 | 0 104 | () 105 | () 106 | (q 107 | exn 108 | "query-value: query returned wrong number of rows\n statement: \"select d from the_numbers where n = 5\"\n expected: 1\n got: 0")) 109 | #"" 110 | #"") 111 | ((query-maybe-value pgc "select d from the_numbers where n = 5") 112 | ((3) 0 () 0 () () (q values #f)) 113 | #"" 114 | #"") 115 | ((for 116 | (((n d) (in-query pgc "select * from the_numbers where n < 4"))) 117 | (printf "~a: ~a\n" n d)) 118 | ((3) 0 () 0 () () (c values c (void))) 119 | #"0: nothing\n1: the loneliest number\n2: company\n3: a crowd\n" 120 | #"") 121 | ((for/fold 122 | ((sum 0)) 123 | ((n (in-query pgc "select n from the_numbers"))) 124 | (+ sum n)) 125 | ((3) 0 () 0 () () (q values 6)) 126 | #"" 127 | #"") 128 | ((begin 129 | (with-handlers 130 | ((exn:fail? (lambda (e) (printf "~a~n" (exn-message e))))) 131 | (query-value pgc "select NoSuchField from NoSuchTable")) 132 | (query-value pgc "select 'okay to proceed!'")) 133 | ((3) 0 () 0 () () (c values c (u . "okay to proceed!"))) 134 | #"query-value: relation \"nosuchtable\" does not exist\n SQLSTATE: 42P01\n" 135 | #"") 136 | ((query-value pgc "select d from the_numbers where n = $1" 2) 137 | ((3) 0 () 0 () () (c values c (u . "company"))) 138 | #"" 139 | #"") 140 | ((query-list pgc "select n from the_numbers where n > $1 and n < $2" 0 3) 141 | ((3) 0 () 0 () () (q values (1 2))) 142 | #"" 143 | #"") 144 | ((define get-less-than-pst 145 | (prepare pgc "select n from the_numbers where n < $1")) 146 | ((3) 0 () 0 () () (c values c (void))) 147 | #"" 148 | #"") 149 | ((query-list pgc get-less-than-pst 1) 150 | ((3) 0 () 0 () () (q values (0))) 151 | #"" 152 | #"") 153 | ((query-list pgc (bind-prepared-statement get-less-than-pst '(2))) 154 | ((3) 0 () 0 () () (q values (0 1))) 155 | #"" 156 | #"") 157 | ((void) ((3) 0 () 0 () () (c values c (void))) #"" #"") 158 | -------------------------------------------------------------------------------- /db-doc/db/scribblings/log-for-util.rktd: -------------------------------------------------------------------------------- 1 | ;; This file was created by make-log-based-eval 2 | ((require racket/class db db/util/postgresql db/util/datetime) 3 | ((3) 0 () 0 () () (c values c (void))) 4 | #"" 5 | #"") 6 | ((begin 7 | (define pgc (dsn-connect 'db-scribble-env)) 8 | (query-exec 9 | pgc 10 | "create temporary table the_numbers (n integer, d varchar(20))") 11 | (query-exec pgc "insert into the_numbers values (0, 'nothing')") 12 | (query-exec 13 | pgc 14 | "insert into the_numbers values (1, 'the loneliest number')") 15 | (query-exec pgc "insert into the_numbers values (2, 'company')") 16 | (query-exec pgc "insert into the_numbers values (3, 'a crowd')")) 17 | ((3) 0 () 0 () () (c values c (void))) 18 | #"" 19 | #"") 20 | ((sql-datetime->srfi-date (query-value pgc "select time '7:30'")) 21 | ((3) 0 () 0 () () (c values c (date* 0 30 7 1 1 0 0 0 #f 0 0 ""))) 22 | #"" 23 | #"") 24 | ((sql-datetime->srfi-date (query-value pgc "select date '25-dec-1980'")) 25 | ((3) 0 () 0 () () (c values c (date* 0 0 0 25 12 1980 4 359 #f 0 0 ""))) 26 | #"" 27 | #"") 28 | ((sql-datetime->srfi-date (query-value pgc "select timestamp 'epoch'")) 29 | ((3) 0 () 0 () () (c values c (date* 0 0 0 1 1 1970 4 0 #f 0 0 ""))) 30 | #"" 31 | #"") 32 | ((define-values 33 | (cidr-typeid cidr-array-typeid) 34 | (vector->values 35 | (query-row 36 | pgc 37 | "select oid, typarray from pg_type where typname = $1" 38 | "cidr"))) 39 | ((3) 0 () 0 () () (c values c (void))) 40 | #"" 41 | #"") 42 | (cidr-typeid ((3) 0 () 0 () () (q values 650)) #"" #"") 43 | ((send pgc add-custom-types 44 | (list 45 | (pg-custom-type 46 | cidr-typeid 47 | 'cidr 48 | #:recv 49 | bytes->list 50 | #:send 51 | list->bytes 52 | #:array 53 | cidr-array-typeid))) 54 | ((3) 0 () 0 () () (c values c (void))) 55 | #"" 56 | #"") 57 | ((query-value pgc "select cidr '127.0.0.0/24'") 58 | ((3) 0 () 0 () () (q values (2 24 1 4 127 0 0 0))) 59 | #"" 60 | #"") 61 | ((query-value pgc "select cast('{127.0.0.0/24, 10.0.0.0/8}' as cidr[])") 62 | ((3) 63 | 1 64 | (((lib "db/private/postgresql/util.rkt") . deserialize-info:pg-array-v0)) 65 | 0 66 | () 67 | () 68 | (c 69 | values 70 | c 71 | (0 1 (q 2) (q 1) (v! (q 2 24 1 4 127 0 0 0) (q 2 8 1 4 10 0 0 0))))) 72 | #"" 73 | #"") 74 | -------------------------------------------------------------------------------- /db-doc/db/scribblings/tabbing.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require scribble/struct 3 | scribble/base) 4 | (provide & // tabbing) 5 | 6 | (define-struct tabbing-marker (kind) #:transparent) 7 | 8 | (define & (make-tabbing-marker '&)) 9 | (define // (make-tabbing-marker '//)) 10 | 11 | (define (tabbing #:spacing [spacing 4] . pres) 12 | (define (loop pres cell row rows sep) 13 | (cond [(null? pres) 14 | (let* ([row (cons (reverse cell) row)] 15 | [rows (cons (reverse row) rows)]) 16 | (reverse rows))] 17 | [(eq? (car pres) &) 18 | (loop (cdr pres) null (list* sep (reverse cell) row) rows sep)] 19 | [(eq? (car pres) //) 20 | (let* ([row (cons (reverse cell) row)]) 21 | (loop (cdr pres) null null (cons (reverse row) rows) null))] 22 | [else 23 | (loop (cdr pres) (cons (car pres) cell) row rows sep)])) 24 | (define rows (loop pres null null null (list (hspace spacing)))) 25 | (make-table #f (map layout-row rows))) 26 | 27 | (define (layout-row row) 28 | (map layout-cell row)) 29 | 30 | (define (layout-cell cell) 31 | (make-flow (list (make-paragraph cell)))) 32 | -------------------------------------------------------------------------------- /db-doc/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection 'multi) 4 | 5 | (define deps '("base")) 6 | 7 | (define build-deps '("srfi-lite-lib" 8 | "web-server-doc" 9 | "base" 10 | "scribble-lib" 11 | "sandbox-lib" 12 | "web-server-lib" 13 | "db-lib" 14 | "data-doc" 15 | "racket-doc")) 16 | (define update-implies '("db-lib")) 17 | 18 | (define pkg-desc "documentation part of \"db\"") 19 | 20 | (define pkg-authors '(ryanc)) 21 | 22 | (define license 23 | '(Apache-2.0 OR MIT)) 24 | -------------------------------------------------------------------------------- /db-lib/db/TODO: -------------------------------------------------------------------------------- 1 | 2 | - place proxy: interrupt work & disconnect on client-side custodian shutdown (?) 3 | 4 | - postgresql: send no-arg queries without prepare step (?) 5 | 6 | - add under-the-hood doc section (eg, debugging, adjusting statement cache) 7 | 8 | - type annotations 9 | - two modes: mandatory and opportunistic 10 | - on result fields (eg sqlite, convert to date) 11 | - on parameters ??? 12 | - per query or per connection? (or both?) 13 | - either only well-known conversions, or must apply outside of lock 14 | 15 | - postgresql record type: docs, send 16 | - postgresql domain types, table record types, etc 17 | 18 | - for wrapped/managed connections, detect if underlying connection gets 19 | disconnected by server (eg, times out after 10 minutes of inactivity) 20 | - at least, pool should make sure connection is alive when gotten from idle list 21 | - add {keepalive : -> boolean} method to connection<%> (?) 22 | 23 | - disconnect on custudian shutdown (?) 24 | 25 | - disconnect should always work, even on thread-damaged connections 26 | - but might need version with timeout and/or rudely? flag, because 27 | I can't think of a way to solve the lock problem that doesn't involve aux thread. 28 | 29 | - add recursive locking? 30 | - cons: - considered by experts to be bad design, sloppy 31 | - pros: - would simplify cleanup for one-shot pstmts 32 | - would enable simple impl of user-level 'call-with-lock' for grouping 33 | multiple operations together 34 | (but this could also be done by two locks: outer "ownership" lock 35 | and inner "invariant-protecting" lock) 36 | 37 | - make implementation notes section of docs 38 | - explain nested tx impl 39 | 40 | - invalidate statement cache on query error 41 | 42 | - 2 call-with-transactions from separate threads can conflict 43 | -------------------------------------------------------------------------------- /db-lib/db/base.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require (for-syntax racket/base 3 | syntax/parse 4 | syntax/parse/experimental/template) 5 | racket/dict 6 | syntax/location 7 | racket/contract/base) 8 | 9 | ;; ============================================================ 10 | 11 | (require db/private/generic/interfaces 12 | db/private/generic/sql-data) 13 | 14 | (provide (struct-out simple-result) 15 | (struct-out rows-result) 16 | statement-binding? 17 | (struct-out exn:fail:sql)) 18 | 19 | (provide sql-null 20 | sql-null? 21 | sql-null->false 22 | false->sql-null) 23 | 24 | (provide/contract 25 | [struct sql-date ([year exact-integer?] 26 | [month (integer-in 0 12)] 27 | [day (integer-in 0 31)])] 28 | [struct sql-time ([hour (integer-in 0 23)] 29 | [minute (integer-in 0 59)] 30 | [second (integer-in 0 61)] ;; leap seconds 31 | [nanosecond (integer-in 0 (sub1 #e1e9))] 32 | [tz (or/c #f exact-integer?)])] 33 | [struct sql-timestamp ([year exact-integer?] 34 | [month (integer-in 0 12)] 35 | [day (integer-in 0 31)] 36 | [hour (integer-in 0 23)] 37 | [minute (integer-in 0 59)] 38 | [second (integer-in 0 61)] 39 | [nanosecond (integer-in 0 (sub1 #e1e9))] 40 | [tz (or/c #f exact-integer?)])] 41 | [struct sql-interval ([years exact-integer?] 42 | [months exact-integer?] 43 | [days exact-integer?] 44 | [hours exact-integer?] 45 | [minutes exact-integer?] 46 | [seconds exact-integer?] 47 | [nanoseconds exact-integer?])] 48 | 49 | [sql-day-time-interval? 50 | (-> any/c boolean?)] 51 | [sql-year-month-interval? 52 | (-> any/c boolean?)] 53 | [sql-interval->sql-time 54 | (->* (sql-interval?) (any/c) 55 | any)] 56 | [sql-time->sql-interval 57 | (-> sql-time? sql-day-time-interval?)] 58 | 59 | [make-sql-bits 60 | (-> exact-nonnegative-integer? sql-bits?)] 61 | [sql-bits? 62 | (-> any/c boolean?)] 63 | [sql-bits-length 64 | (-> sql-bits? exact-nonnegative-integer?)] 65 | [sql-bits-ref 66 | (-> sql-bits? exact-nonnegative-integer? boolean?)] 67 | [sql-bits-set! 68 | (-> sql-bits? exact-nonnegative-integer? boolean? void?)] 69 | [sql-bits->list 70 | (-> sql-bits? (listof boolean?))] 71 | [list->sql-bits 72 | (-> (listof boolean?) sql-bits?)] 73 | [sql-bits->string 74 | (-> sql-bits? string?)] 75 | [string->sql-bits 76 | (-> string? sql-bits?)]) 77 | 78 | ;; ============================================================ 79 | 80 | (require db/private/generic/functions2) 81 | 82 | (define fetch-size/c 83 | (or/c exact-positive-integer? +inf.0)) 84 | 85 | (define grouping-field/c (or/c string? exact-nonnegative-integer?)) 86 | (define group/c (or/c grouping-field/c (vectorof grouping-field/c))) 87 | (define grouping/c (or/c group/c (listof group/c))) 88 | 89 | (define group-mode/c 90 | (listof (or/c 'list 'preserve-null))) 91 | 92 | (define-module-boundary-contract contracted-in-query 93 | in-query 94 | (->* (connection? statement?) 95 | (#:fetch 96 | fetch-size/c 97 | #:group grouping/c 98 | #:group-mode group-mode/c) 99 | #:rest list? 100 | sequence?)) 101 | 102 | (define-sequence-syntax in-query* 103 | (lambda () #'contracted-in-query) 104 | (lambda (stx) 105 | (syntax-parse stx 106 | [[(var ...) (~and form 107 | (in-query (~or (~optional (~seq #:fetch fetch-size)) 108 | (~optional (~seq #:group grouping-fields)) 109 | (~optional (~seq #:group-mode group-mode)) 110 | (~between arg:expr 2 +inf.0)) 111 | ...))] 112 | #:declare fetch-size (expr/c #'fetch-size/c #:context #'form) #:role "fetch size argument" 113 | #:declare grouping-fields (expr/c #'grouping/c #:context #'form) #:role "grouping fields argument" 114 | #:declare group-mode (expr/c #'group-mode/c #:context #'form) #:role "group mode argument" 115 | #:with (c stmt q-arg ...) #'(arg ...) 116 | #:declare c (expr/c #'connection? #:context #'form) #:role "connection argument" 117 | #:declare stmt (expr/c #'statement? #:context #'form) #:role "statement argument" 118 | (template 119 | [(var ...) (in-query-helper (length '(var ...)) c.c stmt.c q-arg ... 120 | (?? (?@ #:fetch fetch-size.c)) 121 | (?? (?@ #:group grouping-fields.c)) 122 | (?? (?@ #:group-mode group-mode.c)))])] 123 | [_ #f]))) 124 | 125 | (provide (rename-out [in-query* in-query])) 126 | 127 | (provide/contract 128 | [connection? 129 | (-> any/c any)] 130 | [disconnect 131 | (-> connection? any)] 132 | [connected? 133 | (-> connection? any)] 134 | [connection-dbsystem 135 | (-> connection? dbsystem?)] 136 | [dbsystem? 137 | (-> any/c any)] 138 | [dbsystem-name 139 | (-> dbsystem? symbol?)] 140 | [dbsystem-supported-types 141 | (-> dbsystem? (listof symbol?))] 142 | 143 | [statement? 144 | (-> any/c any)] 145 | [prepared-statement? 146 | (-> any/c any)] 147 | [prepared-statement-parameter-types 148 | (-> prepared-statement? (or/c list? #f))] 149 | [prepared-statement-result-types 150 | (-> prepared-statement? (or/c list? #f))] 151 | 152 | [query-exec 153 | (->* (connection? statement?) () #:rest list? any)] 154 | [query-rows 155 | (->* (connection? statement?) 156 | (#:group grouping/c 157 | #:group-mode group-mode/c) 158 | #:rest list? (listof vector?))] 159 | [query-list 160 | (->* (connection? statement?) () #:rest list? list?)] 161 | [query-row 162 | (->* (connection? statement?) () #:rest list? vector?)] 163 | [query-maybe-row 164 | (->* (connection? statement?) () #:rest list? (or/c #f vector?))] 165 | [query-value 166 | (->* (connection? statement?) () #:rest list? any)] 167 | [query-maybe-value 168 | (->* (connection? statement?) () #:rest list? any)] 169 | [query 170 | (->* (connection? statement?) () #:rest list? any)] 171 | 172 | [prepare 173 | (-> connection? (or/c string? virtual-statement?) any)] 174 | [bind-prepared-statement 175 | (-> prepared-statement? list? any)] 176 | 177 | [virtual-statement 178 | (-> (or/c string? (-> dbsystem? string?)) 179 | virtual-statement?)] 180 | [virtual-statement? 181 | (-> any/c boolean?)] 182 | 183 | [start-transaction 184 | (->* (connection?) 185 | (#:isolation (or/c 'serializable 'repeatable-read 'read-committed 'read-uncommitted #f) 186 | #:option any/c) 187 | void?)] 188 | [commit-transaction 189 | (-> connection? void?)] 190 | [rollback-transaction 191 | (-> connection? void?)] 192 | [in-transaction? 193 | (-> connection? boolean?)] 194 | [needs-rollback? 195 | (-> connection? boolean?)] 196 | [call-with-transaction 197 | (->* (connection? (-> any)) 198 | (#:isolation (or/c 'serializable 'repeatable-read 'read-committed 'read-uncommitted #f) 199 | #:option any/c) 200 | any)] 201 | 202 | [prop:statement 203 | (struct-type-property/c 204 | (-> any/c connection? 205 | statement?))] 206 | 207 | [list-tables 208 | (->* (connection?) 209 | (#:schema (or/c 'search-or-current 'search 'current)) 210 | (listof string?))] 211 | [table-exists? 212 | (->* (connection? string?) 213 | (#:schema (or/c 'search-or-current 'search 'current) 214 | #:case-sensitive? any/c) 215 | boolean?)] 216 | 217 | [group-rows 218 | (->* (rows-result? 219 | #:group grouping/c) 220 | (#:group-mode (listof (or/c 'list 'preserve-null #|deprecated:|# 'preserve-null-rows))) 221 | rows-result?)] 222 | 223 | [rows->dict 224 | (->* (rows-result? #:key grouping/c #:value grouping/c) 225 | (#:value-mode group-mode/c) 226 | dict?)] 227 | ) 228 | (provide prop:statement?) 229 | 230 | ;; ============================================================ 231 | 232 | (require "private/generic/connect-util.rkt") 233 | 234 | (provide/contract 235 | [kill-safe-connection 236 | (-> connection? connection?)] 237 | [virtual-connection 238 | (->* ((or/c (-> connection?) connection-pool?)) 239 | () 240 | connection?)] 241 | [connection-pool 242 | (->* ((-> connection?)) 243 | (#:max-connections (or/c (integer-in 1 10000) +inf.0) 244 | #:max-idle-connections (or/c (integer-in 1 10000) +inf.0)) 245 | connection-pool?)] 246 | [connection-pool? 247 | (-> any/c boolean?)] 248 | [connection-pool-lease 249 | (->* (connection-pool?) 250 | ((or/c custodian? evt?)) 251 | connection?)]) 252 | 253 | ;; ============================================================ 254 | 255 | (require "private/generic/dsn.rkt") 256 | 257 | (provide dsn-connect) ;; can't express "or any kw at all" w/ ->* contract 258 | (provide/contract 259 | [struct data-source 260 | ([connector connector?] 261 | [args arglist?] 262 | [extensions (listof (list/c symbol? writable-datum?))])] 263 | [current-dsn-file (parameter/c path-string?)] 264 | [get-dsn 265 | (->* (symbol?) (any/c #:dsn-file path-string?) any)] 266 | [put-dsn 267 | (->* (symbol? (or/c data-source? #f)) (#:dsn-file path-string?) void?)] 268 | [postgresql-data-source 269 | (->* () 270 | (#:user string? 271 | #:database string? 272 | #:server string? 273 | #:port exact-positive-integer? 274 | #:socket (or/c string? 'guess) 275 | #:password (or/c string? #f) 276 | #:allow-cleartext-password? boolean? 277 | #:ssl (or/c 'yes 'optional 'no) 278 | #:notice-handler (or/c 'output 'error) 279 | #:notification-handler (or/c 'output 'error) 280 | #:debug? any/c) 281 | data-source?)] 282 | [mysql-data-source 283 | (->* () 284 | (#:user string? 285 | #:database (or/c string? #f) 286 | #:server string? 287 | #:port exact-positive-integer? 288 | #:socket (or/c string? 'guess) 289 | #:password (or/c string? #f) 290 | #:notice-handler (or/c 'output 'error) 291 | #:debug? any/c) 292 | data-source?)] 293 | [cassandra-data-source 294 | (->* [] 295 | [#:server string? 296 | #:port exact-positive-integer? 297 | #:user string? 298 | #:password (or/c string? #f) 299 | #:ssl (or/c 'yes 'no) 300 | #:ssl-context (or/c 'auto 'secure) 301 | #:debug? any/c] 302 | data-source?)] 303 | [sqlite3-data-source 304 | (->* () 305 | (#:database (or/c string? 'memory 'temporary) 306 | #:mode (or/c 'read-only 'read/write 'create) 307 | #:busy-retry-limit (or/c exact-nonnegative-integer? +inf.0) 308 | #:busy-retry-delay (and/c rational? (not/c negative?)) 309 | #:use-place boolean?) 310 | data-source?)] 311 | [odbc-data-source 312 | (->* () 313 | (#:dsn string? 314 | #:user string? 315 | #:password string? 316 | #:notice-handler (or/c 'output 'error) 317 | #:strict-parameter-types? boolean? 318 | #:character-mode (or/c 'wchar 'utf-8 'latin-1) 319 | #:quirks (listof symbol?) 320 | #:use-place boolean?) 321 | data-source?)] 322 | [odbc-driver-data-source 323 | (->* (string?) 324 | (#:notice-handler (or/c 'output 'error) 325 | #:strict-parameter-types? boolean? 326 | #:character-mode (or/c 'wchar 'utf-8 'latin-1) 327 | #:quirks (listof symbol?) 328 | #:use-place boolean?) 329 | data-source?)]) 330 | -------------------------------------------------------------------------------- /db-lib/db/cassandra.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/contract/base 3 | db/base 4 | openssl 5 | "private/cassandra/main.rkt" 6 | "util/cassandra.rkt") 7 | 8 | ;; FIXME: Contracts duplicated at main.rkt 9 | (provide/contract 10 | [cassandra-connect 11 | (->* [] 12 | [#:server (or/c string? #f) 13 | #:port (or/c exact-positive-integer? #f) 14 | #:user (or/c string? #f) 15 | #:password (or/c string? #f) 16 | #:ssl (or/c 'yes 'no) 17 | #:ssl-context (or/c ssl-client-context? 'secure 'auto) 18 | #:debug? any/c] 19 | connection?)]) 20 | (provide cassandra-consistency) 21 | -------------------------------------------------------------------------------- /db-lib/db/info.rkt: -------------------------------------------------------------------------------- 1 | #lang setup/infotab 2 | 3 | (define collection "db") 4 | -------------------------------------------------------------------------------- /db-lib/db/main.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/lazy-require 3 | racket/contract/base 4 | db/base) 5 | (provide (all-from-out db/base)) 6 | 7 | (lazy-require 8 | ["private/postgresql/main.rkt" 9 | (postgresql-connect 10 | postgresql-guess-socket-path 11 | postgresql-password-hash)] 12 | ["private/mysql/main.rkt" 13 | (mysql-connect 14 | mysql-guess-socket-path 15 | mysql-password-hash)] 16 | ["private/cassandra/main.rkt" 17 | (cassandra-connect)] 18 | ["private/sqlite3/place.rkt" 19 | (sqlite3-connect 20 | sqlite3-available?)] 21 | ["private/odbc/main.rkt" 22 | (odbc-connect 23 | odbc-driver-connect 24 | odbc-data-sources 25 | odbc-drivers)] 26 | [openssl 27 | (ssl-client-context?)]) 28 | 29 | (provide/contract 30 | ;; Duplicates contracts at postgresql.rkt 31 | [postgresql-connect 32 | (->* (#:user string? 33 | #:database string?) 34 | (#:password (or/c string? (list/c 'hash string?) #f) 35 | #:server (or/c string? #f) 36 | #:port (or/c exact-positive-integer? #f) 37 | #:socket (or/c path-string? 'guess #f) 38 | #:allow-cleartext-password? boolean? 39 | #:ssl (or/c 'yes 'no 'optional) 40 | #:ssl-context ssl-client-context? 41 | #:notice-handler (or/c 'output 'error output-port? procedure?) 42 | #:notification-handler (or/c 'output 'error output-port? procedure?) 43 | #:debug? any/c) 44 | connection?)] 45 | [postgresql-guess-socket-path 46 | (-> path-string?)] 47 | [postgresql-password-hash 48 | (-> string? string? string?)] 49 | 50 | ;; Duplicates contracts at mysql.rkt 51 | [mysql-connect 52 | (->* (#:user string?) 53 | (#:database (or/c string? #f) 54 | #:password (or/c string? (list/c 'hash string?) #f) 55 | #:server (or/c string? #f) 56 | #:port (or/c exact-positive-integer? #f) 57 | #:socket (or/c path-string? 'guess #f) 58 | #:allow-cleartext-password? boolean? 59 | #:ssl (or/c 'yes 'no 'optional) 60 | #:ssl-context ssl-client-context? 61 | #:notice-handler (or/c 'output 'error output-port? procedure?) 62 | #:debug? any/c) 63 | connection?)] 64 | [mysql-guess-socket-path 65 | (-> path-string?)] 66 | [mysql-password-hash 67 | (-> string? string?)] 68 | 69 | ;; Duplicates contracts at cassandra.rkt 70 | [cassandra-connect 71 | (->* [] 72 | [#:server (or/c string? #f) 73 | #:port (or/c exact-positive-integer? #f) 74 | #:user (or/c string? #f) 75 | #:password (or/c string? #f) 76 | #:ssl (or/c 'yes 'no) 77 | #:ssl-context (or/c ssl-client-context? 'secure 'auto) 78 | #:debug? any/c] 79 | connection?)] 80 | 81 | ;; Duplicates contracts at sqlite3.rkt 82 | [sqlite3-connect 83 | (->* (#:database (or/c path-string? 'memory 'temporary)) 84 | (#:mode (or/c 'read-only 'read/write 'create) 85 | #:busy-retry-limit (or/c exact-nonnegative-integer? +inf.0) 86 | #:busy-retry-delay (and/c rational? (not/c negative?)) 87 | #:use-place (or/c boolean? 'place 'os-thread) 88 | #:debug? any/c) 89 | connection?)] 90 | [sqlite3-available? 91 | (-> boolean?)] 92 | 93 | ;; Duplicates contracts at odbc.rkt 94 | [odbc-connect 95 | (->* (#:dsn (or/c string? #f)) 96 | (#:user (or/c string? #f) 97 | #:password (or/c string? #f) 98 | #:notice-handler (or/c 'output 'error output-port? procedure?) 99 | #:strict-parameter-types? boolean? 100 | #:character-mode (or/c 'wchar 'utf-8 'latin-1) 101 | #:quirks (listof symbol?) 102 | #:use-place (or/c boolean? 'place 'os-thread)) 103 | connection?)] 104 | [odbc-driver-connect 105 | (->* (string?) 106 | (#:notice-handler (or/c 'output 'error output-port? procedure?) 107 | #:strict-parameter-types? boolean? 108 | #:character-mode (or/c 'wchar 'utf-8 'latin-1) 109 | #:quirks (listof symbol?) 110 | #:use-place (or/c boolean? 'place 'os-thread)) 111 | connection?)] 112 | [odbc-data-sources 113 | (-> (listof (list/c string? string?)))] 114 | [odbc-drivers 115 | (-> (listof (cons/c string? any/c)))]) 116 | -------------------------------------------------------------------------------- /db-lib/db/mysql.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/contract/base 3 | openssl 4 | db/base 5 | "private/mysql/main.rkt") 6 | 7 | ;; FIXME: Contracts duplicated at main.rkt 8 | (provide/contract 9 | [mysql-connect 10 | (->* (#:user string?) 11 | (#:database (or/c string? #f) 12 | #:password (or/c string? (list/c 'hash string?) #f) 13 | #:server (or/c string? #f) 14 | #:port (or/c exact-positive-integer? #f) 15 | #:socket (or/c path-string? 'guess #f) 16 | #:allow-cleartext-password? boolean? 17 | #:ssl (or/c 'yes 'no 'optional) 18 | #:ssl-context ssl-client-context? 19 | #:notice-handler (or/c 'output 'error output-port? procedure?) 20 | #:debug? any/c) 21 | connection?)] 22 | [mysql-guess-socket-path 23 | (-> path-string?)] 24 | [mysql-password-hash 25 | (-> string? string?)]) 26 | -------------------------------------------------------------------------------- /db-lib/db/odbc.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/contract/base 3 | db/base 4 | "private/odbc/main.rkt") 5 | 6 | ;; FIXME: Contracts duplicated at main.rkt 7 | (provide/contract 8 | [odbc-connect 9 | (->* (#:dsn (or/c string? #f)) 10 | (#:user (or/c string? #f) 11 | #:password (or/c string? #f) 12 | #:notice-handler (or/c 'output 'error output-port? procedure?) 13 | #:strict-parameter-types? boolean? 14 | #:character-mode (or/c 'wchar 'utf-8 'latin-1) 15 | #:quirks (listof symbol?) 16 | #:use-place (or/c boolean? 'place 'os-thread)) 17 | connection?)] 18 | [odbc-driver-connect 19 | (->* (string?) 20 | (#:notice-handler (or/c 'output 'error output-port? procedure?) 21 | #:strict-parameter-types? boolean? 22 | #:character-mode (or/c 'wchar 'utf-8 'latin-1) 23 | #:quirks (listof symbol?) 24 | #:use-place (or/c boolean? 'place 'os-thread)) 25 | connection?)] 26 | [odbc-data-sources 27 | (-> (listof (list/c string? string?)))] 28 | [odbc-drivers 29 | (-> (listof (cons/c string? any/c)))]) 30 | -------------------------------------------------------------------------------- /db-lib/db/postgresql.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/contract/base 3 | openssl 4 | db/base 5 | "private/postgresql/main.rkt") 6 | 7 | ;; FIXME: Contracts duplicated at main.rkt 8 | (provide/contract 9 | [postgresql-connect 10 | (->* (#:user string? 11 | #:database string?) 12 | (#:password (or/c string? (list/c 'hash string?) #f) 13 | #:server (or/c string? #f) 14 | #:port (or/c exact-positive-integer? #f) 15 | #:socket (or/c path-string? 'guess #f) 16 | #:allow-cleartext-password? boolean? 17 | #:ssl (or/c 'yes 'no 'optional) 18 | #:ssl-context ssl-client-context? 19 | #:notice-handler (or/c 'output 'error output-port? procedure?) 20 | #:notification-handler (or/c 'output 'error output-port? procedure?) 21 | #:debug? any/c) 22 | connection?)] 23 | [postgresql-guess-socket-path 24 | (-> path-string?)] 25 | [postgresql-password-hash 26 | (-> string? string? string?)]) 27 | -------------------------------------------------------------------------------- /db-lib/db/private/cassandra/dbsystem.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/class 3 | racket/list 4 | racket/match 5 | racket/string 6 | file/sha1 7 | db/private/generic/interfaces 8 | db/private/generic/common 9 | db/private/generic/sql-data 10 | db/private/generic/sql-convert 11 | "message.rkt") 12 | (provide dbsystem) 13 | 14 | (define cassandra-dbsystem% 15 | (class* dbsystem-base% (dbsystem<%>) 16 | (define/public (get-short-name) 'cassandra) 17 | (define/override (get-type-list) type-list) 18 | 19 | (define/public (has-support? option) 20 | (case option 21 | ((real-infinities) #t) 22 | ((numeric-infinities) #t) 23 | (else #f))) 24 | 25 | (define/public (get-parameter-handlers param-typeids) 26 | (map make-type-writer param-typeids)) 27 | 28 | (define/public (field-dvecs->typeids dvecs) 29 | (map dvec-type dvecs)) 30 | 31 | (define/public (describe-params typeids) 32 | typeids) 33 | 34 | (define/public (describe-fields dvecs) 35 | (map dvec-type dvecs)) 36 | 37 | (super-new))) 38 | 39 | (define dbsystem (new cassandra-dbsystem%)) 40 | 41 | ;; ============================================================ 42 | 43 | (define ((make-type-writer typeid) who v) (encode-value who typeid v)) 44 | 45 | (define type-list 46 | '(ascii 47 | bigint 48 | int 49 | blob 50 | boolean 51 | decimal 52 | double 53 | float 54 | ;; inet 55 | text 56 | varchar 57 | timestamp 58 | uuid 59 | timeuuid 60 | varint 61 | (list *) 62 | (set *) 63 | (map * *) 64 | (tuple **))) 65 | -------------------------------------------------------------------------------- /db-lib/db/private/cassandra/main.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/class 3 | racket/tcp 4 | openssl 5 | db/private/generic/interfaces 6 | db/private/generic/common 7 | "connection.rkt") 8 | (provide cassandra-connect) 9 | 10 | (define (cassandra-connect #:server [server "localhost"] 11 | #:port [port 9042] 12 | #:user [user #f] 13 | #:password [password #f] 14 | #:ssl [ssl 'no] 15 | #:ssl-context [ssl-context 'auto] 16 | #:debug? [debug? #f]) 17 | (define-values (in out) 18 | (case ssl 19 | [(no) (tcp-connect server port)] 20 | [(yes) (ssl-connect server port ssl-context)])) 21 | (define c (new connection% (inport in) (outport out))) 22 | (when debug? (send c debug #t)) 23 | (with-handlers 24 | ([exn? (lambda (e) 25 | (send c disconnect* #f) 26 | (raise e))]) 27 | (send c start-connection-protocol user password)) 28 | c) 29 | -------------------------------------------------------------------------------- /db-lib/db/private/generic/dsn.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/lazy-require 3 | syntax/parse/private/minimatch 4 | racket/file 5 | racket/list) 6 | (provide dsn-connect 7 | (struct-out data-source) 8 | connector? 9 | arglist? 10 | writable-datum? 11 | current-dsn-file 12 | get-dsn 13 | put-dsn 14 | postgresql-data-source 15 | mysql-data-source 16 | cassandra-data-source 17 | sqlite3-data-source 18 | odbc-data-source 19 | odbc-driver-data-source) 20 | 21 | (lazy-require 22 | [db/postgresql (postgresql-connect)] 23 | [db/mysql (mysql-connect)] 24 | [db/cassandra (cassandra-connect)] 25 | [db/sqlite3 (sqlite3-connect)] 26 | [db/odbc (odbc-connect odbc-driver-connect)]) 27 | 28 | #| 29 | DSN v0.1 format 30 | 31 | A DSN (prefs) file maps symbol => 32 | 33 | ::= (db ) 34 | 35 | ::= postgresql | mysql | sqlite3 | odbc | odbc-driver 36 | 37 | ::= ( ...) 38 | ::= | { } 39 | 40 | ::= (( ) ...) 41 | 42 | Extensions associate arbitrary extra information with a data-source (for 43 | example, SQL dialect information, testing flags, etc). Extension keys 44 | starting with 'dsn:', 'db:', 'racket:', and 'plt:' are 45 | reserved. Keys may occur multiple times, but the order should not be 46 | considered important. 47 | 48 | db:description ::= , short description 49 | db:comment ::= , or maybe 50 | 51 | |# 52 | 53 | (struct data-source (connector args extensions) #:transparent #:mutable) 54 | 55 | ;; ---------------------------------------- 56 | 57 | (define none (gensym 'none)) 58 | 59 | (define (writable-datum? x) 60 | (or (symbol? x) 61 | (string? x) 62 | (number? x) 63 | (boolean? x) 64 | (null? x) 65 | (and (pair? x) 66 | (writable-datum? (car x)) 67 | (writable-datum? (cdr x))))) 68 | 69 | (define (connector? x) 70 | (memq x '(postgresql mysql cassandra sqlite3 odbc odbc-driver))) 71 | 72 | (define (parse-arglist x [default none]) 73 | (define (fail . args) 74 | (cond [(eq? default none) (apply error 'parse-arglist args)] 75 | [(procedure? default) (default)] 76 | [else default])) 77 | (if (list? x) 78 | (let loop ([x x] [pargs null] [kwargs null]) 79 | (cond [(null? x) 80 | (list (reverse pargs) 81 | (reverse kwargs))] 82 | [(keyword? (car x)) 83 | (cond [(null? (cdr x)) (fail "keyword without argument: ~a" (car x))] 84 | [(writable-datum? (cadr x)) 85 | (loop (cddr x) pargs (cons (list (car x) (cadr x)) kwargs))] 86 | [else 87 | (fail "expected readable datum: ~e" (cadr x))])] 88 | [(writable-datum? (car x)) 89 | (loop (cdr x) (cons (car x) pargs) kwargs)] 90 | [else (fail "expected readable datum: ~e" (car x))])) 91 | (fail "expected list"))) 92 | 93 | (define (arglist? x) 94 | (and (parse-arglist x #f) #t)) 95 | 96 | (define (parse-extensions x [default none]) 97 | (let/ec escape 98 | (define (fail . args) 99 | (cond [(eq? default none) (apply error 'parse-extensions args)] 100 | [(procedure? default) (escape (default))] 101 | [else (escape default)])) 102 | (if (list? x) 103 | (map (lambda (x) 104 | (match x 105 | [(list (? symbol? key) (? writable-datum? value)) 106 | x] 107 | [else (fail "expected extension entry: ~e" x)])) 108 | x) 109 | (fail "expected list: ~e" x)))) 110 | 111 | (define (extensions? x) 112 | (and (parse-extensions x #f) #t)) 113 | 114 | (define (sexpr->data-source x) 115 | (let/ec escape 116 | (match x 117 | [(list 'db (? connector? connector) (? arglist? args) (? extensions? exts)) 118 | (data-source connector args exts)] 119 | [_ #f]))) 120 | 121 | (define (data-source->sexpr x) 122 | (match x 123 | [(data-source connector args exts) 124 | `(db ,connector ,args ,exts)])) 125 | 126 | ;; ---------------------------------------- 127 | 128 | (define current-dsn-file 129 | (make-parameter (build-path (find-system-path 'pref-dir) "db-dsn-0.rktd"))) 130 | 131 | (define (get-dsn name [default #f] #:dsn-file [file (current-dsn-file)]) 132 | (let* ([sexpr (get-preference name (lambda () #f) 'timestamp file)]) 133 | (or (and sexpr (sexpr->data-source sexpr)) 134 | (if (procedure? default) (default) default)))) 135 | 136 | (define (put-dsn name value #:dsn-file [file (current-dsn-file)]) 137 | (let* ([sexpr (and value (data-source->sexpr value))]) 138 | (put-preferences (list name) 139 | (list sexpr) 140 | (lambda () (error 'put-dsn "DSN file locked")) 141 | file))) 142 | 143 | ;; ---------------------------------------- 144 | 145 | (define (get-connect x) 146 | (case x 147 | ((postgresql) postgresql-connect) 148 | ((mysql) mysql-connect) 149 | ((cassandra) cassandra-connect) 150 | ((sqlite3) sqlite3-connect) 151 | ((odbc) odbc-connect) 152 | ((odbc-driver) odbc-driver-connect))) 153 | 154 | (define dsn-connect 155 | (make-keyword-procedure 156 | (lambda (kws kwargs name . pargs) 157 | (let* ([kws (map list kws kwargs)] 158 | [file-entry (assq '#:dsn-file kws)] 159 | [kws* (if file-entry (remq file-entry kws) kws)] 160 | [file (if file-entry (cadr file-entry) (current-dsn-file))]) 161 | (unless (or (symbol? name) (data-source? name)) 162 | (error 'dsn-connect 163 | "expected symbol for first argument, got: ~e" name)) 164 | (unless (or (path-string? file) (not file)) 165 | (error 'dsn-connect 166 | "expected path or string for #:dsn-file keyword, got: ~e" 167 | file)) 168 | (let ([r (if (data-source? name) name (get-dsn name #f #:dsn-file file))]) 169 | (unless r 170 | (error 'dsn-connect "cannot find data source named ~e" name)) 171 | (let* ([rargs (parse-arglist (data-source-args r))] 172 | [rpargs (first rargs)] 173 | [rkwargs (second rargs)] 174 | [allpargs (append rpargs pargs)] 175 | [allkwargs (sort (append rkwargs kws*) keyword) 41 | (init channel) 42 | (field [channel-box (make-custodian-box (current-custodian) channel)]) 43 | (inherit call-with-lock 44 | call-with-lock*) 45 | (super-new) 46 | 47 | (define/private (call method-name who . args) 48 | (call-with-lock who (lambda () (call* method-name who args #t)))) 49 | (define/private (call/d method-name who . args) 50 | (call-with-lock* who (lambda () (call* method-name who args #f)) #f #f)) 51 | (define/private (call* method-name who args need-connected?) 52 | (cond [(and channel-box (custodian-box-value channel-box)) 53 | => (lambda (channel) 54 | (pchan-put channel (cons method-name args)) 55 | (let* ([response (pchan-get channel)] 56 | [still-connected? (car response)]) 57 | (when (not still-connected?) (set! channel-box #f)) 58 | (match (cdr response) 59 | [(cons 'values vals) 60 | (apply values (for/list ([val (in-list vals)]) (sexpr->result val)))] 61 | [(list 'error message) 62 | (raise (make-exn:fail message (current-continuation-marks)))])))] 63 | [need-connected? 64 | (error/not-connected who)] 65 | [else (void)])) 66 | 67 | (define/override (connected?) 68 | (let ([channel-box channel-box]) 69 | (and channel-box (custodian-box-value channel-box) #t))) 70 | 71 | (define/public (disconnect) 72 | (call/d 'disconnect 'disconnect) 73 | (set! channel-box #f)) 74 | 75 | (define/public (get-dbsystem) (error 'get-dbsystem "not implemented")) 76 | (define/public (get-base) this) 77 | 78 | (define/public (query who stmt cursor?) 79 | (begin0 (call 'query who who 80 | (match stmt 81 | [(? string?) (list 'string stmt)] 82 | [(statement-binding pst params) 83 | (list 'statement-binding (send pst get-handle) params)]) 84 | cursor?) 85 | ;; If stmt contains a prepared statement, it must not be GC'd before 86 | ;; the query is actually executed. 87 | (void/reference-sink stmt))) 88 | (define/public (prepare who stmt close-on-exec?) 89 | (call 'prepare who who stmt close-on-exec?)) 90 | (define/public (fetch/cursor who cursor fetch-size) 91 | (call 'fetch/cursor who who (cursor-result-extra cursor) fetch-size)) 92 | (define/public (transaction-status who) 93 | (call 'transaction-status who who)) 94 | (define/public (start-transaction who iso option cwt?) 95 | (call 'start-transaction who who iso option cwt?)) 96 | (define/public (end-transaction who mode cwt?) 97 | (call 'end-transaction who who mode cwt?)) 98 | (define/public (list-tables who schema) 99 | (call 'list-tables who who schema)) 100 | 101 | (define/public (free-statement pst need-lock?) 102 | (start-atomic) 103 | (let ([handle (send pst get-handle)]) 104 | (send pst set-handle #f) 105 | (end-atomic) 106 | (when channel-box 107 | (call/d 'free-statement 'free-statement handle need-lock?)))) 108 | 109 | (define/private (sexpr->result x) 110 | (match x 111 | [(list 'simple-result y) 112 | (simple-result y)] 113 | [(list 'rows-result h rows) 114 | (rows-result h rows)] 115 | [(list 'cursor-result info handle) 116 | (cursor-result info #f handle)] 117 | [(list 'prepared-statement handle close-on-exec? param-typeids result-dvecs) 118 | (new prepared-statement% 119 | (handle handle) 120 | (close-on-exec? close-on-exec?) 121 | (param-typeids param-typeids) 122 | (result-dvecs result-dvecs) 123 | (owner this))] 124 | [_ x])))) 125 | -------------------------------------------------------------------------------- /db-lib/db/private/generic/place-server.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require (for-syntax racket/base) 3 | racket/class 4 | syntax/parse/private/minimatch 5 | racket/place 6 | racket/serialize 7 | racket/lazy-require 8 | db/private/generic/interfaces 9 | db/private/generic/prepared) 10 | (provide connection-server) 11 | 12 | (define (pchan-put chan datum) 13 | (place-channel-put chan (serialize datum))) 14 | (define (pchan-get chan) 15 | (deserialize (place-channel-get chan))) 16 | 17 | #| 18 | Connection creation protocol 19 | 20 | client -> server on client-chan: (list 'connect conn-chan ) 21 | server -> client on conn-chan: (or (list 'ok) 22 | (list 'error string)) 23 | 24 | where ::= (list 'sqlite3 path/sym mode-sym delay-num limit-num) 25 | | (list 'odbc string string/#f string/#f boolean symbol symbol-list) 26 | |# 27 | (define (connection-server client-chan) 28 | (let loop () 29 | (serve client-chan) 30 | (loop))) 31 | 32 | (lazy-require 33 | [db/private/sqlite3/main (sqlite3-connect)] 34 | [db/private/odbc/main (odbc-connect odbc-driver-connect)]) 35 | 36 | (define (serve client-chan) 37 | (match (place-channel-get client-chan) 38 | [(list 'connect conn-chan connect-spec) 39 | (with-handlers ([exn:fail? 40 | (lambda (e) 41 | (pchan-put conn-chan (list 'error (exn-message e))))]) 42 | (let* ([c 43 | (match connect-spec 44 | [(list 'sqlite3 db mode busy-retry-delay busy-retry-limit) 45 | (sqlite3-connect #:database db 46 | #:mode mode 47 | #:busy-retry-delay busy-retry-delay 48 | #:busy-retry-limit busy-retry-limit)] 49 | [(list 'odbc dsn user password strict-param? char-mode quirks) 50 | (odbc-connect #:dsn dsn 51 | #:user user 52 | #:password password 53 | #:strict-parameter-types? strict-param? 54 | #:character-mode char-mode 55 | #:quirks quirks 56 | #:use-place #f)] 57 | [(list 'odbc-driver connection-string strict-param? char-mode quirks) 58 | (odbc-driver-connect connection-string 59 | #:strict-parameter-types? strict-param? 60 | #:character-mode char-mode 61 | #:quirks quirks 62 | #:use-place #f)])] 63 | [p (new proxy-server% (connection c) (channel conn-chan))]) 64 | (pchan-put conn-chan (list 'ok)) 65 | (thread (lambda () (send p serve)))))])) 66 | 67 | #| 68 | Connection methods protocol 69 | 70 | client -> server: (list ' arg ...) 71 | server -> client: (or (list boolean 'values result ...) 72 | (list boolean 'error string)) 73 | |# 74 | 75 | (define proxy-server% 76 | (class object% 77 | (init-field connection 78 | channel) 79 | (super-new) 80 | 81 | ;; FIXME: need to collect cursors, too 82 | (define table (make-hash)) ;; int => prepared-statement/cursor-result 83 | (define counter 0) 84 | 85 | (define/public (serve) 86 | (serve1) 87 | (when connection (serve))) 88 | 89 | (define/private (still-connected?) (and connection (send connection connected?))) 90 | 91 | (define/private (serve1) 92 | (with-handlers ([exn? 93 | (lambda (e) 94 | (pchan-put channel (list (still-connected?) 'error (exn-message e))))]) 95 | (call-with-values 96 | (lambda () 97 | (match (pchan-get channel) 98 | [(list 'disconnect) 99 | (send connection disconnect) 100 | (set! connection #f)] 101 | [(list 'free-statement pstmt-index need-lock?) 102 | ;; The client is done with the stmt, but this side's connection might still 103 | ;; have references (eg, statement-cache). So just remove from table. 104 | (hash-remove! table pstmt-index)] 105 | [(list 'query fsym stmt cursor?) 106 | (send connection query fsym (sexpr->statement stmt) cursor?)] 107 | [(list 'fetch/cursor fsym cursor-index fetch-size) 108 | (send connection fetch/cursor fsym (hash-ref table cursor-index) fetch-size)] 109 | [msg 110 | (define-syntax-rule (forward-methods (method arg ...) ...) 111 | (match msg 112 | [(list 'method arg ...) 113 | (send connection method arg ...)] 114 | ...)) 115 | (forward-methods (connected?) 116 | (prepare w s m) 117 | (list-tables w s) 118 | (start-transaction w m o c) 119 | (end-transaction w m c) 120 | (transaction-status w))])) 121 | (lambda results 122 | (let ([results (for/list ([result (in-list results)]) (result->sexpr result))]) 123 | (pchan-put channel (cons (still-connected?) (cons 'values results)))))))) 124 | 125 | (define/private (sexpr->statement x) 126 | (match x 127 | [(list 'string s) s] 128 | [(list 'statement-binding pstmt-index args) 129 | (statement-binding (hash-ref table pstmt-index) args)])) 130 | 131 | (define/private (result->sexpr x) 132 | (match x 133 | [(simple-result y) 134 | (list 'simple-result y)] 135 | [(rows-result h rows) 136 | (list 'rows-result h rows)] 137 | [(cursor-result h pst extra) 138 | (let ([index (begin (set! counter (add1 counter)) counter)]) 139 | (hash-set! table index x) 140 | (list 'cursor-result h index))] 141 | ;; FIXME: Assumes prepared-statement is concrete class, not interface. 142 | [(? (lambda (x) (is-a? x prepared-statement%))) 143 | (let ([index (begin (set! counter (add1 counter)) counter)]) 144 | (hash-set! table index x) 145 | (list 'prepared-statement 146 | index 147 | (get-field close-on-exec? x) 148 | (get-field param-typeids x) 149 | (get-field result-dvecs x)))] 150 | [_ x])))) 151 | -------------------------------------------------------------------------------- /db-lib/db/private/generic/sql-convert.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/math) 3 | 4 | (provide exact->decimal-string ;; odbc, tests (?) 5 | scaled-integer->decimal-string ;; odbc 6 | exact->scaled-integer ;; pg, odbc 7 | inexact->scaled-integer) ;; pg 8 | 9 | ;; ======================================== 10 | 11 | ;; exact->decimal-string : exact -> string or #f 12 | (define (exact->decimal-string n) 13 | (cond [(exact->scaled-integer n) 14 | => (lambda (ma+ex) 15 | (scaled-integer->decimal-string (car ma+ex) (cdr ma+ex)))] 16 | [else #f])) 17 | 18 | ;; scaled-integer->decimal-string : Int Int -> String 19 | ;; Given M and E, converts (M * 10^-E) to a decimal string. 20 | ;; If E>0, then there is a decimal point and exactly E digits after it. 21 | (define (scaled-integer->decimal-string ma ex) 22 | (cond [(zero? ex) (number->string ma)] 23 | [(< ex 0) 24 | (string-append (number->string ma) (make-string ex #\0))] 25 | [(> ex 0) 26 | (define mstr (number->string (abs ma))) 27 | (define len (string-length mstr)) 28 | (cond [(<= len ex) 29 | (string-append (if (negative? ma) "-0." "0.") 30 | (make-string (- ex len) #\0) 31 | mstr)] 32 | [else 33 | (string-append (if (negative? ma) "-" "") 34 | (substring mstr 0 (- len ex)) 35 | "." 36 | (substring mstr (- len ex) len))])])) 37 | 38 | ;; exact->scaled-integer : exact-rational -> (cons int int) or #f 39 | ;; Given x, returns (cons M E) s.t. x = (M * 10^-E) 40 | (define (exact->scaled-integer n [trim-integers? #f]) 41 | (if (and trim-integers? (integer? n)) 42 | (let*-values ([(n* fives) (factor-out n 5)] 43 | [(n** twos) (factor-out n* 2)]) 44 | (let ([tens (min fives twos)]) 45 | (cons (/ n (expt 10 tens)) (- tens)))) 46 | (let* ([whole-part (truncate n)] 47 | [fractional-part (- (abs n) (abs whole-part))] 48 | [den (denominator fractional-part)]) 49 | (let*-values ([(den* fives) (factor-out den 5)] 50 | [(den** twos) (factor-out den* 2)]) 51 | (and (= 1 den**) 52 | (let ([tens (max fives twos)]) 53 | (cons (* n (expt 10 tens)) tens))))))) 54 | 55 | ;; inexact->scaled-integer : inexact-rational -> (cons int int) 56 | ;; Given x, returns (cons M E) s.t. x ~= (M * 10^-E) 57 | (define (inexact->scaled-integer x) 58 | ;; FIXME: as a hacky alternative, could just parse result of number->string 59 | (if (zero? x) 60 | (cons 0 0) 61 | ;; nonzero, inexact 62 | ;; 16 digits ought to be enough (and not too much) 63 | (let* ([E0 (order-of-magnitude x)] 64 | ;; x = y * 10^E0 where y in [1,10) 65 | [E1 (add1 E0)] 66 | ;; x = y * 10^E1 where y in [0.1,1) 67 | [E (- E1 16)] 68 | ;; x ~= M * 10^E where M in [10^15,10^16) 69 | [M (inexact->exact (truncate (* x (expt 10 (- E)))))] 70 | ;; trim zeroes from M 71 | [M*+E* (exact->scaled-integer M #t)] 72 | [M* (car M*+E*)] 73 | [E* (cdr M*+E*)]) 74 | (cons M* (- E* E))))) 75 | 76 | (define (factor-out-v1 n factor) 77 | (define (loop n acc) 78 | (let-values ([(q r) (quotient/remainder n factor)]) 79 | (if (zero? r) 80 | (loop q (add1 acc)) 81 | (values n acc)))) 82 | (loop n 0)) 83 | 84 | (define (factor-out n factor) 85 | (define (loop n factor) 86 | (if (<= factor n) 87 | (let*-values ([(q n) (loop n (* factor factor))] 88 | [(q* r) (quotient/remainder q factor)]) 89 | (if (zero? r) 90 | (values q* (+ n n 1)) 91 | (values q (+ n n)))) 92 | (values n 0))) 93 | (loop n factor)) 94 | -------------------------------------------------------------------------------- /db-lib/db/private/mysql/dbsystem.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/class 3 | racket/match 4 | racket/flonum 5 | json 6 | db/private/generic/interfaces 7 | db/private/generic/common 8 | db/private/generic/sql-data 9 | "../../util/private/geometry.rkt" 10 | (submod "../../util/mysql.rkt" private) 11 | (only-in "message.rkt" length-code->bytes field-dvec->typeid field-dvec->flags)) 12 | (provide dbsystem:base 13 | select-dbsystem 14 | parse-server-version 15 | version<=? 16 | classify-my-sql) 17 | 18 | (define mysql-dbsystem% 19 | (class* dbsystem-base% (dbsystem<%>) 20 | (init-field flags) 21 | 22 | (define (check-param* who param) 23 | (check-param who param flags)) 24 | 25 | (define/public (get-short-name) 'mysql) 26 | (define/override (get-type-list) type-list) 27 | 28 | (define/public (has-support? option) 29 | (case option 30 | ((real-infinities) #f) 31 | ((numeric-infinities) #f) 32 | (else #f))) 33 | 34 | (define/public (get-parameter-handlers param-typeids) 35 | ;; All params sent as binary data, so handled in message.rkt. 36 | ;; MySQL now (since ??) sometimes sets useful param typeid, but ignore 37 | ;; because it might not be reliable and for backwards compatibility. 38 | (map (lambda (param-typid) check-param*) param-typeids)) 39 | 40 | (define/public (field-dvecs->typeids dvecs) 41 | (map field-dvec->typeid dvecs)) 42 | 43 | (define/public (describe-params typeids) 44 | (for/list ([_typeid (in-list typeids)]) 45 | '(#t any #f))) 46 | 47 | (define/public (describe-fields dvecs) 48 | (for/list ([dvec (in-list dvecs)]) 49 | (let ([r (describe-typeid (field-dvec->typeid dvec))]) 50 | (match r 51 | [(list supported? type typeid) 52 | (let* ([binary? (memq 'binary (field-dvec->flags dvec))] 53 | [type* (case type 54 | ((tinyblob) (if binary? type 'tinytext)) 55 | ((blob) (if binary? type 'text)) 56 | ((mediumblob) (if binary? type 'mediumtext)) 57 | ((longblob) (if binary? type 'longtext)) 58 | ((var-string) (if binary? 'var-binary type)) 59 | (else type))]) 60 | (if (eq? type* type) 61 | r 62 | (list supported? type* typeid)))])))) 63 | 64 | (super-new))) 65 | 66 | (define dbsystem:base (new mysql-dbsystem% (flags '()))) 67 | (define dbsystem:5 (new mysql-dbsystem% (flags '(send-geom)))) 68 | (define dbsystem:5.7 (new mysql-dbsystem% (flags '(send-geom json)))) 69 | (define dbsystem:8 (new mysql-dbsystem% (flags '(json)))) 70 | (define dbsystem:9 (new mysql-dbsystem% (flags '(json vector)))) 71 | 72 | (define (select-dbsystem v) 73 | (cond [(version<=? '(9) v) dbsystem:9] 74 | [(version<=? '(8) v) dbsystem:8] 75 | [(version<=? '(5 7) v) dbsystem:5.7] 76 | [else dbsystem:5])) 77 | 78 | (define (parse-server-version sver) 79 | (cond [(regexp-match #rx"^([0-9]+)[.]([0-9]+)[.]([0-9]+)" sver) 80 | => (lambda (m) (map string->number (list (cadr m) (caddr m) (cadddr m))))] 81 | [(regexp-match #rx"^([0-9]+)[.]([0-9]+)" sver) 82 | => (lambda (m) (map string->number (list (cadr m) (caddr m))))] 83 | [else (list 0)])) 84 | 85 | (define (version<=? v1 v2) 86 | (cond [(null? v1) #t] 87 | [(null? v2) #f] 88 | [(< (car v1) (car v2)) #t] 89 | [(= (car v1) (car v2)) (version<=? (cdr v1) (cdr v2))] 90 | [else #f])) 91 | 92 | ;; ======================================== 93 | 94 | (define DATE-YEAR-MIN 0) 95 | (define DATE-YEAR-MAX 9999) 96 | 97 | ;; A CheckedParam is (cons type-symbol bytes-or-value) 98 | ;; Three variants, depending on the stage of parameter processing: 99 | ;; - v1, after check-param: All variable-length values are converted 100 | ;; to bytes here, so that connection can decide what to send in long 101 | ;; data packets. 102 | ;; - v2, after by connection sends long data: Payloads already sent as 103 | ;; long-data are replaced by #f. 104 | 105 | ;; check-param : Symbol Any (Listof Symbol) -> CheckParam-v1 106 | ;; Note: not applied to sql-null parameters. 107 | (define (check-param fsym param flags) 108 | (cond [(string? param) 109 | (cons 'var-string (string->bytes/utf-8 param))] 110 | [(bytes? param) 111 | (cons 'blob param)] 112 | [(int64? param) 113 | (cons 'longlong param)] 114 | [(rational? param) 115 | (cons 'double param)] 116 | [(or (sql-time? param) (sql-day-time-interval? param)) 117 | (cons 'time param)] 118 | [(sql-bits? param) 119 | (let-values ([(len bs start) (align-sql-bits param 'right)]) 120 | (cons 'bit (bytes-append (length-code->bytes (- (bytes-length bs) start)) bs)))] 121 | [(geometry2d? param) 122 | ;; Since MySQL 8.0 (?), sending parameters as the 'geometry type does not work. 123 | ;; So send WKB as 'blob instead. 124 | (define who 'mysql-geometry->bytes) 125 | (if (memq 'send-geom flags) 126 | (cons 'geometry (geometry->bytes who param #:big-endian? #f #:srid? #t)) 127 | (cons 'blob (geometry->bytes who param #:big-endian? #f #:srid? #f)))] 128 | [(sql-date? param) 129 | (unless (<= DATE-YEAR-MIN (sql-date-year param) DATE-YEAR-MAX) 130 | (error/no-convert fsym "MySQL" "DATE" param "year out of range")) 131 | ;; Other ranges checked by sql-date contract at db/base.rkt 132 | (cons 'date param)] 133 | [(sql-timestamp? param) 134 | (unless (<= DATE-YEAR-MIN (sql-timestamp-year param) DATE-YEAR-MAX) 135 | (error/no-convert fsym "MySQL" "DATETIME" param "year out of range")) 136 | ;; See comment above for sql-date 137 | (cons 'timestamp param)] 138 | [(mysql-json? param) 139 | (unless (memq 'json flags) 140 | (error/no-convert fsym "MySQL" "JSON" param "server version too old")) 141 | (cons 'json (mysql-json-bytes param))] 142 | [(flvector? param) 143 | (unless (memq 'vector flags) 144 | (error/no-convert fsym "MySQL" "VECTOR" param "server version too old")) 145 | (when (zero? (flvector-length param)) 146 | (error/no-convert fsym "MySQL" "VECTOR" param "must be non-empty")) 147 | (define bs (make-bytes (* 4 (flvector-length param)))) 148 | (for ([x (in-flvector param)] [i (in-naturals)]) 149 | (real->floating-point-bytes x 4 #f bs (* 4 i))) 150 | (cons 'vector bs)] 151 | [else 152 | (error/no-convert fsym "MySQL" "parameter" param)])) 153 | 154 | ;; ======================================== 155 | 156 | ;; SQL "parsing" 157 | ;; We care about: 158 | ;; - determining whether commands must be prepared (to use binary data) 159 | ;; see http://dev.mysql.com/doc/refman/5.0/en/c-api-prepared-statements.html 160 | ;; - determining what statements are safe for the statement cache 161 | ;; - detecting commands that affect transaction status (maybe implicitly) 162 | ;; see http://dev.mysql.com/doc/refman/5.0/en/implicit-commit.html 163 | 164 | ;; classify-my-sql : string [nat] -> symbol/#f 165 | (define classify-my-sql 166 | (make-sql-classifier #:hash-comments? #t 167 | '(;; Must be prepared 168 | ("SELECT" select) 169 | ("SHOW" show) 170 | 171 | ;; Do not invalidate statement cache 172 | ("INSERT" insert) 173 | ("DELETE" delete) 174 | ("UPDATE" update) 175 | 176 | ;; Explicit transaction commands 177 | ("ROLLBACK WORK TO" rollback-savepoint) 178 | ("ROLLBACK TO" rollback-savepoint) 179 | ("RELEASE SAVEPOINT" release-savepoint) 180 | ("SAVEPOINT" savepoint) 181 | ("START TRANSACTION" start) 182 | ("BEGIN" start) 183 | ("COMMIT" commit) 184 | ("ROLLBACK" rollback) ;; Note: after ROLLBACK TO, etc 185 | ("SET autocommit" set-autocommit) ;; trouble 186 | ;; Note: commit/rollback may immediately start new transaction 187 | 188 | ;; Implicit commit 189 | ("ALTER" implicit-commit) 190 | ("CREATE" implicit-commit) 191 | ("DROP" implicit-commit) 192 | ("RENAME" implicit-commit) 193 | ("TRUNCATE" implicit-commit) 194 | ("LOAD" implicit-commit) 195 | ("LOCK TABLES" implicit-commit) 196 | ("UNLOCK TABLES" implicit-commit)))) 197 | 198 | ;; ======================================== 199 | 200 | (define-type-table (type-list* 201 | typeid->type 202 | describe-typeid) 203 | 204 | (newdecimal decimal 0) 205 | (tiny tinyint 0) 206 | (short smallint 0) 207 | (int24 mediumint 0) 208 | (long integer 0) 209 | (longlong bigint 0) 210 | (float real 0) 211 | (double double 0) 212 | (newdate date 0) 213 | (time time 0) 214 | (datetime datetime 0) 215 | (varchar varchar 0) 216 | (string character 0) 217 | (var-string var-string 0) 218 | (tiny-blob tinyblob 0) 219 | (medium-blob mediumblob 0) 220 | (long-blob longblob 0) 221 | (blob blob 0) 222 | (bit bit 0) 223 | (geometry geometry 0) 224 | (json json 5.7) 225 | (vector vector 9.0)) 226 | 227 | (define type-list 228 | (append (map (lambda (t) (list t 0)) 229 | '(tinytext text mediumtext longtext var-binary)) 230 | type-list*)) 231 | 232 | ;; decimal, date typeids not used (?) 233 | -------------------------------------------------------------------------------- /db-lib/db/private/mysql/main.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/class 3 | racket/tcp 4 | openssl 5 | db/private/generic/interfaces 6 | db/private/generic/common 7 | racket/unix-socket 8 | "connection.rkt") 9 | (provide mysql-connect 10 | mysql-guess-socket-path 11 | mysql-password-hash) 12 | 13 | (define (mysql-connect #:user user 14 | #:database [database #f] 15 | #:password [password #f] 16 | #:server [server #f] 17 | #:port [port #f] 18 | #:socket [socket #f] 19 | #:allow-cleartext-password? [allow-cleartext-password? 'local] 20 | #:ssl [ssl 'no] 21 | #:ssl-context [ssl-context 22 | (case ssl 23 | ((no) #f) 24 | (else (ssl-make-client-context)))] 25 | #:notice-handler [notice-handler void] 26 | #:debug? [debug? #f]) 27 | (let ([connection-options 28 | (+ (if (or server port) 1 0) 29 | (if socket 1 0))]) 30 | (when (> connection-options 1) 31 | (error 'mysql-connect "cannot give both server/port and socket arguments"))) 32 | (let* ([notice-handler 33 | (cond [(procedure? notice-handler) notice-handler] 34 | [else (make-print-notice notice-handler)])] 35 | [c (new connection% 36 | (notice-handler notice-handler) 37 | (custodian-b (make-custodian-box (current-custodian) #t)))]) 38 | (when debug? (send c debug #t)) 39 | (with-handlers 40 | ([exn? (lambda (e) 41 | (send c disconnect* #f) 42 | (raise e))]) 43 | (define transport 44 | (cond [socket 45 | (let ([socket (if (eq? socket 'guess) 46 | (mysql-guess-socket-path) 47 | socket)]) 48 | (let-values ([(in out) (unix-socket-connect socket)]) 49 | (send c attach-to-ports in out))) 50 | 'socket] 51 | [else 52 | (let ([server (or server "localhost")] 53 | [port (or port 3306)]) 54 | (let-values ([(in out) (tcp-connect server port)]) 55 | (send c attach-to-ports in out))) 56 | 'tcp])) 57 | (send c start-connection-protocol database user password transport ssl ssl-context 58 | (and (not socket) (or server "localhost")) allow-cleartext-password?)) 59 | c)) 60 | 61 | ;; make-print-notification : output-port -> number string -> void 62 | (define ((make-print-notice out) code condition) 63 | (fprintf (case out 64 | ((output) (current-output-port)) 65 | ((error) (current-error-port)) 66 | (else out)) 67 | "notice: ~a (MySQL code ~a)\n" condition code)) 68 | 69 | (define socket-paths 70 | (case (system-type) 71 | ((unix) '("/var/run/mysqld/mysqld.sock")) 72 | (else '()))) 73 | 74 | (define (mysql-guess-socket-path) 75 | (guess-socket-path/paths 'mysql-guess-socket-path socket-paths)) 76 | -------------------------------------------------------------------------------- /db-lib/db/private/odbc/dbsystem.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/class 3 | db/private/generic/interfaces 4 | db/private/generic/common 5 | db/private/generic/sql-data 6 | db/private/generic/sql-convert) 7 | (provide dbsystem 8 | field-dvec->field-info 9 | field-dvec->typeid 10 | field-dvec->size 11 | field-dvec->digits 12 | supported-typeid? 13 | classify-odbc-sql) 14 | 15 | (define odbc-dbsystem% 16 | (class* dbsystem-base% (dbsystem<%>) 17 | (define/public (get-short-name) 'odbc) 18 | (define/override (get-type-list) type-list) 19 | (define/public (has-support? x) #f) 20 | 21 | (define/public (get-parameter-handlers param-typeids) 22 | (map get-check param-typeids)) 23 | 24 | (define/public (field-dvecs->typeids dvecs) 25 | (map (lambda (dvec) (vector-ref dvec 1)) dvecs)) 26 | 27 | (define/public (describe-params typeids) 28 | (map describe-typeid typeids)) 29 | 30 | (define/public (describe-fields dvecs) 31 | (for/list ([dvec (in-list dvecs)]) 32 | (describe-typeid (field-dvec->typeid dvec)))) 33 | 34 | (super-new))) 35 | 36 | (define dbsystem 37 | (new odbc-dbsystem%)) 38 | 39 | ;; ---- 40 | 41 | (define (field-dvec->field-info dvec) 42 | `((name . ,(vector-ref dvec 0)) 43 | (typeid . ,(vector-ref dvec 1)) 44 | (size . ,(vector-ref dvec 2)) 45 | (digits . ,(vector-ref dvec 3)))) 46 | 47 | (define (field-dvec->typeid dvec) 48 | (vector-ref dvec 1)) 49 | (define (field-dvec->size dvec) 50 | (vector-ref dvec 2)) 51 | (define (field-dvec->digits dvec) 52 | (vector-ref dvec 3)) 53 | 54 | ;; ---- 55 | 56 | ;; SQL "parsing" 57 | ;; We just care about detecting commands that affect transaction status. 58 | 59 | ;; Since we have no idea what the actual database system is, just cover 60 | ;; standard commands and assume DDL is not transactional. 61 | 62 | ;; classify-odbc-sql : string [nat] -> symbol/#f 63 | (define classify-odbc-sql 64 | (make-sql-classifier #:hash-comments? #t 65 | '(;; Explicit transaction commands 66 | ("ROLLBACK TRANSACTION TO" rollback-savepoint) 67 | ("ROLLBACK WORK TO" rollback-savepoint) 68 | ("ROLLBACK TO" rollback-savepoint) 69 | ("RELEASE" release-savepoint) 70 | ("SAVEPOINT" savepoint) 71 | ("START" start) 72 | ("BEGIN" start) 73 | ("COMMIT" commit) 74 | ("END" commit) 75 | ("ROLLBACK" rollback) ;; Note: after ROLLBACK TO, etc 76 | 77 | ;; Implicit commit 78 | ("ALTER" implicit-commit) 79 | ("CREATE" implicit-commit) 80 | ("DROP" implicit-commit) 81 | ("GRANT" implicit-commit) 82 | ("RENAME" implicit-commit) 83 | ("TRUNCATE" implicit-commit)))) 84 | 85 | ;; ---- 86 | 87 | (define-syntax-rule 88 | (defchecks get-check [(typeid name pred ...) ...] [(*typeid *name *fun) ...]) 89 | (define get-check 90 | (let ([name (mk-check typeid (lambda (z) (or (pred z) ...)) #:contract-parts '(pred ...))] ... 91 | [*name *fun] ...) 92 | (lambda (x) 93 | (case x 94 | ((typeid) name) ... 95 | ((*typeid) *name) ... 96 | (else 97 | (lambda (fsym param) 98 | (error/unsupported-type fsym x)))))))) 99 | 100 | (define (mk-check typeid pred #:contract-parts [ctc-parts #f]) 101 | (lambda (fsym param) 102 | (unless (pred param) 103 | (error/no-convert fsym "ODBC" (typeid->type typeid) param 104 | #:contract (cond [(= (length ctc-parts) 1) 105 | (car ctc-parts)] 106 | [else (cons 'or/c ctc-parts)]))) 107 | param)) 108 | 109 | (define (check-numeric fsym param) 110 | (define (bad note) 111 | (error/no-convert fsym "ODBC" "numeric" param note)) 112 | (unless (and (rational? param) (exact? param)) (bad "(expected exact rational)")) 113 | (let ([scaled (exact->scaled-integer (inexact->exact param))]) 114 | (unless scaled (bad "(bad denominator for exact decimal)")) 115 | (let ([ma (car scaled)] 116 | [ex (cdr scaled)]) 117 | ;; check (abs ma) fits in 16*8 bits, ex fits in char 118 | (unless (<= -128 ex 127) (bad "(scale too large)")) 119 | (unless (< (abs ma) (expt 2 (* 16 8))) (bad "(mantissa too long)")) 120 | (cons ma ex)))) 121 | 122 | (defchecks get-check 123 | [(0 unknown string? bytes? rational? boolean? sql-date? sql-time? sql-timestamp?) 124 | (1 character string?) 125 | (4 integer int32?) 126 | (5 smallint int16?) 127 | (6 float real?) 128 | (7 real real?) 129 | (8 double real?) 130 | (9 datetime sql-timestamp?) 131 | (12 varchar string?) 132 | (91 date sql-date?) 133 | (92 time sql-time?) 134 | (-154 time2 sql-time?) 135 | (93 timestamp sql-timestamp?) 136 | (-1 longvarchar string?) 137 | (-2 binary bytes?) 138 | (-3 varbinary bytes?) 139 | (-4 longvarbinary bytes?) 140 | (-5 bigint int64?) 141 | (-6 tinyint int8?) 142 | (-7 bit1 boolean?) 143 | (-8 wcharacter string?) 144 | (-9 wvarchar string?) 145 | (-10 wlongvarchar string?)] 146 | [(2 numeric check-numeric) 147 | (3 decimal check-numeric)]) 148 | 149 | ;; ---- 150 | 151 | (define-type-table (type-list 152 | typeid->type 153 | describe-typeid) 154 | 155 | (0 unknown 0) 156 | (1 character 0) 157 | (2 numeric 0) 158 | (3 decimal 0) 159 | (4 integer 0) 160 | (5 smallint 0) 161 | (6 float 0) 162 | (7 real 0) 163 | (8 double 0) 164 | (9 datetime 0) 165 | (12 varchar 0) 166 | (91 date 0) 167 | (92 time 0) 168 | (93 timestamp 0) 169 | (-1 longvarchar 0) 170 | (-2 binary 0) 171 | (-3 varbinary 0) 172 | (-4 longvarbinary 0) 173 | (-5 bigint 0) 174 | (-6 tinyint 0) 175 | (-7 bit1 0) ;; not bit(n), always single bit 176 | (-8 wchar 0) 177 | (-9 wvarchar 0) 178 | (-10 wlongvarchar 0) 179 | 180 | ;; Unsupported types 181 | 182 | (101 interval-year #f) 183 | (102 interval-month #f) 184 | (103 interval-day #f) 185 | (104 interval-hour #f) 186 | (105 interval-minute #f) 187 | (106 interval-second #f) 188 | (107 interval-year-month #f) 189 | (108 interval-day-hour #f) 190 | (109 interval-day-minute #f) 191 | (110 interval-day-second #f) 192 | (111 interval-hour-minute #f) 193 | (112 interval-hour-second #f) 194 | (113 interval-minute-second #f) 195 | 196 | ;; SQL Server extensions 197 | (-154 time 0) 198 | ) 199 | 200 | (define (supported-typeid? x) 201 | (case x 202 | ((0 1 2 3 4 5 6 7 8 9 12 91 92 93 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10) #t) 203 | ((-154) #t) 204 | (else #f))) 205 | -------------------------------------------------------------------------------- /db-lib/db/private/odbc/ffi-constants.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (provide (all-defined-out)) 3 | 4 | ;; ============================================================ 5 | 6 | (define SQL_MAX_MESSAGE_LENGTH 512) 7 | (define SQL_MAX_NUMERIC_LEN 16) 8 | 9 | (define SQL_HANDLE_ENV 1) 10 | (define SQL_HANDLE_DBC 2) 11 | (define SQL_HANDLE_STMT 3) 12 | (define SQL_HANDLE_DESC 4) 13 | 14 | (define SQL_DRIVER_NOPROMPT 0) 15 | (define SQL_DRIVER_COMPLETE 1) 16 | (define SQL_DRIVER_PROMPT 2) 17 | (define SQL_DRIVER_COMPLETE_REQUIRED 3) 18 | 19 | (define SQL_IS_POINTER -4) 20 | (define SQL_IS_UINTEGER -5) 21 | (define SQL_IS_INTEGER -6) 22 | (define SQL_IS_USMALLINT -7) 23 | (define SQL_IS_SMALLINT -8) 24 | 25 | (define SQL_ATTR_ODBC_VERSION 200) 26 | (define SQL_OV_ODBC2 2) 27 | (define SQL_OV_ODBC3 3) 28 | 29 | (define SQL_SUCCESS 0) 30 | (define SQL_SUCCESS_WITH_INFO 1) 31 | (define SQL_STILL_EXECUTING 2) 32 | (define SQL_ERROR -1) 33 | (define SQL_INVALID_HANDLE -2) 34 | (define SQL_NEED_DATA 99) 35 | (define SQL_NO_DATA 100) 36 | 37 | (define SQL_NULL_DATA -1) 38 | (define SQL_DATA_AT_EXEC -2) 39 | (define SQL_NO_TOTAL -4) 40 | 41 | (define SQL_UNKNOWN_TYPE 0) 42 | (define SQL_CHAR 1) 43 | (define SQL_NUMERIC 2) 44 | (define SQL_DECIMAL 3) 45 | (define SQL_INTEGER 4) 46 | (define SQL_SMALLINT 5) 47 | (define SQL_FLOAT 6) 48 | (define SQL_REAL 7) 49 | (define SQL_DOUBLE 8) 50 | (define SQL_DATETIME 9) 51 | (define SQL_VARCHAR 12) 52 | (define SQL_TYPE_DATE 91) 53 | (define SQL_TYPE_TIME 92) 54 | (define SQL_TYPE_TIMESTAMP 93) 55 | 56 | (define SQL_DATE 9) 57 | (define SQL_TIME 10) 58 | (define SQL_TIMESTAMP 11) 59 | (define SQL_LONGVARCHAR -1) 60 | (define SQL_BINARY -2) 61 | (define SQL_VARBINARY -3) 62 | (define SQL_LONGVARBINARY -4) 63 | (define SQL_BIGINT -5) 64 | (define SQL_TINYINT -6) 65 | (define SQL_BIT -7) 66 | 67 | (define SQL_WCHAR -8) 68 | (define SQL_WVARCHAR -9) 69 | (define SQL_WLONGVARCHAR -10) 70 | 71 | (define SQL_SS_TIME2 -154) 72 | (define SQL_C_SS_TIME2 #x4000) 73 | 74 | (define SQL_CODE_YEAR 1) 75 | (define SQL_CODE_MONTH 2) 76 | (define SQL_CODE_DAY 3) 77 | (define SQL_CODE_HOUR 4) 78 | (define SQL_CODE_MINUTE 5) 79 | (define SQL_CODE_SECOND 6) 80 | (define SQL_CODE_YEAR_TO_MONTH 7) 81 | (define SQL_CODE_DAY_TO_HOUR 8) 82 | (define SQL_CODE_DAY_TO_MINUTE 9) 83 | (define SQL_CODE_DAY_TO_SECOND 10) 84 | (define SQL_CODE_HOUR_TO_MINUTE 11) 85 | (define SQL_CODE_HOUR_TO_SECOND 12) 86 | (define SQL_CODE_MINUTE_TO_SECOND 13) 87 | 88 | (define SQL_INTERVAL_YEAR (+ 100 SQL_CODE_YEAR)) 89 | (define SQL_INTERVAL_MONTH (+ 100 SQL_CODE_MONTH)) 90 | (define SQL_INTERVAL_DAY (+ 100 SQL_CODE_DAY)) 91 | (define SQL_INTERVAL_HOUR (+ 100 SQL_CODE_HOUR)) 92 | (define SQL_INTERVAL_MINUTE (+ 100 SQL_CODE_MINUTE)) 93 | (define SQL_INTERVAL_SECOND (+ 100 SQL_CODE_SECOND)) 94 | (define SQL_INTERVAL_YEAR_TO_MONTH (+ 100 SQL_CODE_YEAR_TO_MONTH)) 95 | (define SQL_INTERVAL_DAY_TO_HOUR (+ 100 SQL_CODE_DAY_TO_HOUR)) 96 | (define SQL_INTERVAL_DAY_TO_MINUTE (+ 100 SQL_CODE_DAY_TO_MINUTE)) 97 | (define SQL_INTERVAL_DAY_TO_SECOND (+ 100 SQL_CODE_DAY_TO_SECOND)) 98 | (define SQL_INTERVAL_HOUR_TO_MINUTE (+ 100 SQL_CODE_HOUR_TO_MINUTE)) 99 | (define SQL_INTERVAL_HOUR_TO_SECOND (+ 100 SQL_CODE_HOUR_TO_SECOND)) 100 | (define SQL_INTERVAL_MINUTE_TO_SECOND (+ 100 SQL_CODE_MINUTE_TO_SECOND)) 101 | 102 | (define SQL_DATE_LEN 10) 103 | (define SQL_TIME_LEN 8) 104 | (define SQL_TIMESTAMP_LEN 19) 105 | 106 | (define SQL_NULL_HENV 0) 107 | (define SQL_NULL_HDBC 0) 108 | (define SQL_NULL_HSTMT 0) 109 | (define SQL_NULL_HDESC 0) 110 | (define SQL_NULL_HANDLE 0) 111 | 112 | (define SQL_FETCH_NEXT 1) 113 | (define SQL_FETCH_FIRST 2) 114 | 115 | (define SQL_FETCH_LAST 3) 116 | (define SQL_FETCH_PRIOR 4) 117 | (define SQL_FETCH_ABSOLUTE 5) 118 | (define SQL_FETCH_RELATIVE 6) 119 | 120 | (define SQL_CLOSE 0) 121 | (define SQL_DROP 1) 122 | (define SQL_UNBIND 2) 123 | (define SQL_RESET_PARAMS 3) 124 | 125 | (define SQL_COMMIT 0) 126 | (define SQL_ROLLBACK 1) 127 | 128 | (define SQL_C_CHAR SQL_CHAR) 129 | (define SQL_C_LONG SQL_INTEGER) 130 | (define SQL_C_SHORT SQL_SMALLINT) 131 | (define SQL_C_FLOAT SQL_REAL) 132 | (define SQL_C_DOUBLE SQL_DOUBLE) 133 | (define SQL_C_NUMERIC SQL_NUMERIC) 134 | (define SQL_C_DEFAULT 99) 135 | (define SQL_ARD_TYPE -99) 136 | 137 | (define SQL_C_DATE SQL_DATE) 138 | (define SQL_C_TIME SQL_TIME) 139 | (define SQL_C_TIMESTAMP SQL_TIMESTAMP) 140 | (define SQL_C_BINARY SQL_BINARY) 141 | (define SQL_C_BIT SQL_BIT) 142 | (define SQL_C_TINYINT SQL_TINYINT) 143 | #| 144 | (define SQL_C_SLONG (+ SQL_C_LONG SQL_SIGNED_OFFSET)) 145 | (define SQL_C_SSHORT (+ SQL_C_SHORT SQL_SIGNED_OFFSET)) 146 | (define SQL_C_STINYINT (+ SQL_TINYINT SQL_SIGNED_OFFSET)) 147 | (define SQL_C_ULONG (+ SQL_C_LONG SQL_UNSIGNED_OFFSET)) 148 | (define SQL_C_USHORT (+ SQL_C_SHORT SQL_UNSIGNED_OFFSET)) 149 | (define SQL_C_UTINYINT (+ SQL_TINYINT SQL_UNSIGNED_OFFSET)) 150 | |# 151 | 152 | (define SQL_C_WCHAR SQL_WCHAR) 153 | 154 | (define SQL_SIGNED_OFFSET -20) 155 | (define SQL_UNSIGNED_OFFSET -22) 156 | 157 | (define SQL_C_TYPE_DATE SQL_TYPE_DATE) 158 | (define SQL_C_TYPE_TIME SQL_TYPE_TIME) 159 | (define SQL_C_TYPE_TIMESTAMP SQL_TYPE_TIMESTAMP) 160 | 161 | (define SQL_C_INTERVAL_YEAR SQL_INTERVAL_YEAR) 162 | (define SQL_C_INTERVAL_MONTH SQL_INTERVAL_MONTH) 163 | (define SQL_C_INTERVAL_DAY SQL_INTERVAL_DAY) 164 | (define SQL_C_INTERVAL_HOUR SQL_INTERVAL_HOUR) 165 | (define SQL_C_INTERVAL_MINUTE SQL_INTERVAL_MINUTE) 166 | (define SQL_C_INTERVAL_SECOND SQL_INTERVAL_SECOND) 167 | (define SQL_C_INTERVAL_YEAR_TO_MONTH SQL_INTERVAL_YEAR_TO_MONTH) 168 | (define SQL_C_INTERVAL_DAY_TO_HOUR SQL_INTERVAL_DAY_TO_HOUR) 169 | (define SQL_C_INTERVAL_DAY_TO_MINUTE SQL_INTERVAL_DAY_TO_MINUTE) 170 | (define SQL_C_INTERVAL_DAY_TO_SECOND SQL_INTERVAL_DAY_TO_SECOND) 171 | (define SQL_C_INTERVAL_HOUR_TO_MINUTE SQL_INTERVAL_HOUR_TO_MINUTE) 172 | (define SQL_C_INTERVAL_HOUR_TO_SECOND SQL_INTERVAL_HOUR_TO_SECOND) 173 | (define SQL_C_INTERVAL_MINUTE_TO_SECOND SQL_INTERVAL_MINUTE_TO_SECOND) 174 | 175 | (define SQL_C_SBIGINT (+ SQL_BIGINT SQL_SIGNED_OFFSET)) ;; = int64_t 176 | (define SQL_C_SLONG (+ SQL_C_LONG SQL_SIGNED_OFFSET)) ;; = long 177 | (define SQL_C_SSHORT (+ SQL_C_SHORT SQL_SIGNED_OFFSET)) 178 | (define SQL_C_STINYINT (+ SQL_TINYINT SQL_SIGNED_OFFSET)) 179 | (define SQL_C_UBIGINT (+ SQL_BIGINT SQL_UNSIGNED_OFFSET)) 180 | (define SQL_C_ULONG (+ SQL_C_LONG SQL_UNSIGNED_OFFSET)) 181 | (define SQL_C_USHORT (+ SQL_C_SHORT SQL_UNSIGNED_OFFSET)) 182 | (define SQL_C_UTINYINT (+ SQL_TINYINT SQL_UNSIGNED_OFFSET)) 183 | 184 | (define SQL_C_VARBOOKMARK SQL_C_BINARY) 185 | 186 | (define SQL_TYPE_NULL 0) 187 | 188 | (define SQL_PARAM_TYPE_UNKNOWN 0) 189 | (define SQL_PARAM_INPUT 1) 190 | (define SQL_PARAM_INPUT_OUTPUT 2) 191 | (define SQL_RESULT_COL 3) 192 | (define SQL_PARAM_OUTPUT 4) 193 | (define SQL_RETURN_VALUE 5) 194 | 195 | (define SQL_API_SQLDESCRIBEPARAM 58) 196 | 197 | (define SQL_ATTR_AUTOCOMMIT 102) 198 | (define SQL_AUTOCOMMIT_OFF 0) 199 | (define SQL_AUTOCOMMIT_ON 1) 200 | 201 | (define SQL_DEFAULT_TXN_ISOLATION 26) 202 | (define SQL_TXN_ISOLATION_OPTION 72) 203 | (define SQL_ATTR_TXN_ISOLATION 108) 204 | (define SQL_TXN_READ_UNCOMMITTED #x1) 205 | (define SQL_TXN_READ_COMMITTED #x2) 206 | (define SQL_TXN_REPEATABLE_READ #x4) 207 | (define SQL_TXN_SERIALIZABLE #x8) 208 | 209 | (define SQL_DATA_SOURCE_NAME 2) 210 | (define SQL_DRIVER_NAME 6) 211 | (define SQL_DRIVER_VER 7) 212 | (define SQL_ODBC_VER 10) 213 | (define SQL_SERVER_NAME 13) 214 | (define SQL_DBMS_NAME 17) 215 | (define SQL_DBMS_VER 18) 216 | (define SQL_DRIVER_ODBC_VER 77) 217 | 218 | (define SQL_ATTR_APP_PARAM_DESC 10011) 219 | (define SQL_ATTR_APP_ROW_DESC 10010) 220 | (define SQL_DESC_TYPE 1002) 221 | (define SQL_DESC_PRECISION 1005) 222 | (define SQL_DESC_SCALE 1006) 223 | (define SQL_DESC_DATA_PTR 1010) 224 | -------------------------------------------------------------------------------- /db-lib/db/private/odbc/main.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/class 3 | ffi/unsafe/os-thread 4 | db/private/generic/interfaces 5 | db/private/generic/common 6 | db/private/generic/place-client 7 | "connection.rkt" 8 | "dbsystem.rkt" 9 | "ffi.rkt") 10 | (provide odbc-connect 11 | odbc-driver-connect 12 | odbc-data-sources 13 | odbc-drivers) 14 | 15 | (define (odbc-connect #:dsn dsn 16 | #:user [user #f] 17 | #:password [auth #f] 18 | #:notice-handler [notice-handler void] 19 | #:strict-parameter-types? [strict-parameter-types? #f] 20 | #:character-mode [char-mode 'wchar] 21 | #:quirks [quirks '()] 22 | #:use-place [use-place #f]) 23 | (define (connect) 24 | (let ([notice-handler (make-handler notice-handler "notice")]) 25 | (call-with-env 'odbc-connect 26 | (lambda (env) 27 | (call-with-db 'odbc-connect env 28 | (lambda (db) 29 | (let ([status (SQLConnect db dsn user auth)]) 30 | (handle-status* 'odbc-connect status db) 31 | (new connection% 32 | (env env) 33 | (db db) 34 | (notice-handler notice-handler) 35 | (strict-parameter-types? strict-parameter-types?) 36 | (char-mode char-mode) 37 | (quirks quirks))))))))) 38 | (let ([use-place (normalize-use-place use-place)]) 39 | (case use-place 40 | [(place) 41 | (place-connect (list 'odbc dsn user auth strict-parameter-types? char-mode quirks) 42 | odbc-proxy%)] 43 | [(os-thread) 44 | (define c (connect)) 45 | (send c use-os-thread #t) 46 | c] 47 | [else (connect)]))) 48 | 49 | (define (odbc-driver-connect connection-string 50 | #:notice-handler [notice-handler void] 51 | #:strict-parameter-types? [strict-parameter-types? #f] 52 | #:character-mode [char-mode 'wchar] 53 | #:quirks [quirks '()] 54 | #:use-place [use-place #f]) 55 | (define (connect) 56 | (let ([notice-handler (make-handler notice-handler "notice")]) 57 | (call-with-env 'odbc-driver-connect 58 | (lambda (env) 59 | (call-with-db 'odbc-driver-connect env 60 | (lambda (db) 61 | (define status (SQLDriverConnect db connection-string SQL_DRIVER_NOPROMPT)) 62 | (handle-status* 'odbc-driver-connect status db) 63 | (new connection% 64 | (env env) 65 | (db db) 66 | (notice-handler notice-handler) 67 | (strict-parameter-types? strict-parameter-types?) 68 | (char-mode char-mode) 69 | (quirks quirks)))))))) 70 | (let ([use-place (normalize-use-place use-place)]) 71 | (case use-place 72 | [(place) 73 | (place-connect (list 'odbc-driver connection-string strict-parameter-types? char-mode quirks) 74 | odbc-proxy%)] 75 | [(os-thread) 76 | (define c (connect)) 77 | (send c use-os-thread #t) 78 | c] 79 | [else (connect)]))) 80 | 81 | (define (normalize-use-place use-place) 82 | (cond [(eq? use-place #t) 83 | (if (os-thread-enabled?) 'os-thread 'place)] 84 | [else use-place])) 85 | 86 | (define (odbc-data-sources) 87 | (call-with-env 'odbc-data-sources 88 | (lambda (env) 89 | (begin0 90 | (let loop () 91 | (let-values ([(status name description) 92 | (SQLDataSources env SQL_FETCH_NEXT)]) 93 | (cond [(or (= status SQL_SUCCESS) (= status SQL_SUCCESS_WITH_INFO)) 94 | (cons (list name description) (loop))] 95 | [else ;; SQL_NO_DATA 96 | null]))) 97 | (handle-status* 'odbc-data-sources (SQLFreeHandle SQL_HANDLE_ENV env)))))) 98 | 99 | (define (odbc-drivers) 100 | (call-with-env 'odbc-drivers 101 | (lambda (env) 102 | (let ([result 103 | (let loop () 104 | (let-values ([(status name attrs) (SQLDrivers env SQL_FETCH_NEXT)]) 105 | (cond [(or (= status SQL_SUCCESS) (= status SQL_SUCCESS_WITH_INFO)) 106 | (cons (list name (parse-driver-attrs attrs)) (loop))] 107 | [else null])))]) ;; SQL_NO_DATA 108 | (handle-status* 'odbc-drivers (SQLFreeHandle SQL_HANDLE_ENV env)) 109 | result)))) 110 | 111 | (define (parse-driver-attrs buf) 112 | (let* ([attrs (regexp-split #rx"\0" buf)]) 113 | (filter values 114 | (for/list ([s (in-list attrs)] 115 | #:when (positive? (string-length s))) 116 | (let* ([m (regexp-match-positions #rx"=" s)]) 117 | ;; Sometimes (eg iodbc on openbsd), returns ill-formatted attr-buf; just discard 118 | (and m 119 | (let ([=-pos (caar m)]) 120 | (cons (substring s 0 =-pos) (substring s (+ 1 =-pos)))))))))) 121 | 122 | (define odbc-proxy% 123 | (class place-proxy-connection% 124 | (super-new) 125 | (define/override (get-dbsystem) dbsystem))) 126 | 127 | ;; ---- 128 | 129 | ;; Aux functions to free handles on error. 130 | 131 | (define (call-with-env fsym proc) 132 | (let-values ([(status env) (SQLAllocHandle SQL_HANDLE_ENV #f)]) 133 | (with-handlers ([(lambda (e) #t) 134 | (lambda (e) 135 | (SQLFreeHandle SQL_HANDLE_ENV env) 136 | (raise e))]) 137 | (handle-status* fsym status env) 138 | (handle-status* fsym (SQLSetEnvAttr env SQL_ATTR_ODBC_VERSION SQL_OV_ODBC3)) 139 | (proc env)))) 140 | 141 | (define (call-with-db fsym env proc) 142 | (let-values ([(status db) (SQLAllocHandle SQL_HANDLE_DBC env)]) 143 | (with-handlers ([(lambda (e) #t) 144 | (lambda (e) 145 | (SQLFreeHandle SQL_HANDLE_DBC db) 146 | (raise e))]) 147 | (handle-status* fsym status db) 148 | (proc db)))) 149 | -------------------------------------------------------------------------------- /db-lib/db/private/postgresql/main.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/class 3 | racket/tcp 4 | openssl 5 | db/private/generic/interfaces 6 | db/private/generic/common 7 | racket/unix-socket 8 | "connection.rkt") 9 | (provide postgresql-connect 10 | postgresql-guess-socket-path 11 | postgresql-password-hash) 12 | 13 | (define (postgresql-connect #:user user 14 | #:database database 15 | #:password [password #f] 16 | #:server [server #f] 17 | #:port [port #f] 18 | #:socket [socket #f] 19 | #:allow-cleartext-password? [allow-cleartext-password? 'local] 20 | #:ssl [ssl 'no] 21 | #:ssl-context [ssl-context 22 | (case ssl 23 | ((no) #f) 24 | (else (ssl-make-client-context)))] 25 | #:notice-handler [notice-handler void] 26 | #:notification-handler [notification-handler void] 27 | #:debug? [debug? #f]) 28 | (let ([connection-options 29 | (+ (if (or server port) 1 0) 30 | (if socket 1 0))] 31 | [notice-handler (make-handler notice-handler "notice")] 32 | [notification-handler 33 | (if (procedure? notification-handler) 34 | notification-handler 35 | (make-print-notification notification-handler))] 36 | [socket 37 | (if (eq? socket 'guess) 38 | (postgresql-guess-socket-path) 39 | socket)] 40 | [server (or server "localhost")] 41 | [port (or port 5432)]) 42 | (when (> connection-options 1) 43 | (error 'postgresql-connect "cannot give both server/port and socket arguments")) 44 | (define (connect&attach c) 45 | (define-values (in out local?) 46 | (cond 47 | [socket 48 | (define-values (in out) 49 | (unix-socket-connect socket)) 50 | (values in out #t)] 51 | [else 52 | (define-values (in out) 53 | (tcp-connect server port)) 54 | (values in out (equal? server "localhost"))])) 55 | (send c attach-to-ports in out ssl ssl-context (if socket #f server)) 56 | local?) 57 | (let ([c (new connection% 58 | (notice-handler notice-handler) 59 | (notification-handler notification-handler) 60 | (allow-cleartext-password? allow-cleartext-password?) 61 | (custodian-b (make-custodian-box (current-custodian) #t)) 62 | (connect&attach-proc connect&attach))]) 63 | (when debug? (send c debug #t)) 64 | (with-handlers ([exn? (lambda (e) 65 | (send c disconnect* #f) 66 | (raise e))]) 67 | (define local? (connect&attach c)) 68 | (send c start-connection-protocol database user password local?)) 69 | c))) 70 | 71 | (define socket-paths 72 | (case (system-type) 73 | ((unix) '("/var/run/postgresql/.s.PGSQL.5432")) 74 | (else '()))) 75 | 76 | (define (postgresql-guess-socket-path) 77 | (guess-socket-path/paths 'postgresql-guess-socket-path socket-paths)) 78 | 79 | ;; make-print-notification : output-port -> string -> void 80 | (define ((make-print-notification out) channel payload) 81 | (fprintf (case out 82 | ((output) (current-output-port)) 83 | ((error) (current-error-port)) 84 | (else out)) 85 | "notification: ~a ~a\n" channel payload)) 86 | 87 | (define (postgresql-password-hash user password) 88 | (bytes->string/latin-1 (password-hash user password))) 89 | -------------------------------------------------------------------------------- /db-lib/db/private/postgresql/util.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/serialize 3 | racket/string 4 | racket/contract/base 5 | racket/class 6 | db/private/generic/interfaces 7 | db/util/private/geometry) 8 | (provide (all-defined-out)) 9 | 10 | ;; inet, cidr = family:byte bits:byte is_cidr:byte addrlen:byte addr:be-integer 11 | ;; is_cidr is ignored 12 | 13 | ;; box = x1 y1 x2 y2 (all float8) 14 | ;; circle = x y rad (all float8) 15 | ;; line = not yet implemented 16 | ;; lseg = x1 y1 x2 y2 (all float8) 17 | ;; path = closed?:byte #points:int4 (x y : float8)* 18 | ;; point = x y (all float8) 19 | ;; polygon = #points:int4 (x y : float8)* 20 | 21 | (serializable-struct pg-box (ne sw) 22 | #:transparent 23 | #:guard (lambda (ne sw _n) 24 | (let ([x1 (point-x ne)] 25 | [x2 (point-x sw)] 26 | [y1 (point-y ne)] 27 | [y2 (point-y sw)]) 28 | (values (point (max x1 x2) (max y1 y2)) 29 | (point (min x1 x2) (min y1 y2)))))) 30 | 31 | (serializable-struct pg-circle (center radius) 32 | #:transparent 33 | #:guard (lambda (center radius _n) 34 | (values center (exact->inexact radius)))) 35 | 36 | (serializable-struct pg-path (closed? points) 37 | #:transparent 38 | #:guard (lambda (closed? points _n) 39 | (values (and closed? #t) 40 | points))) 41 | 42 | (serializable-struct pg-array (dimensions dimension-lengths dimension-lower-bounds contents) 43 | #:transparent 44 | #:guard (lambda (ndim counts lbounds vals _n) 45 | (unless (= (length counts) ndim) 46 | (error* 'pg-array "list for dimension lengths has wrong length" 47 | "expected length" ndim 48 | '("got" value) counts)) 49 | (unless (= (length lbounds) ndim) 50 | (error* 'pg-array "list for dimension lower bounds has wrong length" 51 | "expected length" ndim 52 | '("got" value) lbounds)) 53 | (when (zero? ndim) 54 | (unless (equal? vals '#()) 55 | (error* 'pg-array 56 | "bad array contents for zero-dimensional array" 57 | '("contents" value) vals))) 58 | (let loop ([counts* counts] [vals* vals]) 59 | (when (pair? counts*) 60 | (unless (and (vector? vals*) 61 | (= (vector-length vals*) (car counts*))) 62 | (error 'pg-array "bad array contents: ~e" vals)) 63 | (for ([sub (in-vector vals*)]) 64 | (loop (cdr counts*) sub)))) 65 | (values ndim counts lbounds vals))) 66 | 67 | (define (pg-array-ref arr . indexes) 68 | (unless (= (pg-array-dimensions arr) (length indexes)) 69 | (error* 'pg-array-ref "wrong number of indexes" 70 | "expected number" (pg-array-dimensions arr) 71 | '("got" value) indexes)) 72 | (let* ([counts (pg-array-dimension-lengths arr)] 73 | [lbounds (pg-array-dimension-lower-bounds arr)] 74 | [ubounds (map (lambda (c lb) (+ c lb -1)) counts lbounds)]) 75 | (unless (for/and ([index indexes] [lbound lbounds] [ubound ubounds]) 76 | (<= lbound index ubound)) 77 | (error* 'pg-array-ref "index out of range" 78 | '("index" value) indexes 79 | "valid range" (string-join (for/list ([lbound lbounds] [ubound ubounds]) 80 | (format "[~a,~a]" lbound ubound)) 81 | ", "))) 82 | (let loop ([indexes (map - indexes lbounds)] 83 | [vals (pg-array-contents arr)]) 84 | (cond [(pair? indexes) 85 | (let ([index (car indexes)]) 86 | (loop (cdr indexes) 87 | (vector-ref vals index)))] 88 | [else vals])))) 89 | 90 | (define (pg-array->list arr) 91 | (unless (member (pg-array-dimensions arr) '(0 1)) 92 | (raise-type-error 'pg-array->list "pg-array of dimension 0 or 1" arr)) 93 | (vector->list (pg-array-contents arr))) 94 | 95 | (define (list->pg-array lst) 96 | (cond [(zero? (length lst)) 97 | (pg-array 0 '() '() '#())] 98 | [else (pg-array 1 (list (length lst)) '(1) (list->vector lst))])) 99 | 100 | (serializable-struct pg-empty-range () #:transparent) 101 | (serializable-struct pg-range (lb includes-lb? ub includes-ub?) #:transparent) 102 | 103 | (define (pg-range-or-empty? v) 104 | (or (pg-empty-range? v) (pg-range? v))) 105 | 106 | (define (uuid? x) 107 | (define uuid-rx 108 | #px"^[[:xdigit:]]{8}-[[:xdigit:]]{4}-[[:xdigit:]]{4}-[[:xdigit:]]{4}-[[:xdigit:]]{12}$") 109 | (and (string? x) (regexp-match? uuid-rx x))) 110 | 111 | (struct pg-custom-type (typeid typename basetype recv-convert send-convert array-typeid)) 112 | 113 | (define postgresql-connection<%> 114 | (interface () 115 | [add-custom-types 116 | (->m (listof pg-custom-type?) void?)] 117 | [async-message-evt 118 | (->m evt?)] 119 | [cancel 120 | (->m void?)] 121 | )) 122 | -------------------------------------------------------------------------------- /db-lib/db/private/sqlite3/place.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/contract/base 3 | racket/class 4 | ffi/unsafe/os-thread 5 | db/base 6 | db/private/generic/place-client 7 | (rename-in db/private/sqlite3/main 8 | [sqlite3-connect pre:sqlite3-connect]) 9 | db/private/sqlite3/dbsystem) 10 | 11 | (define (sqlite3-connect #:database path 12 | #:mode [mode 'read/write] 13 | #:busy-retry-delay [busy-retry-delay 0.1] 14 | #:busy-retry-limit [busy-retry-limit 10] 15 | #:debug? [debug? #f] 16 | #:use-place [use-place #f]) 17 | (define (connect) 18 | (pre:sqlite3-connect #:database path 19 | #:mode mode 20 | #:busy-retry-delay busy-retry-delay 21 | #:busy-retry-limit busy-retry-limit 22 | #:debug? debug?)) 23 | (let ([use-place 24 | (cond [(eq? use-place #t) 25 | (if (os-thread-enabled?) 'os-thread 'place)] 26 | [else use-place])]) 27 | (case use-place 28 | [(place) 29 | (place-connect (list 'sqlite3 path mode busy-retry-delay busy-retry-limit) 30 | sqlite-place-proxy%)] 31 | [(os-thread) 32 | (define c (connect)) 33 | (send c use-os-thread #t) 34 | c] 35 | [else (connect)]))) 36 | 37 | (define sqlite-place-proxy% 38 | (class place-proxy-connection% 39 | (super-new) 40 | (define/override (get-dbsystem) dbsystem))) 41 | 42 | (provide sqlite3-connect 43 | sqlite3-available?) 44 | -------------------------------------------------------------------------------- /db-lib/db/sqlite3.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/contract/base 3 | db/base 4 | db/private/sqlite3/place) 5 | 6 | ;; FIXME: Contracts duplicated at main.rkt 7 | (provide/contract 8 | [sqlite3-connect 9 | (->* (#:database (or/c path-string? 'memory 'temporary)) 10 | (#:mode (or/c 'read-only 'read/write 'create) 11 | #:busy-retry-limit (or/c exact-nonnegative-integer? +inf.0) 12 | #:busy-retry-delay (and/c rational? (not/c negative?)) 13 | #:use-place (or/c boolean? 'place 'os-thread) 14 | #:debug? any/c) 15 | connection?)] 16 | [sqlite3-available? 17 | (-> boolean?)]) 18 | -------------------------------------------------------------------------------- /db-lib/db/unsafe/sqlite3.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/class 3 | db/private/sqlite3/connection) 4 | (provide 5 | (protect-out sqlite3-load-extension 6 | sqlite3-create-function 7 | sqlite3-create-aggregate)) 8 | 9 | (define (sqlite3-load-extension c ext-path) 10 | (define who 'sqlite3-load-extension) 11 | (unless (is-a? c connection%) 12 | (raise-argument-error who "sqlite3 connection" 0 c ext-path)) 13 | (unless (path-string? ext-path) 14 | (raise-argument-error who "path-string?" 1 c ext-path)) 15 | (send c unsafe-load-extension who ext-path) 16 | (void)) 17 | 18 | (define (sqlite3-create-function c name arity proc) 19 | (define who 'sqlite3-create-function) 20 | (define (bad index expected) 21 | (raise-argument-error who expected index c name arity proc)) 22 | (unless (is-a? c connection%) 23 | (bad 0 "sqlite3 connection")) 24 | (unless (or (string? name) (symbol? name)) 25 | (bad 1 "(or/c string? symbol?)")) 26 | (unless (or (exact-nonnegative-integer? arity) (eq? arity #f)) 27 | (bad 2 "(or/c exact-nonnegative-integer? #f)")) 28 | (unless (procedure? proc) 29 | (bad 3 "procedure?")) 30 | (let ([name (if (symbol? name) (symbol->string name) name)]) 31 | (send c unsafe-create-function who name arity proc)) 32 | (void)) 33 | 34 | (define (sqlite3-create-aggregate c name arity init step final) 35 | (define who 'sqlite3-create-aggregate) 36 | (define (bad index expected) 37 | (raise-argument-error who expected index c name arity step final init)) 38 | (unless (is-a? c connection%) 39 | (bad 0 "sqlite3 connection")) 40 | (unless (or (string? name) (symbol? name)) 41 | (bad 1 "(or/c string? symbol?)")) 42 | (unless (or (exact-nonnegative-integer? arity) (eq? arity #f)) 43 | (bad 2 "(or/c exact-nonnegative-integer? #f)")) 44 | (unless (procedure? step) 45 | (bad 3 "procedure?")) 46 | (unless (procedure? final) 47 | (bad 4 "procedure?")) 48 | (let ([name (if (symbol? name) (symbol->string name) name)]) 49 | (send c unsafe-create-aggregate who name arity step final init)) 50 | (void)) 51 | -------------------------------------------------------------------------------- /db-lib/db/util/cassandra.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/contract/base 3 | (only-in "../private/cassandra/connection.rkt" cassandra-consistency) 4 | (only-in "../private/cassandra/message.rkt" consistency-symbols)) 5 | 6 | (provide/contract 7 | [cassandra-consistency 8 | (parameter/c (apply or/c consistency-symbols))]) 9 | -------------------------------------------------------------------------------- /db-lib/db/util/datetime.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/contract/base 3 | racket/match 4 | (prefix-in srfi: srfi/19) 5 | db/private/generic/sql-data) 6 | 7 | (define (sql-datetime->srfi-date datetime) 8 | (match datetime 9 | [(struct sql-date (year month day)) 10 | (srfi:make-date 0 0 0 0 day month year 0)] 11 | [(struct sql-time (hour minute second nanosecond tz)) 12 | (srfi:make-date nanosecond second minute hour 1 1 0 (or tz 0))] 13 | [(struct sql-timestamp (year month day hour minute second nanosecond tz)) 14 | (srfi:make-date nanosecond second minute hour day month year (or tz 0))])) 15 | 16 | (define (srfi-date->sql-date date) 17 | (make-sql-date (srfi:date-year date) 18 | (srfi:date-month date) 19 | (srfi:date-day date))) 20 | 21 | (define (srfi-date->sql-time* date tz? ns) 22 | (make-sql-time (srfi:date-hour date) 23 | (srfi:date-minute date) 24 | (srfi:date-second date) 25 | (or ns (srfi:date-nanosecond date)) 26 | (and tz? (srfi:date-zone-offset date)))) 27 | 28 | (define (srfi-date->sql-time date [ns #f]) 29 | (srfi-date->sql-time* date #f ns)) 30 | 31 | (define (srfi-date->sql-time-tz date [ns #f]) 32 | (srfi-date->sql-time* date #t ns)) 33 | 34 | (define (srfi-date->sql-timestamp* date tz? ns) 35 | (make-sql-timestamp (srfi:date-year date) 36 | (srfi:date-month date) 37 | (srfi:date-day date) 38 | (srfi:date-hour date) 39 | (srfi:date-minute date) 40 | (srfi:date-second date) 41 | (or ns (srfi:date-nanosecond date)) 42 | (and tz? (srfi:date-zone-offset date)))) 43 | 44 | (define (srfi-date->sql-timestamp date [ns #f]) 45 | (srfi-date->sql-timestamp* date #f ns)) 46 | 47 | (define (srfi-date->sql-timestamp-tz date [ns #f]) 48 | (srfi-date->sql-timestamp* date #t ns)) 49 | 50 | (define (sql-day-time-interval->seconds x) 51 | (+ (* (sql-interval-hours x) 60 60) 52 | (* (sql-interval-minutes x) 60) 53 | (sql-interval-seconds x) 54 | (/ (sql-interval-nanoseconds x) #i1e9))) 55 | 56 | ;; ============================================================ 57 | 58 | ;; Note: MySQL allows 0 month, 0 day, etc. 59 | 60 | (provide/contract 61 | [sql-datetime->srfi-date 62 | (-> (or/c sql-date? sql-time? sql-timestamp?) 63 | srfi:date?)] 64 | [srfi-date->sql-date 65 | (-> srfi:date? sql-date?)] 66 | [srfi-date->sql-time 67 | (->* (srfi:date?) ((or/c exact-nonnegative-integer? #f)) 68 | sql-time?)] 69 | [srfi-date->sql-time-tz 70 | (->* (srfi:date?) ((or/c exact-nonnegative-integer? #f)) 71 | sql-time?)] 72 | [srfi-date->sql-timestamp 73 | (->* (srfi:date?) ((or/c exact-nonnegative-integer? #f)) 74 | sql-timestamp?)] 75 | [srfi-date->sql-timestamp-tz 76 | (->* (srfi:date?) ((or/c exact-nonnegative-integer? #f)) 77 | sql-timestamp?)] 78 | 79 | [sql-day-time-interval->seconds 80 | (-> sql-day-time-interval? rational?)]) 81 | -------------------------------------------------------------------------------- /db-lib/db/util/geometry.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/contract/base 3 | "private/geometry.rkt") 4 | 5 | (provide/contract 6 | [struct point ([x real?] [y real?])] 7 | [struct line-string ([points (listof point?)])] 8 | [struct polygon ([exterior linear-ring?] 9 | [interiors (listof linear-ring?)])] 10 | [struct multi-point ([elements (listof point?)])] 11 | [struct multi-line-string ([elements (listof line-string?)])] 12 | [struct multi-polygon ([elements (listof polygon?)])] 13 | [struct geometry-collection ([elements (listof geometry2d?)])] 14 | 15 | [line? (-> any/c boolean?)] 16 | [linear-ring? (-> any/c boolean?)] 17 | [geometry2d? (-> any/c boolean?)] 18 | 19 | [geometry->wkb 20 | (->* (geometry2d?) 21 | (#:big-endian? any/c) 22 | bytes?)] 23 | [wkb->geometry 24 | (->* (bytes?) 25 | (exact-nonnegative-integer? 26 | exact-nonnegative-integer?) 27 | geometry2d?)]) 28 | -------------------------------------------------------------------------------- /db-lib/db/util/mysql.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/contract/base 3 | json) 4 | (provide mysql-json? 5 | (contract-out 6 | [mysql-json 7 | (-> jsexpr? mysql-json?)])) 8 | 9 | (module private racket/base 10 | (provide (struct-out mysql-json)) 11 | (struct mysql-json (bytes) #:transparent)) 12 | 13 | (require (rename-in (submod "." private) 14 | [mysql-json make-mysql-json])) 15 | 16 | (define (mysql-json jsexpr) 17 | (make-mysql-json (jsexpr->bytes jsexpr))) 18 | -------------------------------------------------------------------------------- /db-lib/db/util/postgresql.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/contract/base 3 | db/private/generic/interfaces 4 | "private/geometry.rkt" 5 | (rename-in db/private/postgresql/util 6 | [pg-custom-type make-custom-type])) 7 | 8 | (define (pg-custom-type typeid name [base-type #f] 9 | #:recv [recv-convert values] 10 | #:send [send-convert values] 11 | #:array [array-typeid #f]) 12 | (make-custom-type typeid name base-type recv-convert send-convert array-typeid)) 13 | 14 | (provide postgresql-connection<%>) 15 | (provide/contract 16 | [pg-custom-type? 17 | (-> any/c boolean?)] 18 | [pg-custom-type 19 | (->* [exact-nonnegative-integer? 20 | symbol?] 21 | [(or/c #f symbol? exact-nonnegative-integer?) 22 | #:recv (or/c #f (procedure-arity-includes/c 1)) 23 | #:send (or/c #f (procedure-arity-includes/c 1)) 24 | #:array (or/c #f exact-nonnegative-integer?)] 25 | any)] 26 | [struct pg-box ([ne point?] [sw point?])] 27 | [struct pg-circle ([center point?] [radius (and/c real? (not/c negative?))])] 28 | [struct pg-path ([closed? any/c] [points (listof point?)])] 29 | 30 | [struct pg-array ([dimensions exact-nonnegative-integer?] 31 | [dimension-lengths (listof exact-positive-integer?)] 32 | [dimension-lower-bounds (listof exact-integer?)] 33 | [contents vector?])] 34 | [pg-array-ref 35 | (->* (pg-array?) () #:rest (non-empty-listof exact-integer?) any)] 36 | [pg-array->list 37 | (-> pg-array? list?)] 38 | [list->pg-array 39 | (-> list? pg-array?)] 40 | 41 | [struct pg-empty-range ()] 42 | [struct pg-range ([lb any/c] 43 | [includes-lb? boolean?] 44 | [ub any/c] 45 | [includes-ub? boolean?])] 46 | [pg-range-or-empty? (-> any/c boolean?)] 47 | [uuid? (-> any/c boolean?)]) 48 | -------------------------------------------------------------------------------- /db-lib/db/util/private/geometry.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/list) 3 | (provide (all-defined-out)) 4 | 5 | #| 6 | Geometry according to mysql: 7 | abstract Geometry 8 | - Point = (x, y) 9 | - abstract Curve 10 | - LineString = (list of points) 11 | - predicate Line 12 | - predicate LinearRing (closed and non-self-intersecting, bleh) 13 | - abstract Surface 14 | - Polygon (defined by LinearRings, bleh) 15 | = exterior ring, list of interior rings 16 | - GeometryCollection = (list of geometry values) 17 | - MultiPoint = (list of points) 18 | - abstract MultiCurve 19 | - MultiLineString = (list of line strings) 20 | - abstract MultiSurface 21 | - MultiPolygon = (list of polygons) 22 | 23 | every geometric value has an associated Spacial Reference System (SRID), ignored by mysql 24 | 25 | Geometry according to postgis: 26 | 27 | same as above, but with coordinate variants: eg pointm = (x, y, m) 28 | |# 29 | 30 | (struct point (x y) 31 | #:transparent 32 | #:guard (lambda (x y _n) 33 | (values (exact->inexact x) 34 | (exact->inexact y)))) 35 | 36 | (struct line-string (points) 37 | #:transparent) 38 | 39 | (define (line? x) 40 | (and (line-string? x) 41 | (let ([points (line-string-points x)]) 42 | (and (= 2 (length points)) 43 | (not (equal? (first points) (second points))))))) 44 | 45 | (define (linear-ring? x) 46 | (and (line-string? x) 47 | (let ([points (line-string-points x)]) 48 | ;; FIXME: require at least ??? points 49 | (equal? (first points) (last points))))) 50 | 51 | (struct polygon (exterior interiors) 52 | #:transparent) 53 | 54 | (struct multi-point (elements) 55 | #:transparent) 56 | 57 | (struct multi-line-string (elements) 58 | #:transparent) 59 | 60 | (struct multi-polygon (elements) 61 | #:transparent) 62 | 63 | (struct geometry-collection (elements) 64 | #:transparent) 65 | 66 | (define (geometry2d? x) 67 | (or (point? x) 68 | (line-string? x) 69 | (polygon? x) 70 | (multi-point? x) 71 | (multi-line-string? x) 72 | (multi-polygon? x) 73 | (geometry-collection? x))) 74 | 75 | ;; ---------------------------------------- 76 | 77 | ;; Based on OGC 06-103r4 78 | 79 | (define (wkb->geometry b [start 0] [end (bytes-length b)]) 80 | (bytes->geometry 'wkb->geometry b start end #:srid? #f)) 81 | 82 | (define (bytes->geometry who b [start 0] [end (bytes-length b)] 83 | #:srid? [srid? #f]) 84 | (define (get-byte) 85 | (begin0 (bytes-ref b start) 86 | (set! start (+ start 1)))) 87 | (define (get-uint be?) 88 | (begin0 (integer-bytes->integer b #f be? start (+ start 4)) 89 | (set! start (+ start 4)))) 90 | (define (get-multi n get-X) 91 | (for/list ([i (in-range n)]) (get-X))) 92 | (define (get-geometry) 93 | (let ([srid (and srid? (get-uint #f))] ;; FIXME: store srid 94 | [be? (zero? (get-byte))]) 95 | (define (get-double) 96 | (begin0 (floating-point-bytes->real b be? start (+ start 8)) 97 | (set! start (+ start 8)))) 98 | (define (get-point) 99 | (let* ([x (get-double)] 100 | [y (get-double)]) 101 | (point x y))) 102 | (define (get-linear-ring) 103 | (let ([len (get-uint be?)]) 104 | (line-string (get-multi len get-point)))) 105 | (let ([type (get-uint be?)]) 106 | (case type 107 | ((1) (get-point)) 108 | ((2) (let ([points (get-multi (get-uint be?) get-point)]) 109 | (line-string points))) 110 | ((3) (let ([rings (get-multi (get-uint be?) get-linear-ring)]) 111 | (when (null? rings) 112 | (error who "polygon with zero rings")) 113 | (polygon (car rings) (cdr rings)))) 114 | ((4 5 6 7) (let ([constructor 115 | (case type 116 | ((4) multi-point) 117 | ((5) multi-line-string) 118 | ((6) multi-polygon) 119 | ((7) geometry-collection))] 120 | [elements (get-multi (get-uint be?) get-geometry)]) 121 | (constructor elements))) 122 | (else 123 | (error who "unsupported geometry type: ~s" type)))))) 124 | (begin0 (get-geometry) 125 | (unless (= start end) 126 | (error who "~s bytes left over" (- end start))))) 127 | 128 | ;; ---- 129 | 130 | (define (geometry->wkb g 131 | #:big-endian? [be? (system-big-endian?)]) 132 | (geometry->bytes 'geometry->wkb g 133 | #:big-endian? be? 134 | #:srid? #f)) 135 | 136 | (define (geometry->bytes who g 137 | #:big-endian? [be? (system-big-endian?)] 138 | #:srid? [srid? #f]) 139 | (define out (open-output-bytes)) 140 | (define (put-uint n) 141 | (write-bytes (integer->integer-bytes n 4 #f be?) out)) 142 | (define (put-double x) 143 | (write-bytes (real->floating-point-bytes x 8 be?) out)) 144 | (define (put-point g) 145 | (put-double (point-x g)) 146 | (put-double (point-y g))) 147 | (define (put-line-string g) 148 | (let ([points (line-string-points g)]) 149 | (put-uint (length points)) 150 | (for ([p (in-list points)]) 151 | (put-point p)))) 152 | (define (put-collection lst) 153 | (put-uint (length lst)) 154 | (for ([g (in-list lst)]) 155 | (put-geometry g))) 156 | (define (put-geometry g) 157 | (when srid? (put-uint 0)) ;; FIXME 158 | (write-byte (if be? 0 1) out) 159 | (cond [(point? g) 160 | (put-uint 1) 161 | (put-point g)] 162 | [(line-string? g) 163 | (put-uint 2) 164 | (put-line-string g)] 165 | [(polygon? g) 166 | (put-uint 3) 167 | (let ([rings (cons (polygon-exterior g) (polygon-interiors g))]) 168 | (put-uint (length rings)) 169 | (for ([ring (in-list rings)]) 170 | (put-line-string ring)))] 171 | [(multi-point? g) 172 | (put-uint 4) 173 | (put-collection (multi-point-elements g))] 174 | [(multi-line-string? g) 175 | (put-uint 5) 176 | (put-collection (multi-line-string-elements g))] 177 | [(multi-polygon? g) 178 | (put-uint 6) 179 | (put-collection (multi-polygon-elements g))] 180 | [(geometry-collection? g) 181 | (put-uint 7) 182 | (put-collection (geometry-collection-elements g))] 183 | [else 184 | (error who "unsupported geometry type: ~e" g)])) 185 | (put-geometry g) 186 | (get-output-bytes out)) 187 | 188 | ;; FIXME: define WKT functions? 189 | ;; FIXME: eventually, integrate with geos? 190 | -------------------------------------------------------------------------------- /db-lib/db/util/testing.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/contract 3 | racket/class 4 | ffi/unsafe/atomic 5 | db/private/generic/interfaces 6 | db/private/generic/common) 7 | 8 | (define high-latency-connection% 9 | (class* locking% (connection<%>) 10 | (init-private connection 11 | latency 12 | sleep-atomic?) 13 | (inherit call-with-lock) 14 | (super-new) 15 | 16 | (define-syntax-rule (define-forward defmethod (sleep-factor method arg ...) ...) 17 | (begin 18 | (defmethod (method arg ...) 19 | (call-with-lock 'method 20 | (lambda () 21 | (let ([c connection]) 22 | (unless c (error/not-connected 'method)) 23 | (when (positive? sleep-factor) 24 | (if sleep-atomic? 25 | (call-as-atomic (lambda () (sleep (* sleep-factor latency)))) 26 | (sleep (* sleep-factor latency)))) 27 | (send c method arg ...))))) 28 | ...)) 29 | 30 | (define-forward define/public 31 | (0 get-dbsystem) 32 | (2 query fsym stmt cursor?) ;; 2 because may require implicit prepare 33 | (1 prepare fsym stmt close-on-exec?) 34 | (1 fetch/cursor fsym stmt fetch-size) 35 | (0 get-base) 36 | (0 free-statement stmt need-lock?) 37 | (0 transaction-status fsym) 38 | (1 start-transaction fsym isolation cwt?) 39 | (1 end-transaction fsym mode cwt?) 40 | (1 list-tables fsym schema)) 41 | 42 | (define/override (connected?) (and connection (send connection connected?))) 43 | 44 | (define/public (disconnect) 45 | (set! connection #f)))) 46 | 47 | (define (high-latency-connection connection latency 48 | #:sleep-atomic? [sleep-atomic? #f]) 49 | (new high-latency-connection% 50 | [connection connection] 51 | [latency latency] 52 | [sleep-atomic? sleep-atomic?])) 53 | 54 | (provide/contract 55 | [high-latency-connection 56 | (->* (connection? (>=/c 0)) 57 | (#:sleep-atomic? any/c) 58 | connection?)]) 59 | -------------------------------------------------------------------------------- /db-lib/info.rkt: -------------------------------------------------------------------------------- 1 | #lang setup/infotab 2 | 3 | (define version "1.11") 4 | 5 | (define collection 'multi) 6 | (define deps '("srfi-lite-lib" 7 | ["base" #:version "8.15.0.2"] 8 | "unix-socket-lib" 9 | ["sasl-lib" #:version "1.1"])) 10 | 11 | (define pkg-desc "implementation (no documentation) part of \"db\"") 12 | 13 | (define pkg-authors '(ryanc)) 14 | 15 | (define license 16 | '(Apache-2.0 OR MIT)) 17 | -------------------------------------------------------------------------------- /db-test/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection 'multi) 4 | 5 | (define deps '("base" 6 | "db-lib" 7 | "rackunit-lib" 8 | "web-server-lib")) 9 | 10 | (define pkg-desc "tests for \"db\"") 11 | 12 | (define pkg-authors '(ryanc)) 13 | (define build-deps '("srfi-lite-lib")) 14 | (define update-implies '("db-lib")) 15 | 16 | (define license 17 | '(Apache-2.0 OR MIT)) 18 | -------------------------------------------------------------------------------- /db-test/tests/db/all-tests.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/match 3 | racket/list 4 | racket/cmdline 5 | racket/file 6 | racket/place 7 | racket/runtime-path 8 | rackunit 9 | rackunit/text-ui 10 | racket/unit 11 | ffi/unsafe/os-thread 12 | db 13 | "config.rkt" 14 | (prefix-in db- 15 | (combine-in "db/connection.rkt" 16 | "db/query.rkt" 17 | "db/sql-types.rkt" 18 | "db/special.rkt" 19 | "db/concurrent.rkt"))) 20 | (provide (all-defined-out)) 21 | 22 | #| 23 | 24 | RUNNING THE TESTS 25 | ----------------- 26 | 27 | 0) To run the generic tests (ie, those that don't require a db 28 | connection): 29 | 30 | raco test -c tests/db/gen 31 | 32 | 1) Default test configuration. 33 | 34 | To run the default tests (ie, the sqlite3 tests), 35 | simply execute this file with no arguments: 36 | 37 | racket -l tests/db/all-tests 38 | 39 | This is how DrDr runs the file---we assume the machine running DrDr 40 | has sqlite installed. 41 | 42 | 2) Custom test configuration. 43 | 44 | First, set up the testing environment as described in the following 45 | subsections. 46 | 47 | Then, run the tests with the following command line: 48 | 49 | racket -l tests/db/all-tests -- -g