├── .github ├── FUNDING.yml └── workflows │ └── push.yml ├── .gitignore ├── README.md ├── ci ├── deploy.gpg └── docs.sh ├── deta-doc ├── LICENSE ├── deta.scrbl ├── info.rkt └── tutorial-log.rktd ├── deta-lib ├── LICENSE ├── info.rkt ├── main.rkt ├── private │ ├── ast.rkt │ ├── connection.rkt │ ├── dialect │ │ ├── dialect.rkt │ │ ├── operator.rkt │ │ ├── postgresql.rkt │ │ ├── sqlite3.rkt │ │ ├── standard-reserved-words.rktd │ │ └── standard.rkt │ ├── entity.rkt │ ├── field.rkt │ ├── meta.rkt │ ├── query.rkt │ ├── schema.rkt │ └── type.rkt ├── query.rkt ├── reflect.rkt ├── schema.rkt └── type.rkt ├── deta-lint-lib ├── examples │ ├── example.rkt │ └── info.rkt ├── info.rkt └── review.rkt ├── deta-test ├── LICENSE ├── deta │ ├── common.rkt │ ├── entity.rkt │ ├── query.rkt │ ├── schema.rkt │ ├── sql-postgresql.rkt │ ├── sql-sqlite3.rkt │ └── type.rkt └── info.rkt ├── deta ├── LICENSE └── info.rkt └── examples ├── books.rkt ├── issue-58.rkt └── json.rkt /.github/FUNDING.yml: -------------------------------------------------------------------------------- 1 | github: Bogdanp 2 | -------------------------------------------------------------------------------- /.github/workflows/push.yml: -------------------------------------------------------------------------------- 1 | on: [push, pull_request] 2 | name: CI 3 | jobs: 4 | build: 5 | runs-on: ubuntu-latest 6 | services: 7 | postgres: 8 | image: postgres:12 9 | ports: 10 | - 5432:5432 11 | env: 12 | POSTGRES_USER: deta 13 | POSTGRES_PASSWORD: deta 14 | POSTGRES_DATABASE: deta 15 | steps: 16 | - uses: actions/checkout@master 17 | - uses: Bogdanp/setup-racket@v1.9 18 | with: 19 | architecture: 'x64' 20 | distribution: 'full' 21 | variant: 'CS' 22 | version: '8.6' 23 | - run: raco pkg install --auto --batch deta-lib/ deta-doc/ deta-test/ 24 | - run: raco test -j 4 deta-lib/ deta-test/ 25 | env: 26 | DETA_POSTGRES_DB: deta 27 | DETA_POSTGRES_USER: deta 28 | DETA_POSTGRES_PASS: deta 29 | - run: bash ci/docs.sh 30 | env: 31 | DETA_DOCS_DEPLOY_KEY_PASSPHRASE: ${{ secrets.DETA_DOCS_DEPLOY_KEY_PASSPHRASE }} 32 | DETA_DOCS_SSH_HOST: ${{ secrets.DETA_DOCS_SSH_HOST }} 33 | DETA_DOCS_SSH_PORT: ${{ secrets.DETA_DOCS_SSH_PORT }} 34 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | compiled 2 | coverage 3 | doc 4 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # deta ![CI](https://github.com/bogdanp/deta/workflows/CI/badge.svg) 2 | 3 | A functional database mapper for Racket. 4 | 5 | ## Documentation 6 | 7 | You can find the documentation on the [Racket package server][docs]. 8 | The package server only updates once every 24 hours so if you want the 9 | absolute most recent docs, then you can visit [deta.defn.io][docs-master]. 10 | 11 | ## Examples 12 | 13 | See the `examples/` folder for some examples. 14 | 15 | ## License 16 | 17 | deta is licensed under the 3-Clause BSD license. 18 | 19 | 20 | [docs]: https://docs.racket-lang.org/deta/index.html 21 | [docs-master]: https://deta.defn.io 22 | -------------------------------------------------------------------------------- /ci/deploy.gpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Bogdanp/deta/8d66a7bf5fe9ee814b1fdff30f95282f5c395223/ci/deploy.gpg -------------------------------------------------------------------------------- /ci/docs.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -euo pipefail 4 | 5 | sudo apt-get update 6 | sudo apt-get install -y --no-install-recommends gettext-base gpg ssh rsync 7 | 8 | raco scribble +m --dest doc --redirect 'https://docs.racket-lang.org/local-redirect/index.html' deta-doc/deta.scrbl 9 | mv doc/deta.html doc/index.html 10 | 11 | mkdir -p /tmp/secrets 12 | gpg -q --batch --yes --decrypt --passphrase="$DETA_DOCS_DEPLOY_KEY_PASSPHRASE" -o /tmp/secrets/deploy ci/deploy.gpg 13 | chmod 0600 /tmp/secrets/deploy 14 | rsync \ 15 | -e "ssh -p $DETA_DOCS_SSH_PORT -o StrictHostKeyChecking=no -i /tmp/secrets/deploy" \ 16 | -a doc/ deta@"$DETA_DOCS_SSH_HOST":~/www/ 17 | -------------------------------------------------------------------------------- /deta-doc/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2019 Bogdan Popa 2 | 3 | Redistribution and use in source and binary forms, with or without 4 | modification, are permitted provided that the following conditions are 5 | met: 6 | 7 | 1. Redistributions of source code must retain the above copyright 8 | notice, this list of conditions and the following disclaimer. 9 | 10 | 2. Redistributions in binary form must reproduce the above copyright 11 | notice, this list of conditions and the following disclaimer in the 12 | documentation and/or other materials provided with the distribution. 13 | 14 | 3. Neither the name of the copyright holder nor the names of its 15 | contributors may be used to endorse or promote products derived from 16 | this software without specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 24 | TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 25 | PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26 | LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | -------------------------------------------------------------------------------- /deta-doc/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define license 'BSD-3-Clause) 4 | (define collection "deta") 5 | (define scribblings '(("deta.scrbl" () ("Databases")))) 6 | 7 | (define deps '("base")) 8 | (define build-deps '("db-doc" 9 | "db-lib" 10 | "deta-lib" 11 | "gregor-doc" 12 | "gregor-lib" 13 | "racket-doc" 14 | "sandbox-lib" 15 | "scribble-lib" 16 | "threading-doc" 17 | "threading-lib")) 18 | 19 | (define update-implies '("deta-lib")) 20 | -------------------------------------------------------------------------------- /deta-doc/tutorial-log.rktd: -------------------------------------------------------------------------------- 1 | ;; This file was created by make-log-based-eval 2 | ((require racket/contract 3 | racket/match 4 | racket/string 5 | threading 6 | (for-label db gregor)) 7 | ((3) 0 () 0 () () (c values c (void))) 8 | #"" 9 | #"") 10 | ((require db) ((3) 0 () 0 () () (c values c (void))) #"" #"") 11 | ((define conn 12 | (postgresql-connect #:database "deta" #:user "deta" #:password "deta")) 13 | ((3) 0 () 0 () () (c values c (void))) 14 | #"" 15 | #"") 16 | ((require deta) ((3) 0 () 0 () () (c values c (void))) #"" #"") 17 | ((define-schema 18 | book 19 | ((id id/f #:primary-key #:auto-increment) 20 | (title string/f #:contract non-empty-string? #:wrapper string-titlecase) 21 | (author string/f #:contract non-empty-string?) 22 | (published-on date/f))) 23 | ((3) 0 () 0 () () (c values c (void))) 24 | #"" 25 | #"") 26 | ((require gregor) ((3) 0 () 0 () () (c values c (void))) #"" #"") 27 | ((define a-book 28 | (make-book 29 | #:title 30 | "To Kill a Mockingbirb" 31 | #:author 32 | "Harper Lee" 33 | #:published-on 34 | (date 1960 7 11))) 35 | ((3) 0 () 0 () () (c values c (void))) 36 | #"" 37 | #"") 38 | ((book-id a-book) 39 | ((3) 40 | 1 41 | (((lib "db/private/generic/sql-data.rkt") . deserialize-info:sql-null-v0)) 42 | 0 43 | () 44 | () 45 | (c values c (0))) 46 | #"" 47 | #"") 48 | ((book-title a-book) 49 | ((3) 0 () 0 () () (c values c (u . "To Kill A Mockingbirb"))) 50 | #"" 51 | #"") 52 | ((book-title (update-book-title a-book (lambda (t) (string-append t "?")))) 53 | ((3) 0 () 0 () () (c values c (u . "To Kill A Mockingbirb?"))) 54 | #"" 55 | #"") 56 | ((book-title a-book) 57 | ((3) 0 () 0 () () (c values c (u . "To Kill A Mockingbirb"))) 58 | #"" 59 | #"") 60 | ((drop-table! conn 'book) ((3) 0 () 0 () () (c values c (void))) #"" #"") 61 | ((create-table! conn 'book) ((3) 0 () 0 () () (c values c (void))) #"" #"") 62 | ((define saved-book (insert-one! conn a-book)) 63 | ((3) 0 () 0 () () (c values c (void))) 64 | #"" 65 | #"") 66 | ((book-id saved-book) ((3) 0 () 0 () () (q values 1)) #"" #"") 67 | ((book-title saved-book) 68 | ((3) 0 () 0 () () (c values c (u . "To Kill A Mockingbirb"))) 69 | #"" 70 | #"") 71 | ((define updated-book 72 | (update-one! conn (set-book-title saved-book "To Kill a Mockingbird"))) 73 | ((3) 0 () 0 () () (c values c (void))) 74 | #"" 75 | #"") 76 | ((book-title saved-book) 77 | ((3) 0 () 0 () () (c values c (u . "To Kill A Mockingbirb"))) 78 | #"" 79 | #"") 80 | ((book-title updated-book) 81 | ((3) 0 () 0 () () (c values c (u . "To Kill A Mockingbird"))) 82 | #"" 83 | #"") 84 | ((void 85 | (insert! 86 | conn 87 | (make-book 88 | #:title 89 | "1984" 90 | #:author 91 | "George Orwell" 92 | #:published-on 93 | (date 1949 6 8)) 94 | (make-book 95 | #:title 96 | "The Lord of the Rings" 97 | #:author 98 | "J.R.R. Tolkien" 99 | #:published-on 100 | (date 1954 7 29)) 101 | (make-book 102 | #:title 103 | "The Catcher in the Rye" 104 | #:author 105 | "J.D. Salinger" 106 | #:published-on 107 | (date 1949 7 16)))) 108 | ((3) 0 () 0 () () (c values c (void))) 109 | #"" 110 | #"") 111 | ((require threading) ((3) 0 () 0 () () (c values c (void))) #"" #"") 112 | ((for/list 113 | ((b 114 | (in-entities 115 | conn 116 | (~> 117 | (from book #:as b) 118 | (where (< b.published-on (date "1955-01-01"))) 119 | (order-by ((b.published-on #:desc))))))) 120 | (book-title b)) 121 | ((3) 122 | 0 123 | () 124 | 0 125 | () 126 | () 127 | (c 128 | values 129 | c 130 | (c 131 | (u . "The Lord Of The Rings") 132 | c 133 | (u . "The Catcher In The Rye") 134 | c 135 | (u . "1984")))) 136 | #"" 137 | #"") 138 | ((displayln 139 | (~> 140 | (from book #:as b) 141 | (where (< b.published-on (date "1955-01-01"))) 142 | (order-by ((b.published-on #:desc))))) 143 | ((3) 0 () 0 () () (c values c (void))) 144 | #"#\n" 145 | #"") 146 | ((define (books-before year) 147 | (~> 148 | (from book #:as b) 149 | (where (< b.published-on ,(sql-date year 1 1))) 150 | (order-by ((b.published-on #:desc))))) 151 | ((3) 0 () 0 () () (c values c (void))) 152 | #"" 153 | #"") 154 | ((for/list ((b (in-entities conn (books-before 1950)))) (book-title b)) 155 | ((3) 156 | 0 157 | () 158 | 0 159 | () 160 | () 161 | (c values c (c (u . "The Catcher In The Rye") c (u . "1984")))) 162 | #"" 163 | #"") 164 | ((for/list ((b (in-entities conn (books-before 1955)))) (book-title b)) 165 | ((3) 166 | 0 167 | () 168 | 0 169 | () 170 | () 171 | (c 172 | values 173 | c 174 | (c 175 | (u . "The Lord Of The Rings") 176 | c 177 | (u . "The Catcher In The Rye") 178 | c 179 | (u . "1984")))) 180 | #"" 181 | #"") 182 | ((define-schema book-stats #:virtual ((year date/f) (books integer/f))) 183 | ((3) 0 () 0 () () (c values c (void))) 184 | #"" 185 | #"") 186 | ((define books-published-by-year 187 | (~> 188 | (from book #:as b) 189 | (select 190 | (as (cast (date_trunc "year" b.published-on) date) year) 191 | (count b.title)) 192 | (group-by year) 193 | (order-by ((year))) 194 | (project-onto book-stats-schema))) 195 | ((3) 0 () 0 () () (c values c (void))) 196 | #"" 197 | #"") 198 | ((for 199 | ((s (in-entities conn books-published-by-year))) 200 | (displayln 201 | (format "year: ~a books: ~a" (book-stats-year s) (book-stats-books s)))) 202 | ((3) 0 () 0 () () (c values c (void))) 203 | #"year: # books: 2\nyear: # books: 1\nyear: # books: 1\n" 204 | #"") 205 | ((query-exec conn (delete (books-before 1950))) 206 | ((3) 0 () 0 () () (c values c (void))) 207 | #"" 208 | #"") 209 | ((for 210 | ((s (in-entities conn books-published-by-year))) 211 | (displayln 212 | (format "year: ~a books: ~a" (book-stats-year s) (book-stats-books s)))) 213 | ((3) 0 () 0 () () (c values c (void))) 214 | #"year: # books: 1\nyear: # books: 1\n" 215 | #"") 216 | -------------------------------------------------------------------------------- /deta-lib/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2019 Bogdan Popa 2 | 3 | Redistribution and use in source and binary forms, with or without 4 | modification, are permitted provided that the following conditions are 5 | met: 6 | 7 | 1. Redistributions of source code must retain the above copyright 8 | notice, this list of conditions and the following disclaimer. 9 | 10 | 2. Redistributions in binary form must reproduce the above copyright 11 | notice, this list of conditions and the following disclaimer in the 12 | documentation and/or other materials provided with the distribution. 13 | 14 | 3. Neither the name of the copyright holder nor the names of its 15 | contributors may be used to endorse or promote products derived from 16 | this software without specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 24 | TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 25 | PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26 | LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | -------------------------------------------------------------------------------- /deta-lib/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define license 'BSD-3-Clause) 4 | (define version "0.16.1") 5 | (define collection "deta") 6 | 7 | (define deps '("base" 8 | "db-lib" 9 | "gregor-lib")) 10 | (define build-deps '("at-exp-lib")) 11 | -------------------------------------------------------------------------------- /deta-lib/main.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (define-syntax-rule (reprovide e ...) 4 | (begin 5 | (require e ...) 6 | (provide (all-from-out e ...)))) 7 | 8 | (reprovide 9 | "schema.rkt" 10 | "query.rkt" 11 | "type.rkt") 12 | -------------------------------------------------------------------------------- /deta-lib/private/ast.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ;; ddl ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4 | 5 | (provide 6 | ddl? 7 | 8 | (struct-out create-table) 9 | (struct-out drop-table)) 10 | 11 | (struct ddl () 12 | #:transparent) 13 | 14 | ;; TODO: Eventually there should be a ddl-field struct. 15 | (struct create-table ddl (table fields) 16 | #:transparent) 17 | 18 | (struct drop-table ddl (table) 19 | #:transparent) 20 | 21 | 22 | ;; expr ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 23 | 24 | (provide 25 | expr? 26 | expr-terminal? 27 | 28 | make-fragment 29 | (struct-out app) 30 | (struct-out as) 31 | (struct-out case-e) 32 | (struct-out column) 33 | (struct-out fragment) 34 | (struct-out ident) 35 | (struct-out placeholder) 36 | (struct-out qualified) 37 | (struct-out scalar) 38 | (struct-out subquery) 39 | (struct-out table)) 40 | 41 | (struct expr () 42 | #:transparent) 43 | 44 | (define (expr-terminal? e) 45 | (not (app? e))) 46 | 47 | (struct app expr (f args) 48 | #:transparent) 49 | 50 | (struct as expr (e alias) 51 | #:transparent) 52 | 53 | (struct case-e expr (clauses else-clause) 54 | #:transparent) 55 | 56 | (struct column expr (e) 57 | #:transparent) 58 | 59 | (struct fragment expr (e) 60 | #:transparent) 61 | 62 | (struct ident expr (name) 63 | #:transparent) 64 | 65 | (struct placeholder expr (v) 66 | #:transparent) 67 | 68 | (struct qualified expr (parent name) 69 | #:transparent) 70 | 71 | (struct scalar expr (v) 72 | #:transparent) 73 | 74 | (struct subquery expr (stmt) 75 | #:transparent) 76 | 77 | (struct table expr (e) 78 | #:transparent) 79 | 80 | (define (make-fragment e) 81 | (cond 82 | [(string? e) (fragment e)] 83 | [(expr? e) e] 84 | [else (raise-argument-error 'fragment "(or/c string? expr?)" e)])) 85 | 86 | 87 | ;; clauses ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 88 | 89 | (provide 90 | clause? 91 | (struct-out assignments) 92 | 93 | make-from 94 | (struct-out from) 95 | 96 | (struct-out group-by) 97 | (struct-out join) 98 | (struct-out limit) 99 | (struct-out offset) 100 | (struct-out union) 101 | (struct-out order-by) 102 | (struct-out returning) 103 | (struct-out where)) 104 | 105 | (struct clause () 106 | #:transparent) 107 | 108 | (struct assignments clause (pairs) 109 | #:transparent) 110 | 111 | (struct from clause (tables joins) 112 | #:transparent) 113 | 114 | (define (make-from #:tables tables 115 | #:joins [joins null]) 116 | (from tables joins)) 117 | 118 | (struct group-by clause (columns) 119 | #:transparent) 120 | 121 | (struct join clause (type lateral? with constraint) 122 | #:transparent) 123 | 124 | (struct limit clause (n) 125 | #:transparent) 126 | 127 | (struct offset clause (n) 128 | #:transparent) 129 | 130 | (struct union clause (stmt) 131 | #:transparent) 132 | 133 | (struct order-by clause (orderings) 134 | #:transparent) 135 | 136 | (struct returning clause (es) 137 | #:transparent) 138 | 139 | (struct where clause (e) 140 | #:transparent) 141 | 142 | 143 | ;; statements ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 144 | 145 | (provide 146 | stmt? 147 | 148 | make-delete 149 | (struct-out delete) 150 | 151 | make-insert 152 | (struct-out insert) 153 | 154 | make-update 155 | (struct-out update) 156 | 157 | make-select 158 | (struct-out select)) 159 | 160 | (struct stmt () 161 | #:transparent) 162 | 163 | (struct delete stmt (from where returning) 164 | #:transparent) 165 | 166 | (define (make-delete #:from from 167 | #:where [where #f] 168 | #:returning [returning #f]) 169 | (delete from where returning)) 170 | 171 | (struct insert stmt (into columns column-values returning) 172 | #:transparent) 173 | 174 | (define (make-insert #:into into 175 | #:columns columns 176 | #:values column-values 177 | #:returning [returning #f]) 178 | (insert into columns column-values returning)) 179 | 180 | (struct update stmt (table assignments where returning) 181 | #:transparent) 182 | 183 | (define (make-update #:table table 184 | #:assignments assignments 185 | #:where [where #f] 186 | #:returning [returning #f]) 187 | (update table assignments where returning)) 188 | 189 | (struct select stmt (distinct? columns from where group-by union order-by offset limit) 190 | #:transparent) 191 | 192 | (define (make-select #:distinct? [distinct? #f] 193 | #:columns [columns null] 194 | #:from [from #f] 195 | #:where [where #f] 196 | #:group-by [group-by #f] 197 | #:union [union #f] 198 | #:order-by [order-by #f] 199 | #:offset [offset #f] 200 | #:limit [limit #f]) 201 | (select distinct? columns from where group-by union order-by offset limit)) 202 | -------------------------------------------------------------------------------- /deta-lib/private/connection.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require db 4 | racket/contract/base 5 | "dialect/dialect.rkt" 6 | "dialect/postgresql.rkt" 7 | "dialect/sqlite3.rkt") 8 | 9 | (provide 10 | (contract-out 11 | [connection-dialect (-> connection? dialect?)])) 12 | 13 | (define (connection-dialect conn) 14 | (case (dbsystem-name (connection-dbsystem conn)) 15 | [(postgresql) postgresql-dialect] 16 | [(sqlite3) sqlite3-dialect] 17 | [else (error 'connection-dialect "dialect not supported")])) 18 | -------------------------------------------------------------------------------- /deta-lib/private/dialect/dialect.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/generic) 4 | 5 | (provide 6 | gen:dialect 7 | dialect? 8 | dialect-name 9 | dialect-supports-returning? 10 | dialect-last-id-query 11 | dialect-emit-ddl 12 | dialect-emit-query 13 | dialect-prepare-parameters) 14 | 15 | (define-generics dialect 16 | (dialect-name dialect) 17 | (dialect-supports-returning? dialect) 18 | (dialect-last-id-query dialect) 19 | (dialect-emit-ddl dialect schema) 20 | (dialect-emit-query/impl dialect query) 21 | (dialect-prepare-parameters dialect statement args)) 22 | 23 | (define (dialect-emit-query dialect stmt) 24 | (parameterize ([current-placeholders null]) 25 | (values (dialect-emit-query/impl dialect stmt) 26 | (reverse (current-placeholders))))) 27 | 28 | 29 | ;; placeholders ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 30 | 31 | (provide 32 | track-placeholder!) 33 | 34 | (define current-placeholders 35 | (make-parameter null)) 36 | 37 | (define (track-placeholder! v) 38 | (define placeholders (cons v (current-placeholders))) 39 | (current-placeholders placeholders) 40 | (length placeholders)) 41 | -------------------------------------------------------------------------------- /deta-lib/private/dialect/operator.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require (for-syntax racket/base 4 | racket/syntax 5 | syntax/parse/pre) 6 | racket/match) 7 | 8 | (provide 9 | define-ops) 10 | 11 | (define-syntax (define-ops stx) 12 | (syntax-parse stx 13 | [(_ kind:id [op:id (~optional maybe-op-str:str)] ...) 14 | #:with (op-str ...) (for/list ([op (in-list (syntax-e #'(op ...)))] 15 | [maybe-str (in-list (syntax-e #'((~? maybe-op-str #f) ...)))]) 16 | (cond 17 | [(syntax->datum maybe-str) maybe-str] 18 | [else (datum->syntax op (string-upcase (symbol->string (syntax->datum op))))])) 19 | #:with write-operator-id (format-id stx "write-~a-operator" #'kind) 20 | #:with match-expander-id (format-id stx "~a-operator" #'kind) 21 | (syntax/loc stx 22 | (begin 23 | (provide 24 | write-operator-id 25 | match-expander-id) 26 | (define (write-operator-id id) 27 | (write-string 28 | (case id 29 | [(op) op-str] ...))) 30 | (define-match-expander match-expander-id 31 | (lambda (stx) 32 | (syntax-parse stx 33 | [(_) #'(or 'op ...)] 34 | [(_ out) #'(and (or 'op ...) out)])))))])) 35 | 36 | (define-ops unary 37 | [bitwise-not "~"] 38 | [date] 39 | [interval] 40 | [json] 41 | [jsonb] 42 | [not] 43 | [time] 44 | [timestamp]) 45 | 46 | (define-ops binary 47 | [=] [>] [<] [>=] [<=] [<>] [!=] 48 | [array-contains? "@>"] 49 | [array-overlap? "&&"] 50 | [array-ref] 51 | [cast] 52 | [extract] 53 | [ilike] 54 | [in] 55 | [is-distinct "IS DISTINCT"] 56 | [is] 57 | [json-check-path "@@"] 58 | [json-contains-all? "?&"] 59 | [json-contains-any? "?|"] 60 | [json-contains-path? "@?"] 61 | [json-contains? "?"] 62 | [json-ref-text "->>"] 63 | [json-ref-text/path "#>>"] 64 | [json-subset? "<@"] 65 | [json-superset? "@>"] 66 | [like] 67 | [position] 68 | [regexp-match? "~"] 69 | [regexp-match?* "~*"] 70 | [tsquery-match? "@@"] 71 | [similar-to "SIMILAR TO"]) 72 | 73 | (define-ops ternary 74 | [array-slice] 75 | [between] 76 | [trim]) 77 | 78 | (define-ops variadic 79 | [+] [-] [*] [/] [%] [^] 80 | [<<] [>>] 81 | [and] 82 | [array-concat "||"] 83 | [bitwise-and "&"] 84 | [bitwise-or "|"] 85 | [bitwise-xor "#"] 86 | [json-concat "||"] 87 | [json-ref "->"] 88 | [json-ref/path "#>"] 89 | [json-remove "-"] 90 | [json-remove/path "#-"] 91 | [or] 92 | [string-concat "||"]) 93 | -------------------------------------------------------------------------------- /deta-lib/private/dialect/postgresql.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/match 4 | racket/port 5 | "../ast.rkt" 6 | "../field.rkt" 7 | "../type.rkt" 8 | "dialect.rkt" 9 | "standard.rkt") 10 | 11 | (provide 12 | postgresql-dialect? 13 | postgresql-dialect) 14 | 15 | (define-values (postgresql-dialect? postgresql-dialect) 16 | (let () 17 | (struct postgresql-dialect () 18 | #:methods gen:dialect 19 | [(define (dialect-name _) 'postgresql) 20 | (define (dialect-supports-returning? _) #t) 21 | 22 | (define (dialect-last-id-query _) 23 | "SELECT lastval()") 24 | 25 | (define (dialect-emit-ddl _ d) 26 | (emit-ddl d)) 27 | 28 | (define (dialect-emit-query/impl _ s) 29 | (emit-stmt s)) 30 | 31 | (define (dialect-prepare-parameters _ p args) 32 | args)]) 33 | 34 | (values postgresql-dialect? (postgresql-dialect)))) 35 | 36 | (define (emit-ddl d) 37 | (with-output-to-string 38 | (lambda () 39 | (match d 40 | [(create-table table fields) 41 | (display "CREATE TABLE IF NOT EXISTS ") 42 | (display (quote/standard table)) 43 | 44 | (displayln "(") 45 | (define n-fields (length fields)) 46 | (for ([i (in-naturals 1)] 47 | [f (in-list fields)]) 48 | (emit-field-ddl f (= i n-fields))) 49 | (displayln ")")] 50 | 51 | [(drop-table table) 52 | (display "DROP TABLE IF EXISTS ") 53 | (displayln (quote/standard table))])))) 54 | 55 | (define (emit-field-ddl f last?) 56 | (define type 57 | (if (field-auto-increment? f) 58 | "SERIAL" 59 | (type-declaration (field-type f) 'postgresql))) 60 | 61 | (display (quote/standard (field-name f))) 62 | (display " ") 63 | (display type) 64 | 65 | (unless (field-nullable? f) 66 | (display " NOT NULL")) 67 | 68 | (when (field-primary-key? f) 69 | (display " PRIMARY KEY")) 70 | 71 | (when (field-unique? f) 72 | (display " UNIQUE")) 73 | 74 | (unless last? 75 | (displayln ","))) 76 | 77 | (define (emit-expr e) 78 | (emit-expr/standard e)) 79 | 80 | (define (emit-stmt e) 81 | (with-output-to-string 82 | (lambda () 83 | (emit-stmt/postgresql e)))) 84 | 85 | (define (emit-stmt/postgresql e) 86 | (emit-stmt/standard e)) 87 | 88 | (define emit-expr/standard 89 | (make-expr-emitter 90 | emit-expr 91 | emit-stmt/postgresql)) 92 | 93 | (define emit-stmt/standard 94 | (make-stmt-emitter 95 | #:supports-returning? #t 96 | emit-stmt/postgresql emit-expr)) 97 | -------------------------------------------------------------------------------- /deta-lib/private/dialect/sqlite3.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/match 4 | racket/port 5 | "../ast.rkt" 6 | "../field.rkt" 7 | "../type.rkt" 8 | "dialect.rkt" 9 | "operator.rkt" 10 | "standard.rkt") 11 | 12 | (provide 13 | sqlite3-dialect? 14 | sqlite3-dialect) 15 | 16 | (define-values (sqlite3-dialect? sqlite3-dialect) 17 | (let () 18 | (struct sqlite3-dialect () 19 | #:methods gen:dialect 20 | [(define (dialect-name _) 'sqlite3) 21 | (define (dialect-supports-returning? _) #t) 22 | 23 | (define (dialect-last-id-query _) 24 | "SELECT last_insert_rowid()") 25 | 26 | (define (dialect-emit-ddl _ d) 27 | (emit-ddl d)) 28 | 29 | (define (dialect-emit-query/impl _ s) 30 | (emit-stmt s)) 31 | 32 | (define (dialect-prepare-parameters _ _p args) 33 | (for/list ([arg (in-list args)]) 34 | (match arg 35 | [#f 0] 36 | [#t 1] 37 | [_ arg])))]) 38 | 39 | (values sqlite3-dialect? (sqlite3-dialect)))) 40 | 41 | (define (emit-ddl d) 42 | (with-output-to-string 43 | (lambda () 44 | (match d 45 | [(create-table table fields) 46 | (display "CREATE TABLE IF NOT EXISTS ") 47 | (display (quote/standard table)) 48 | 49 | (displayln "(") 50 | (define n-fields (length fields)) 51 | (for ([i (in-naturals 1)] 52 | [f (in-list fields)]) 53 | (emit-field-ddl f (= i n-fields))) 54 | (displayln ")")] 55 | 56 | [(drop-table table) 57 | (display "DROP TABLE IF EXISTS ") 58 | (displayln (quote/standard table))])))) 59 | 60 | (define (emit-field-ddl f last?) 61 | (display (quote/standard (field-name f))) 62 | (display " ") 63 | (display (type-declaration (field-type f) 'sqlite3)) 64 | 65 | (unless (field-nullable? f) 66 | (display " NOT NULL")) 67 | 68 | (when (field-primary-key? f) 69 | (display " PRIMARY KEY")) 70 | 71 | (when (field-auto-increment? f) 72 | (display " AUTOINCREMENT")) 73 | 74 | (when (field-unique? f) 75 | (display " UNIQUE")) 76 | 77 | (unless last? 78 | (displayln ","))) 79 | 80 | (define (emit-expr e) 81 | (match e 82 | [(app (ident (unary-operator 'json)) args) 83 | (write-string "JSON(") 84 | (emit-expr (car args)) 85 | (write-string ")")] 86 | 87 | [(app (and (ident (or 'date 'time 'datetime)) op) args) 88 | (emit-expr op) 89 | (write-string "(") 90 | (write/sep args emit-expr) 91 | (write-string ")")] 92 | 93 | [_ 94 | (emit-expr/standard e)])) 95 | 96 | (define (emit-stmt e) 97 | (with-output-to-string 98 | (lambda () 99 | (emit-stmt/sqlite3 e)))) 100 | 101 | (define (emit-stmt/sqlite3 e) 102 | (match e 103 | [(union stmt) 104 | (write-string "UNION ") 105 | (emit-stmt/sqlite3 stmt)] 106 | 107 | [_ 108 | (emit-stmt/standard e)])) 109 | 110 | (define emit-expr/standard 111 | (make-expr-emitter 112 | emit-expr 113 | emit-stmt/sqlite3)) 114 | 115 | (define emit-stmt/standard 116 | (make-stmt-emitter 117 | #:supports-returning? #t 118 | emit-stmt/sqlite3 emit-expr)) 119 | -------------------------------------------------------------------------------- /deta-lib/private/dialect/standard-reserved-words.rktd: -------------------------------------------------------------------------------- 1 | ;; https://www.postgresql.org/docs/15/sql-keywords-appendix.html 2 | (abs absent absolute acos action add all allocate alter analyse 3 | analyze and any are array array_agg array_max_cardinality as asc 4 | asensitive asin assertion asymmetric at atan atomic authorization avg 5 | begin begin_frame begin_partition between bigint binary bit bit_length 6 | blob boolean both by call called cardinality cascade cascaded case 7 | cast catalog ceil ceiling char character character_length char_length 8 | check classifier clob close coalesce collate collation collect column 9 | commit concurrently condition connect connection constraint 10 | constraints contains continue convert copy corr corresponding cos cosh 11 | count covar_pop covar_samp create cross cube cume_dist current 12 | current_catalog current_date current_default_transform_group 13 | current_path current_role current_row current_schema current_time 14 | current_timestamp current_transform_group_for_type current_user cursor 15 | cycle datalink date day deallocate dec decfloat decimal declare 16 | default deferrable deferred define delete dense_rank deref desc 17 | describe descriptor deterministic diagnostics disconnect distinct 18 | dlnewcopy dlpreviouscopy dlurlcomplete dlurlcompleteonly 19 | dlurlcompletewrite dlurlpath dlurlpathonly dlurlpathwrite dlurlscheme 20 | dlurlserver dlvalue do domain double drop dynamic each element else 21 | empty end end-exec end_frame end_partition equals escape every except 22 | exception exec execute exists exp external extract false fetch filter 23 | first first_value float floor for foreign found frame_row free freeze 24 | from full function fusion get global go goto grant group grouping 25 | groups having hold hour identity ilike immediate import in indicator 26 | initial initially inner inout input insensitive insert int integer 27 | intersect intersection interval into is isnull isolation join 28 | json_array json_arrayagg json_exists json_object json_objectagg 29 | json_query json_table json_table_primitive json_value key lag language 30 | large last last_value lateral lead leading left level like like_regex 31 | limit listagg ln local localtime localtimestamp log log10 lower match 32 | matches match_number match_recognize max measures member merge method 33 | min minute mod modifies module month multiset names national natural 34 | nchar nclob new next no none normalize not notnull nth_value ntile 35 | null nullif numeric occurrences_regex octet_length of offset old omit 36 | on one only open option or order out outer output over overlaps 37 | overlay pad parameter partial partition pattern per percent 38 | percentile_cont percentile_disc percent_rank period permute placing 39 | portion position position_regex power precedes precision prepare 40 | preserve primary prior privileges procedure ptf public range rank read 41 | reads real recursive ref references referencing regr_avgx regr_avgy 42 | regr_count regr_intercept regr_r2 regr_slope regr_sxx regr_sxy 43 | regr_syy relative release restrict result return returning returns 44 | revoke right rollback rollup row rows row_number running savepoint 45 | schema scope scroll search second section seek select sensitive 46 | session session_user set show similar sin sinh size skip smallint some 47 | space specific specifictype sql sqlcode sqlerror sqlexception sqlstate 48 | sqlwarning sqrt start static stddev_pop stddev_samp submultiset subset 49 | substring substring_regex succeeds sum symmetric system system_time 50 | system_user table tablesample tan tanh temporary then time timestamp 51 | timezone_hour timezone_minute to trailing transaction translate 52 | translate_regex translation treat trigger trim trim_array true 53 | truncate uescape union unique unknown unmatched unnest update upper 54 | usage user using value values value_of varbinary varchar variadic 55 | varying var_pop var_samp verbose versioning view when whenever where 56 | width_bucket window with within without work write xml xmlagg 57 | xmlattributes xmlbinary xmlcast xmlcomment xmlconcat xmldocument 58 | xmlelement xmlexists xmlforest xmliterate xmlnamespaces xmlparse xmlpi 59 | xmlquery xmlserialize xmltable xmltext xmlvalidate year zone) 60 | -------------------------------------------------------------------------------- /deta-lib/private/dialect/standard.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/match 4 | racket/port 5 | racket/runtime-path 6 | racket/sequence 7 | racket/string 8 | racket/symbol 9 | "../ast.rkt" 10 | "dialect.rkt" 11 | "operator.rkt") 12 | 13 | ;; Implements a "standard" emitter for SQL from our AST. I say 14 | ;; "standard", but what I really mean is as close to the standard as 15 | ;; PostgreSQL 11 natively supports. 16 | 17 | (provide 18 | quote/standard 19 | make-expr-emitter 20 | make-stmt-emitter 21 | write/sep) 22 | 23 | (define-runtime-path standard-reserved-words.rktd 24 | "standard-reserved-words.rktd") 25 | 26 | (define reserved-words 27 | (for/fold ([words (hash)]) 28 | ([word (in-list (call-with-input-file standard-reserved-words.rktd read))]) 29 | (hash-set words (symbol->immutable-string word) #t))) 30 | 31 | (define (quote-string s) 32 | (string-append "\"" s "\"")) 33 | 34 | (define (quote/standard e [reserved reserved-words]) 35 | (cond 36 | [(symbol? e) (quote/standard (symbol->string e))] 37 | [(string=? e "*") "*"] 38 | [(regexp-match-exact? #rx"[a-z_][a-z0-9_]*" e) 39 | (if (hash-has-key? reserved e) 40 | (quote-string e) 41 | e)] 42 | [else 43 | (quote-string e)])) 44 | 45 | (define ((make-expr-emitter write-expr write-stmt) e) 46 | (define (display/maybe-parenthize e) 47 | (match e 48 | [(app (ident 'any) _) 49 | (write-expr e)] 50 | 51 | [(? expr-terminal?) 52 | (write-expr e)] 53 | 54 | [_ 55 | (write-string "(") 56 | (write-expr e) 57 | (write-string ")")])) 58 | 59 | (match e 60 | [(or (? string?) 61 | (? symbol?)) 62 | (write-string (quote/standard e))] 63 | 64 | [(table e) (write-expr e)] 65 | [(column e) (write-expr e)] 66 | 67 | [(fragment s) 68 | (write-string s)] 69 | 70 | [(ident i) 71 | (write-string (ident->string i))] 72 | 73 | [(placeholder v) 74 | (write-string "$") 75 | (display (track-placeholder! v))] 76 | 77 | [(scalar #t) (write-string "TRUE")] 78 | [(scalar #f) (write-string "FALSE")] 79 | 80 | [(scalar (and (? list?) items)) 81 | (write-string "(") 82 | (write/sep items write-expr) 83 | (write-string ")")] 84 | 85 | [(scalar (and (? string?) str)) 86 | (write-string "'") 87 | (write-string (string-replace str "'" "''")) 88 | (write-string "'")] 89 | 90 | [(scalar (and (? vector?) v)) 91 | (write-string "ARRAY[") 92 | (write/sep v write-expr) 93 | (write-string "]")] 94 | 95 | [(scalar v) 96 | (display v)] 97 | 98 | [(qualified parent name) 99 | (write-expr parent) 100 | (write-string ".") 101 | (write-expr name)] 102 | 103 | [(as e alias) 104 | (display/maybe-parenthize e) 105 | (write-string " AS ") 106 | (write-expr alias)] 107 | 108 | [(app (ident (unary-operator op)) (list a)) 109 | (write-unary-operator op) 110 | (write-string " ") 111 | (display/maybe-parenthize a)] 112 | 113 | [(app (ident (binary-operator 'array-ref)) (list a b)) 114 | (write-string "(") 115 | (write-expr a) 116 | (write-string ")[") 117 | (display/maybe-parenthize b) 118 | (write-string "]")] 119 | 120 | [(app (ident (binary-operator 'cast)) (list a b)) 121 | (write-string "CAST(") 122 | (display/maybe-parenthize a) 123 | (write-string " AS ") 124 | (write-expr b) 125 | (write-string ")")] 126 | 127 | [(app (ident (binary-operator 'extract)) (list a b)) 128 | (write-string "EXTRACT(") 129 | (write-expr a) 130 | (write-string " FROM ") 131 | (display/maybe-parenthize b) 132 | (write-string ")")] 133 | 134 | [(app (ident (binary-operator 'position)) (list a b)) 135 | (write-string "POSITION(") 136 | (display/maybe-parenthize a) 137 | (write-string " IN ") 138 | (display/maybe-parenthize b) 139 | (write-string ")")] 140 | 141 | [(app (ident (binary-operator op)) (list a b)) 142 | (display/maybe-parenthize a) 143 | (write-string " ") 144 | (write-binary-operator op) 145 | (write-string " ") 146 | (display/maybe-parenthize b)] 147 | 148 | [(app (ident (ternary-operator 'array-slice)) (list a b c)) 149 | (write-string "(") 150 | (write-expr a) 151 | (write-string ")[") 152 | (display/maybe-parenthize b) 153 | (write-string ":") 154 | (display/maybe-parenthize c) 155 | (write-string "]")] 156 | 157 | [(app (ident (ternary-operator 'between)) (list a b c)) 158 | (display/maybe-parenthize a) 159 | (write-string " BETWEEN ") 160 | (display/maybe-parenthize b) 161 | (write-string " AND ") 162 | (display/maybe-parenthize c)] 163 | 164 | [(app (ident (ternary-operator 'trim)) (list a b c)) 165 | (write-string "TRIM(") 166 | (display/maybe-parenthize a) 167 | (write-string " ") 168 | (display/maybe-parenthize b) 169 | (write-string " FROM ") 170 | (display/maybe-parenthize c) 171 | (write-string ")")] 172 | 173 | [(app (ident (variadic-operator op)) es) 174 | (define separator 175 | (with-output-to-string 176 | (lambda () 177 | (display " ") 178 | (write-variadic-operator op) 179 | (display " ")))) 180 | 181 | (write/sep 182 | #:sep separator 183 | es display/maybe-parenthize)] 184 | 185 | [(app (ident (unary-operator op)) args) 186 | (apply raise-arity-error op 1 args)] 187 | 188 | [(app (ident (binary-operator op)) args) 189 | (apply raise-arity-error op 2 args)] 190 | 191 | [(app (ident (ternary-operator op)) args) 192 | (apply raise-arity-error op 3 args)] 193 | 194 | [(app f args) 195 | (write-expr f) 196 | (write-string "(") 197 | (write/sep args write-expr) 198 | (write-string ")")] 199 | 200 | [(case-e cases else-case) 201 | (write-string "CASE") 202 | 203 | (for ([c (in-list cases)]) 204 | (write-string " WHEN ") 205 | (write-expr (car c)) 206 | (write-string " THEN ") 207 | (write-expr (cdr c))) 208 | 209 | (when else-case 210 | (write-string " ELSE ") 211 | (write-expr else-case)) 212 | 213 | (write-string " END")] 214 | 215 | [(subquery stmt) 216 | (write-string "(") 217 | (write-stmt stmt) 218 | (write-string ")")])) 219 | 220 | (define ((make-stmt-emitter write-stmt 221 | write-expr 222 | #:supports-returning? [supports-returning? #f]) e) 223 | 224 | (define (display/space e) 225 | (write-string " ") 226 | (write-stmt e)) 227 | 228 | (define (display/parens e) 229 | (write-string "(") 230 | (write-stmt e) 231 | (write-string ")")) 232 | 233 | (match e 234 | [(? expr?) 235 | (write-expr e)] 236 | 237 | [(list exprs ...) 238 | (write/sep exprs write-expr)] 239 | 240 | [(select distinct? columns from where group-by union order-by offset limit) 241 | (write-string "SELECT ") 242 | (when distinct? 243 | (write-string "DISTINCT ")) 244 | (cond 245 | [(null? columns) (write-string "*")] 246 | [else (write-stmt columns)]) 247 | 248 | (when from (display/space from)) 249 | (when where (display/space where)) 250 | (when group-by (display/space group-by)) 251 | (when union (display/space union)) 252 | (when order-by (display/space order-by)) 253 | (when limit (display/space limit)) 254 | (when offset (display/space offset))] 255 | 256 | [(update table assignments where returning) 257 | (write-string "UPDATE ") 258 | (write-expr table) 259 | 260 | (when assignments (display/space assignments)) 261 | (when where (display/space where)) 262 | (when (and returning supports-returning?) 263 | (display/space returning))] 264 | 265 | [(delete from where returning) 266 | (write-string "DELETE ") 267 | (write-stmt from) 268 | (when where (display/space where)) 269 | (when (and returning supports-returning?) 270 | (display/space returning))] 271 | 272 | [(insert table columns column-values returning) 273 | (write-string "INSERT INTO ") 274 | (write-expr table) 275 | (display/parens columns) 276 | (write-string " VALUES ") 277 | (display/parens column-values) 278 | (when (and returning supports-returning?) 279 | (display/space returning))] 280 | 281 | [(assignments pairs) 282 | (write-string "SET ") 283 | (write/sep 284 | pairs 285 | (match-lambda 286 | [(cons l r) 287 | (write-expr l) 288 | (write-string " = ") 289 | (write-expr r)]))] 290 | 291 | [(limit e) 292 | (write-string "LIMIT ") 293 | (write-expr e)] 294 | 295 | [(from tables joins) 296 | (write-string "FROM ") 297 | (write/sep tables write-stmt) 298 | (unless (null? joins) 299 | (for ([join (in-list joins)]) 300 | (write-stmt join)))] 301 | 302 | [(join type lateral? with constraint) 303 | (write-string " ") 304 | (write-string (join-type->string type)) 305 | (write-string " ") 306 | (when lateral? 307 | (write-string "LATERAL ")) 308 | (write-expr with) 309 | (unless (eq? type 'cross) 310 | (write-string " ON ") 311 | (write-expr constraint))] 312 | 313 | [(where e) 314 | (write-string "WHERE ") 315 | (write-expr e)] 316 | 317 | [(group-by cols) 318 | (write-string "GROUP BY ") 319 | (write-stmt cols)] 320 | 321 | [(offset e) 322 | (write-string "OFFSET ") 323 | (write-expr e)] 324 | 325 | [(returning es) 326 | (write-string "RETURNING ") 327 | (write-stmt es)] 328 | 329 | [(order-by orderings) 330 | (write-string "ORDER BY ") 331 | (write/sep 332 | orderings 333 | (match-lambda 334 | [(list e dir nulls-dir) 335 | (write-expr e) 336 | (when (eq? dir 'desc) 337 | (write-string " DESC")) 338 | (when nulls-dir 339 | (write-string " NULLS") 340 | (case nulls-dir 341 | [(nulls-first) (write-string " FIRST")] 342 | [(nulls-last) (write-string " LAST")]))]))] 343 | 344 | [(union stmt) 345 | (write-string "UNION (") 346 | (write-stmt stmt) 347 | (write-string ")")])) 348 | 349 | (define (write/sep xs write-proc #:sep [sep ", "]) 350 | (define n-xs 351 | (sequence-length xs)) 352 | 353 | (for ([i (in-naturals 1)] 354 | [x xs]) 355 | (write-proc x) 356 | (unless (= i n-xs) 357 | (write-string sep)))) 358 | 359 | (define (ident->string s) 360 | (string-upcase (symbol->string s))) 361 | 362 | (define (join-type->string t) 363 | (case t 364 | [(inner) "JOIN"] 365 | [(left) "LEFT JOIN"] 366 | [(right) "RIGHT JOIN"] 367 | [(full) "FULL JOIN"] 368 | [(cross) "CROSS JOIN"])) 369 | -------------------------------------------------------------------------------- /deta-lib/private/entity.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/set 4 | "field.rkt" 5 | "meta.rkt" 6 | "schema.rkt") 7 | 8 | (provide 9 | (struct-out entity) 10 | entity-schema 11 | entity-changed? 12 | entity->hash) 13 | 14 | (define (entity=? a b recur) 15 | (and (entity? b) 16 | (eq? (meta-schema (entity-meta a)) 17 | (meta-schema (entity-meta b))) 18 | (for/and ([fld (in-list (schema-fields (meta-schema (entity-meta a))))]) 19 | (recur ((field-getter fld) a) 20 | ((field-getter fld) b))))) 21 | 22 | (define (entity-hash-code e recur) 23 | (define m (entity-meta e)) 24 | (define s (meta-schema m)) 25 | (for/fold ([code (recur s)]) 26 | ([fld (in-list (schema-fields s))]) 27 | (bitwise-xor code 28 | (recur (field-id fld)) 29 | (recur ((field-getter fld) e))))) 30 | 31 | (struct entity (meta) 32 | #:transparent 33 | #:methods gen:equal+hash 34 | [(define equal-proc entity=?) 35 | (define hash-proc entity-hash-code) 36 | (define hash2-proc entity-hash-code)]) 37 | 38 | (define (entity-schema e) 39 | (meta-schema (entity-meta e))) 40 | 41 | (define (entity-changed? e) 42 | (not (set-empty? (meta-changes (entity-meta e))))) 43 | 44 | (define (entity->hash e [f (λ (_k v) v)]) 45 | (for*/hasheq ([fld (in-list (schema-fields (entity-schema e)))] 46 | [key (in-value (field-id fld))] 47 | [val (in-value (f key ((field-getter fld) e)))]) 48 | (values key val))) 49 | -------------------------------------------------------------------------------- /deta-lib/private/field.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/format 4 | racket/string) 5 | 6 | (provide 7 | make-field 8 | (struct-out field) 9 | 10 | id->column-name) 11 | 12 | (struct field 13 | (id 14 | name 15 | kwd 16 | type 17 | getter 18 | setter 19 | updater 20 | primary-key? 21 | auto-increment? 22 | nullable? 23 | unique? 24 | virtual?)) 25 | 26 | (define (make-field #:id id 27 | #:name name 28 | #:kwd [kwd (symbol->keyword id)] 29 | #:type type 30 | #:getter getter 31 | #:setter setter 32 | #:updater updater 33 | #:primary-key? primary-key? 34 | #:auto-increment? auto-increment? 35 | #:nullable? nullable? 36 | #:unique? unique? 37 | #:virtual? virtual?) 38 | (field id 39 | name 40 | kwd 41 | type 42 | getter 43 | setter 44 | updater 45 | primary-key? 46 | auto-increment? 47 | nullable? 48 | unique? 49 | virtual?)) 50 | 51 | (define (id->column-name id) 52 | (let* ([name (cond 53 | [(symbol? id) (symbol->string id)] 54 | [(string? id) id])] 55 | [name (string-replace name "-" "_")] 56 | [name (if (string-suffix? name "?") 57 | (~a "is_" (substring name 0 (sub1 (string-length name)))) 58 | name)]) 59 | name)) 60 | 61 | (define symbol->keyword 62 | (compose1 string->keyword symbol->string)) 63 | -------------------------------------------------------------------------------- /deta-lib/private/meta.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/set) 4 | 5 | (provide 6 | make-meta 7 | meta? 8 | meta-state 9 | meta-schema 10 | meta-changes 11 | meta-can-persist? 12 | meta-can-update? 13 | meta-can-delete? 14 | meta-track-change 15 | meta-track-persisted 16 | meta-track-deleted) 17 | 18 | (struct meta (state schema changes)) 19 | 20 | (define (make-meta schema) 21 | (meta 'created schema (seteq))) 22 | 23 | (define (meta-track-change m f) 24 | (struct-copy meta m 25 | [state (case (meta-state m) 26 | [(created) 'created] 27 | [(persisted changed) 'changed] 28 | [(deleted) 'deleted])] 29 | [changes (set-add (meta-changes m) f)])) 30 | 31 | (define (meta-can-persist? m) 32 | (case (meta-state m) 33 | [(created) #t] 34 | [(changed) #t] 35 | [else #f])) 36 | 37 | (define (meta-can-update? m) 38 | (case (meta-state m) 39 | [(changed) #t] 40 | [else #f])) 41 | 42 | (define (meta-can-delete? m) 43 | (case (meta-state m) 44 | [(persisted) #t] 45 | [(changed) #t] 46 | [else #f])) 47 | 48 | (define (meta-track-persisted m) 49 | (struct-copy meta m 50 | [state 'persisted] 51 | [changes (seteq)])) 52 | 53 | (define (meta-track-deleted m) 54 | (struct-copy meta m 55 | [state 'deleted] 56 | [changes (seteq)])) 57 | -------------------------------------------------------------------------------- /deta-lib/private/query.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require db 4 | (only-in racket/class send) 5 | racket/contract/base 6 | racket/match 7 | racket/struct 8 | (prefix-in ast: "ast.rkt") 9 | "connection.rkt" 10 | "dialect/dialect.rkt" 11 | "dialect/postgresql.rkt" 12 | "field.rkt" 13 | "schema.rkt") 14 | 15 | ;; struct ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 16 | 17 | (provide 18 | make-empty-query 19 | (struct-out opts) 20 | (struct-out query)) 21 | 22 | (struct opts (project-virtual-fields?) 23 | #:transparent) 24 | 25 | (struct query (schema opts stmt) 26 | #:transparent 27 | #:property prop:statement 28 | (lambda (self c) 29 | (define dialect (connection-dialect c)) 30 | (define-values (query args) 31 | (dialect-emit-query dialect (query-stmt self))) 32 | 33 | ;; We grab the base connection s.t. querying `virtual-connection's 34 | ;; works. `virtual-statement' does the same thing so we should be 35 | ;; fine, compatibility-wise, but this behavior isn't specified 36 | ;; anywhere so it may break on us w/o notice. 37 | (define prepared 38 | (prepare (or (send c get-base) c) query)) 39 | 40 | (cond 41 | [(null? args) prepared] 42 | [else (bind-prepared-statement prepared (dialect-prepare-parameters dialect prepared args))])) 43 | 44 | #:property prop:custom-write 45 | (make-constructor-style-printer 46 | (lambda (_) 'query) 47 | (lambda (self) 48 | (define-values (query args) 49 | (dialect-emit-query postgresql-dialect (query-stmt self))) 50 | (cons query args)))) 51 | 52 | (define (make-empty-query) 53 | (query #f (opts #f) (ast:make-select))) 54 | 55 | (define (make-query stmt 56 | #:schema [schema #f] 57 | #:project-virtual-fields? [project-virtual? #f]) 58 | (query schema (opts project-virtual?) stmt)) 59 | 60 | 61 | ;; helpers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 62 | 63 | (define (select-query? q) 64 | (and/c query? (ast:select? (query-stmt q)))) 65 | 66 | (define (contains-subquery? f) 67 | (match f 68 | [(ast:subquery _) #t] 69 | [(ast:as (? ast:subquery?) _) #t] 70 | [_ #f])) 71 | 72 | (define (add-join f j) 73 | (struct-copy ast:from f [joins (append (ast:from-joins f) (list j))])) 74 | 75 | (define assignment/c 76 | (cons/c ast:column? ast:expr?)) 77 | 78 | 79 | ;; combinators ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 80 | 81 | (provide 82 | (contract-out 83 | [delete (-> select-query? query?)] 84 | [from (-> any/c #:as symbol? query?)] 85 | [group-by (-> select-query? ast:expr? ast:expr? ... query?)] 86 | [join 87 | (-> select-query? 88 | #:type (or/c 'inner 'left 'right 'full 'cross) 89 | #:lateral? boolean? 90 | #:with (or/c ast:subquery? schema? string? symbol?) 91 | #:as symbol? 92 | #:on (or/c #f ast:expr?) 93 | query?)] 94 | [limit (-> query? (or/c ast:scalar? ast:placeholder?) query?)] 95 | [offset (-> query? (or/c ast:scalar? ast:placeholder?) query?)] 96 | [or-where (-> query? ast:expr? query?)] 97 | [order-by (-> select-query? ordering/c ordering/c ... query?)] 98 | [project-onto (-> query? schema? query?)] 99 | [project-virtual-fields (-> query? query?)] 100 | [returning (-> query? ast:expr? ast:expr? ... query?)] 101 | [select 102 | (->* [query? ast:expr?] 103 | [#:distinct? boolean?] 104 | #:rest (listof ast:expr?) 105 | query?)] 106 | [select-for-schema 107 | (-> query? 108 | (or/c schema? symbol?) 109 | string? 110 | (hash/c symbol? ast:expr?) 111 | query?)] 112 | [subquery (-> select-query? ast:subquery?)] 113 | [union (-> select-query? select-query? query?)] 114 | [update (-> select-query? assignment/c assignment/c ... query?)] 115 | [where (-> query? ast:expr? query?)])) 116 | 117 | (define (delete q) 118 | (match q 119 | [(query schema opts (struct* ast:select ([from (ast:from (list table) _)] 120 | [where where]))) 121 | (when (contains-subquery? table) 122 | (raise-argument-error 'delete "a real table to delete from" table)) 123 | 124 | (query schema opts (ast:make-delete 125 | #:from (ast:make-from #:tables (list table)) 126 | #:where where))])) 127 | 128 | (define (from source #:as alias) 129 | (define alias:str (symbol->string alias)) 130 | (cond 131 | [(string? source) 132 | (make-query 133 | (ast:make-select 134 | #:from (ast:make-from 135 | #:tables (list (ast:as (ast:table source) alias:str)))))] 136 | 137 | [(symbol? source) 138 | (define schema (schema-registry-lookup source)) 139 | (make-query 140 | #:schema schema 141 | (ast:make-select 142 | #:from (ast:make-from 143 | #:tables (list (ast:as (ast:table (schema-table schema)) alias:str))) 144 | #:columns (for/list ([f (in-list (schema-fields/nonvirtual schema))]) 145 | (ast:column (ast:qualified alias:str (field-name f))))))] 146 | 147 | [(ast:subquery? source) 148 | (make-query 149 | (ast:make-select 150 | #:from (ast:make-from #:tables (list (ast:as source alias:str)))))] 151 | 152 | [else 153 | (raise-argument-error 'form "a table name, a schema name or a subquery" source)])) 154 | 155 | (define (join q 156 | #:type type 157 | #:lateral? lateral? 158 | #:with tbl-e 159 | #:as alias 160 | #:on constraint) 161 | (define tbl-clause 162 | (match tbl-e 163 | [(? ast:subquery?) tbl-e] 164 | [_ (ast:table 165 | (cond 166 | [(string? tbl-e) tbl-e] 167 | [else (schema-table (schema-registry-lookup tbl-e))]))])) 168 | 169 | (match q 170 | [(query schema opts stmt) 171 | (query schema opts (struct-copy ast:select stmt 172 | [from (add-join 173 | (ast:select-from stmt) 174 | (ast:join type lateral? (ast:as tbl-clause alias) constraint))]))])) 175 | 176 | (define (select q column0 177 | #:distinct? [distinct? #f] 178 | . columns) 179 | (match q 180 | [(query _ opts stmt) 181 | (query #f opts (struct-copy ast:select stmt 182 | [distinct? distinct?] 183 | [columns (cons column0 columns)]))])) 184 | 185 | (define (select-for-schema q schema-or-id tbl-alias customizations) 186 | (define s (schema-registry-lookup schema-or-id)) 187 | (define q* (apply select q (for/list ([fld (schema-fields s)]) 188 | (hash-ref customizations 189 | (field-id fld) 190 | (lambda () 191 | (ast:qualified tbl-alias (field-name fld))))))) 192 | (project-onto q* s)) 193 | 194 | (define (limit q n) 195 | (match q 196 | [(query schema opts stmt) 197 | (query schema opts (struct-copy ast:select stmt [limit (ast:limit n)]))])) 198 | 199 | (define (group-by q column0 . columns) 200 | (define all-columns 201 | (cons column0 columns)) 202 | 203 | (match q 204 | [(query schema opts (and (struct* ast:select ([group-by #f])) stmt)) 205 | (query schema opts (struct-copy ast:select stmt [group-by (ast:group-by all-columns)]))] 206 | 207 | [(query schema opts (and (struct* ast:select ([group-by (ast:group-by existing-columns)])) stmt)) 208 | (query schema opts (struct-copy ast:select stmt [group-by (ast:group-by (append existing-columns all-columns))]))])) 209 | 210 | (define (offset q n) 211 | (match q 212 | [(query schema opts stmt) 213 | (query schema opts (struct-copy ast:select stmt [offset (ast:offset n)]))])) 214 | 215 | (define ordering/c 216 | (list/c ast:expr? (or/c 'asc 'desc) (or/c #f 'nulls-first 'nulls-last))) 217 | 218 | (define (union q1 q2) 219 | (define (union* s1 s2) 220 | (match s1 221 | [(struct* ast:select ([union #f])) 222 | (struct-copy ast:select s1 [union (ast:union s2)])] 223 | 224 | [(struct* ast:select ([union u])) 225 | (struct-copy ast:select s1 [union (ast:union (union* (ast:union-stmt u) s2))])])) 226 | 227 | (match q1 228 | [(query schema opts (and (struct* ast:select ([union #f])) stmt)) 229 | (query schema opts (struct-copy ast:select stmt [union (ast:union (query-stmt q2))]))] 230 | 231 | [(query schema opts (and (struct* ast:select ([union u])) stmt)) 232 | (query schema opts (struct-copy ast:select stmt [union (ast:union (union* (ast:union-stmt u) (query-stmt q2)))]))])) 233 | 234 | (define (order-by q ordering0 . orderings) 235 | (define all-orderings 236 | (cons ordering0 orderings)) 237 | 238 | (match q 239 | [(query schema opts (and (struct* ast:select ([order-by #f])) stmt)) 240 | (query schema opts (struct-copy ast:select stmt [order-by (ast:order-by all-orderings)]))] 241 | 242 | [(query schema opts (and (struct* ast:select ([order-by (ast:order-by existing-orderings)])) stmt)) 243 | (query schema opts (struct-copy ast:select stmt [order-by (ast:order-by (append existing-orderings all-orderings))]))])) 244 | 245 | (define (project-onto q s) 246 | (struct-copy query q [schema s])) 247 | 248 | (define (project-virtual-fields q) 249 | (struct-copy query q [opts (opts #t)])) 250 | 251 | (define (returning q e0 . es) 252 | (define all-exprs 253 | (cons e0 es)) 254 | 255 | (define (append-exprs e) 256 | (match e 257 | [#f 258 | (ast:returning all-exprs)] 259 | 260 | [(ast:returning existing-exprs) 261 | (ast:returning (append existing-exprs all-exprs))])) 262 | 263 | (match q 264 | [(query schema opts (and (? ast:insert?) stmt)) 265 | (query schema opts (struct-copy ast:insert stmt [returning (append-exprs (ast:insert-returning stmt))]))] 266 | 267 | [(query schema opts (and (? ast:update?) stmt)) 268 | (query schema opts (struct-copy ast:update stmt [returning (append-exprs (ast:update-returning stmt))]))] 269 | 270 | [(query schema opts (and (? ast:delete?) stmt)) 271 | (query schema opts (struct-copy ast:delete stmt [returning (append-exprs (ast:delete-returning stmt))]))])) 272 | 273 | (define (subquery q) 274 | (ast:subquery (query-stmt q))) 275 | 276 | (define (update q assignment0 . assignments) 277 | (define all-assignments 278 | (cons assignment0 assignments)) 279 | 280 | (match q 281 | [(query schema opts (struct* ast:select 282 | ([from (ast:from (list table) _)] 283 | [where where]))) 284 | (when (contains-subquery? table) 285 | (raise-argument-error 'update "a table to update" table)) 286 | 287 | (query schema opts (ast:make-update 288 | #:table table 289 | #:assignments (ast:assignments all-assignments) 290 | #:where where))])) 291 | 292 | (define (where q e) 293 | (match q 294 | [(query schema opts (and (struct* ast:select ([where #f])) stmt)) 295 | (query schema opts (struct-copy ast:select stmt [where (ast:where e)]))] 296 | 297 | [(query schema opts (and (struct* ast:update ([where #f])) stmt)) 298 | (query schema opts (struct-copy ast:update stmt [where (ast:where e)]))] 299 | 300 | [(query schema opts (and (struct* ast:delete ([where #f])) stmt)) 301 | (query schema opts (struct-copy ast:delete stmt [where (ast:where e)]))] 302 | 303 | [(query schema opts (and (struct* ast:select ([where (ast:where e0)])) stmt)) 304 | (query schema opts (struct-copy ast:select stmt [where (ast:where (ast:app (ast:ident 'and) (list e0 e)))]))] 305 | 306 | [(query schema opts (and (struct* ast:update ([where (ast:where e0)])) stmt)) 307 | (query schema opts (struct-copy ast:update stmt [where (ast:where (ast:app (ast:ident 'and) (list e0 e)))]))] 308 | 309 | [(query schema opts (and (struct* ast:delete ([where (ast:where e0)])) stmt)) 310 | (query schema opts (struct-copy ast:delete stmt [where (ast:where (ast:app (ast:ident 'and) (list e0 e)))]))])) 311 | 312 | (define (or-where q e) 313 | (match q 314 | [(query schema opts (and (struct* ast:select ([where #f])) stmt)) 315 | (query schema opts (struct-copy ast:select stmt [where (ast:where e)]))] 316 | 317 | [(query schema opts (and (struct* ast:update ([where #f])) stmt)) 318 | (query schema opts (struct-copy ast:update stmt [where (ast:where e)]))] 319 | 320 | [(query schema opts (and (struct* ast:delete ([where #f])) stmt)) 321 | (query schema opts (struct-copy ast:delete stmt [where (ast:where e)]))] 322 | 323 | [(query schema opts (and (struct* ast:select ([where (ast:where e0)])) stmt)) 324 | (query schema opts (struct-copy ast:select stmt [where (ast:where (ast:app (ast:ident 'or) (list e0 e)))]))] 325 | 326 | [(query schema opts (and (struct* ast:update ([where (ast:where e0)])) stmt)) 327 | (query schema opts (struct-copy ast:update stmt [where (ast:where (ast:app (ast:ident 'or) (list e0 e)))]))] 328 | 329 | [(query schema opts (and (struct* ast:delete ([where (ast:where e0)])) stmt)) 330 | (query schema opts (struct-copy ast:delete stmt [where (ast:where (ast:app (ast:ident 'or) (list e0 e)))]))])) 331 | -------------------------------------------------------------------------------- /deta-lib/private/schema.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/contract/base 4 | "field.rkt") 5 | 6 | ;; struct ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 7 | 8 | (provide 9 | (struct-out schema) 10 | make-schema 11 | schema-fields/nonvirtual) 12 | 13 | (struct schema 14 | (id 15 | table 16 | virtual? 17 | struct-ctor 18 | struct-pred 19 | meta-updater 20 | pre-persist-hook 21 | pre-delete-hook 22 | fields 23 | primary-key)) 24 | 25 | (define (make-schema #:id id 26 | #:table table 27 | #:virtual? virtual? 28 | #:struct-ctor struct-ctor 29 | #:struct-pred struct-pred 30 | #:meta-updater meta-updater 31 | #:pre-persist-hook pre-persist-hook 32 | #:pre-delete-hook pre-delete-hook 33 | #:fields fields) 34 | 35 | (define pk-fields 36 | (filter field-primary-key? fields)) 37 | (when (> (length pk-fields) 1) 38 | (raise-arguments-error 'make-schema 39 | "at most one field may be marked as a #:primary-key" 40 | "bad fields" (map field-id pk-fields))) 41 | 42 | (define the-schema 43 | (schema id 44 | table 45 | virtual? 46 | struct-ctor 47 | struct-pred 48 | meta-updater 49 | pre-persist-hook 50 | pre-delete-hook 51 | fields 52 | (findf field-primary-key? pk-fields))) 53 | 54 | (begin0 the-schema 55 | (unless virtual? 56 | (register! id the-schema)))) 57 | 58 | (define (schema-fields/nonvirtual the-schema) 59 | (filter (compose1 not field-virtual?) 60 | (schema-fields the-schema))) 61 | 62 | ;; registry ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 63 | 64 | (provide 65 | (contract-out 66 | [current-schema-registry (parameter/c (hash/c symbol? schema?))] 67 | [schema-registry-allow-conflicts? (parameter/c boolean?)] 68 | [schema-registry-lookup (-> (or/c schema? symbol?) schema?)])) 69 | 70 | (define schema-registry-allow-conflicts? 71 | (make-parameter #f)) 72 | 73 | (define current-schema-registry 74 | (make-parameter (make-hasheq))) 75 | 76 | (define (register! id s) 77 | (define registry (current-schema-registry)) 78 | (when (and (hash-has-key? registry id) (not (schema-registry-allow-conflicts?))) 79 | (raise-user-error 'register! "a schema with id ~s is already registered" id)) 80 | 81 | (hash-set! registry id s)) 82 | 83 | (define (schema-registry-lookup schema-or-id) 84 | (cond 85 | [(schema? schema-or-id) 86 | schema-or-id] 87 | 88 | [else 89 | (hash-ref 90 | (current-schema-registry) 91 | schema-or-id 92 | (lambda () 93 | (raise-user-error 'lookup-schema "unregistered schema~n id: ~s" schema-or-id)))])) 94 | -------------------------------------------------------------------------------- /deta-lib/private/type.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require db 4 | racket/generic) 5 | 6 | (provide 7 | gen:type 8 | type? 9 | type-contract 10 | type-declaration 11 | type-load 12 | type-load/null 13 | type-dump 14 | type-dump/null) 15 | 16 | (define-generics type 17 | (type-contract type) 18 | (type-declaration type dialect) 19 | (type-load type dialect v) 20 | (type-dump type dialect v)) 21 | 22 | (define (type-load/null type dialect v) 23 | (if (sql-null? v) 24 | sql-null 25 | (type-load type dialect v))) 26 | 27 | (define (type-dump/null type dialect v) 28 | (if (sql-null? v) 29 | sql-null 30 | (type-dump type dialect v))) 31 | -------------------------------------------------------------------------------- /deta-lib/query.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require (for-syntax racket/base 4 | racket/match 5 | racket/string 6 | syntax/parse/pre 7 | "private/field.rkt") 8 | (except-in db 9 | query) 10 | racket/contract/base 11 | racket/match 12 | racket/sequence 13 | racket/set 14 | (prefix-in ast: "private/ast.rkt") 15 | "private/connection.rkt" 16 | "private/dialect/dialect.rkt" 17 | "private/entity.rkt" 18 | "private/field.rkt" 19 | "private/meta.rkt" 20 | (prefix-in dyn: "private/query.rkt") 21 | "private/schema.rkt" 22 | "private/type.rkt") 23 | 24 | ;; ddl ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 25 | 26 | (provide 27 | (contract-out 28 | [create-all! (-> connection? void?)] 29 | [drop-all! (-> connection? void?)] 30 | [create-table! (-> connection? (or/c schema? symbol?) void?)] 31 | [drop-table! (-> connection? (or/c schema? symbol?) void?)])) 32 | 33 | (define (create-all! conn) 34 | (for ([schema (in-hash-values (current-schema-registry))]) 35 | (create-table! conn schema))) 36 | 37 | (define (drop-all! conn) 38 | (for ([schema (in-hash-values (current-schema-registry))]) 39 | (drop-table! conn schema))) 40 | 41 | (define (create-table! conn schema-or-name) 42 | (define schema (schema-registry-lookup schema-or-name)) 43 | (query-exec conn (dialect-emit-ddl (connection-dialect conn) 44 | (ast:create-table (schema-table schema) 45 | (schema-fields/nonvirtual schema))))) 46 | 47 | (define (drop-table! conn schema-or-name) 48 | (define schema (schema-registry-lookup schema-or-name)) 49 | (query-exec conn (dialect-emit-ddl (connection-dialect conn) 50 | (ast:drop-table (schema-table schema))))) 51 | 52 | 53 | ;; insert ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 54 | 55 | (provide 56 | (contract-out 57 | [insert! (-> connection? entity? ... (listof entity?))] 58 | [insert-one! (-> connection? entity? (or/c #f entity?))])) 59 | 60 | (define (insert! conn . entities) 61 | (define dialect (connection-dialect conn)) 62 | (for/list ([entity (in-list entities)] #:when (meta-can-persist? (entity-meta entity))) 63 | (insert-entity! dialect conn entity))) 64 | 65 | (define (insert-one! conn entity) 66 | (match (insert! conn entity) 67 | [(list entity) entity] 68 | [_ #f])) 69 | 70 | (define (insert-entity! dialect conn entity) 71 | (define meta (entity-meta entity)) 72 | (define schema (meta-schema meta)) 73 | (when (schema-virtual? schema) 74 | (raise-user-error 'insert-entity! "cannot insert entity ~v because it has a virtual schema" entity)) 75 | 76 | (let ([entity ((schema-pre-persist-hook schema) entity)]) 77 | (define-values (columns column-values) 78 | (for*/fold ([columns null] 79 | [column-values null]) 80 | ([f (in-list (schema-fields schema))] 81 | #:unless (or (field-auto-increment? f) 82 | (field-virtual? f))) 83 | (values (cons (field-name f) columns) 84 | (cons (type-dump/null (field-type f) 85 | (dialect-name dialect) 86 | ((field-getter f) entity)) 87 | column-values)))) 88 | 89 | (define pk 90 | (let ([pk (schema-primary-key schema)]) 91 | (and pk (field-auto-increment? pk) pk))) 92 | (define stmt 93 | (ast:make-insert 94 | #:into (ast:table (schema-table schema)) 95 | #:columns (map ast:column columns) 96 | #:values (map ast:placeholder column-values) 97 | #:returning (and pk (ast:returning (list (ast:column (field-name pk))))))) 98 | 99 | (define-values (query args) 100 | (dialect-emit-query dialect stmt)) 101 | 102 | (let ([e ((schema-meta-updater schema) entity meta-track-persisted)]) 103 | (cond 104 | [pk 105 | (define id 106 | (if (dialect-supports-returning? dialect) 107 | (apply query-value conn query args) 108 | (call-with-transaction conn 109 | (lambda () 110 | (apply query-exec conn query args) 111 | (query-value conn (dialect-last-id-query dialect)))))) 112 | 113 | ((field-setter pk) e id #f)] 114 | 115 | [else 116 | (begin0 e 117 | (apply query-exec conn query args))])))) 118 | 119 | 120 | ;; update ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 121 | 122 | (provide 123 | (contract-out 124 | [update! (->* [connection?] 125 | [#:force? boolean?] 126 | #:rest (listof entity?) 127 | (listof entity?))] 128 | [update-one! (->* [connection? entity?] 129 | [#:force? boolean?] 130 | (or/c #f entity?))])) 131 | 132 | (define (update! conn #:force? [force? #f] . entities) 133 | (define dialect (connection-dialect conn)) 134 | (define maybe-updated 135 | (for/list ([entity (in-list entities)]) 136 | (update-entity! dialect conn entity force?))) 137 | (filter values maybe-updated)) 138 | 139 | (define (update-one! conn entity #:force? [force? #f]) 140 | (match (update! conn entity #:force? force?) 141 | [(list e) e] 142 | [_ #f])) 143 | 144 | (define (update-entity! dialect conn entity force?) 145 | (define schema (meta-schema (entity-meta entity))) 146 | (define pk (schema-primary-key schema)) 147 | (unless pk 148 | (raise-argument-error 'update-entity! "entity with primary key field" entity)) 149 | 150 | (cond 151 | [(or force? (meta-can-update? (entity-meta entity))) 152 | (define entity* ((schema-pre-persist-hook schema) entity)) 153 | (define changes (meta-changes (entity-meta entity*))) 154 | (define-values (columns column-values) 155 | (for*/fold ([columns null] 156 | [column-values null]) 157 | ([f (in-list (schema-fields schema))] 158 | #:when (or force? (set-member? changes (field-id f))) 159 | #:unless (or (field-auto-increment? f) (field-virtual? f))) 160 | (values (cons (field-name f) columns) 161 | (cons (type-dump/null (field-type f) 162 | (dialect-name dialect) 163 | ((field-getter f) entity*)) 164 | column-values)))) 165 | (cond 166 | [(null? columns) #f] 167 | [else 168 | (define stmt 169 | (ast:make-update 170 | #:table (ast:table (schema-table schema)) 171 | #:assignments (ast:assignments 172 | (for/list ([column (in-list columns)] 173 | [value (in-list column-values)]) 174 | (cons (ast:column column) 175 | (ast:placeholder value)))) 176 | #:where (ast:where (ast:app (ast:ident '=) 177 | (list (ast:column (field-name pk)) 178 | (ast:placeholder (type-dump/null (field-type pk) 179 | (dialect-name dialect) 180 | ((field-getter pk) entity*)))))))) 181 | 182 | (define-values (query args) 183 | (dialect-emit-query dialect stmt)) 184 | 185 | (apply query-exec conn query args) 186 | ((schema-meta-updater schema) entity* meta-track-persisted)])] 187 | 188 | [else #f])) 189 | 190 | 191 | ;; delete ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 192 | 193 | (provide 194 | (contract-out 195 | [delete! (-> connection? entity? ... (listof entity?))] 196 | [delete-one! (-> connection? entity? (or/c #f entity?))])) 197 | 198 | (define (delete! conn . entities) 199 | (define dialect (connection-dialect conn)) 200 | (for/list ([entity (in-list entities)] #:when (meta-can-delete? (entity-meta entity))) 201 | (delete-entity! dialect conn entity))) 202 | 203 | (define (delete-one! conn entity) 204 | (match (delete! conn entity) 205 | [(list e) e] 206 | [_ #f])) 207 | 208 | (define (delete-entity! dialect conn entity) 209 | (define meta (entity-meta entity)) 210 | (define schema (meta-schema meta)) 211 | (define pk (schema-primary-key schema)) 212 | (unless pk 213 | (raise-argument-error 'delete-entity! "entity with primary key field" entity)) 214 | 215 | (let ([entity ((schema-pre-delete-hook schema) entity)]) 216 | (define stmt 217 | (ast:make-delete 218 | #:from (ast:make-from #:tables (list (ast:table (schema-table schema)))) 219 | #:where (ast:where (ast:app (ast:ident '=) 220 | (list (ast:column (field-name pk)) 221 | (ast:placeholder (type-dump/null (field-type pk) 222 | (dialect-name dialect) 223 | ((field-getter pk) entity)))))))) 224 | 225 | (define-values (query args) 226 | (dialect-emit-query dialect stmt)) 227 | 228 | (apply query-exec conn query args) 229 | ((schema-meta-updater schema) entity meta-track-deleted))) 230 | 231 | 232 | ;; select ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 233 | 234 | (provide 235 | (contract-out 236 | [in-entities (->* [connection? dyn:query?] 237 | [#:batch-size (or/c exact-positive-integer? +inf.0)] 238 | sequence?)] 239 | [query-entities (->* [connection? dyn:query?] 240 | [#:batch-size (or/c exact-positive-integer? +inf.0)] 241 | (listof entity?))] 242 | [lookup (-> connection? dyn:query? any)]) 243 | 244 | from 245 | group-by 246 | join 247 | limit 248 | offset 249 | or-where 250 | order-by 251 | returning 252 | select 253 | select-for-schema 254 | update 255 | where 256 | 257 | (rename-out 258 | [dyn:query? query?] 259 | [dyn:delete delete] 260 | [dyn:union union] 261 | [dyn:project-onto project-onto] 262 | [dyn:project-virtual-fields project-virtual-fields]) 263 | 264 | (contract-out 265 | [make-entity 266 | (->* [(or/c connection? symbol?) schema? (listof any/c)] 267 | [#:project-virtual-fields? boolean?] 268 | entity?)])) 269 | 270 | (define (make-entity conn-or-dialect schema cols 271 | #:project-virtual-fields? [project-virtual? #f]) 272 | (define dialect 273 | (if (connection? conn-or-dialect) 274 | (dbsystem-name (connection-dbsystem conn-or-dialect)) 275 | conn-or-dialect)) 276 | (define pairs 277 | (for/fold ([pairs null]) 278 | ([f (in-list (if project-virtual? 279 | (schema-fields schema) 280 | (schema-fields/nonvirtual schema)))] 281 | [v (in-list cols)]) 282 | (cons (cons (field-kwd f) 283 | (type-load/null (field-type f) dialect v)) 284 | pairs))) 285 | 286 | (define pairs/sorted 287 | (sort pairs keyword (lambda (s) 318 | (define project-virtual? 319 | (dyn:opts-project-virtual-fields? (dyn:query-opts q))) 320 | 321 | (sequence-map 322 | (lambda cols 323 | (make-entity dialect s cols 324 | #:project-virtual-fields? project-virtual?)) 325 | results-seq))] 326 | 327 | [else 328 | results-seq])) 329 | 330 | (define query-entities 331 | (procedure-rename 332 | (make-keyword-procedure 333 | (lambda (kws kw-args . args) 334 | (sequence->list 335 | (keyword-apply in-entities kws kw-args args)))) 336 | 'query-entities)) 337 | 338 | (define (lookup conn q) 339 | (define-values (res _) 340 | (sequence-generate* (in-entities conn q))) 341 | (and res (apply values res))) 342 | 343 | (begin-for-syntax 344 | (define column-reference-re 345 | #rx"^([^\\.]+)\\.([^\\.]+)$") 346 | 347 | (define (column-reference? id) 348 | (regexp-match? column-reference-re (symbol->string id))) 349 | 350 | (define (syntax->column-reference stx) 351 | (match-define (list _ a b) 352 | (regexp-match column-reference-re (symbol->string (syntax->datum stx)))) 353 | 354 | (cons (datum->syntax stx a) 355 | (datum->syntax stx (id->column-name b)))) 356 | 357 | (define-syntax-class placeholder-expr 358 | #:literals (unquote) 359 | (pattern (unquote placeholder) #:with e #'(ast:placeholder placeholder))) 360 | 361 | (define-syntax-class fragment-expr 362 | #:literals (fragment) 363 | (pattern (fragment node:expr) 364 | #:with e #'(ast:make-fragment node))) 365 | 366 | (define-syntax-class subquery-expr 367 | #:literals (subquery) 368 | (pattern (subquery q:expr) #:with e #'(dyn:subquery q))) 369 | 370 | (define-syntax-class q-source 371 | #:literals (unquote) 372 | (pattern schema:id #:with e #''schema) 373 | (pattern table:str #:with e #'table) 374 | (pattern sub:subquery-expr #:with e #'sub.e) 375 | (pattern (unquote e:expr))) 376 | 377 | (define-syntax-class q-expr 378 | #:datum-literals (list null) 379 | #:literals (array as and case cond else or quote subquery unquote-splicing) 380 | (pattern column-reference:id 381 | #:when (column-reference? (syntax->datum this-syntax)) 382 | #:with e (let ([ref (syntax->column-reference this-syntax)]) 383 | #`(ast:qualified #,(car ref) #,(cdr ref)))) 384 | 385 | (pattern placeholder:placeholder-expr 386 | #:with e #'placeholder.e) 387 | 388 | (pattern fragment:fragment-expr 389 | #:with e #'fragment.e) 390 | 391 | (pattern ident:id 392 | #:with e #'(ast:ident 'ident)) 393 | 394 | (pattern b:boolean 395 | #:with e #'(ast:scalar b)) 396 | 397 | (pattern s:string 398 | #:with e #'(ast:scalar s)) 399 | 400 | (pattern n:number 401 | #:when (rational? (syntax->datum #'n)) 402 | #:with e #'(ast:scalar n)) 403 | 404 | (pattern (array item:q-expr ...) 405 | #:with e #'(ast:scalar (vector item.e ...))) 406 | 407 | (pattern (as a:q-expr b:id) 408 | #:with e #'(ast:as a.e 'b)) 409 | 410 | (pattern (and a:q-expr b:q-expr) 411 | #:with e #'(ast:app (ast:ident 'and) (list a.e b.e))) 412 | 413 | (pattern ((~or case cond) [c:q-expr v:q-expr] ...+ 414 | [else ve:q-expr]) 415 | #:with e #'(ast:case-e (list (cons c.e v.e) ...) ve.e)) 416 | 417 | (pattern ((~or case cond) [c:q-expr v:q-expr] ...+) 418 | #:with e #'(ast:case-e (list (cons c.e v.e) ...) #f)) 419 | 420 | (pattern (list item:q-expr ...) 421 | #:with e #'(ast:scalar (list item.e ...))) 422 | 423 | (pattern (quote (item:q-expr ...)) 424 | #:with e #'(ast:scalar (list item.e ...))) 425 | 426 | (pattern (unquote-splicing items:expr) 427 | #:with e #'(ast:scalar (map ast:scalar items))) 428 | 429 | (pattern (or a:q-expr b:q-expr) 430 | #:with e #'(ast:app (ast:ident 'or) (list a.e b.e))) 431 | 432 | (pattern (subquery q) 433 | #:with e #'(ast:subquery (dyn:query-stmt q))) 434 | 435 | (pattern (fun:q-expr arg:q-expr ...) 436 | #:with e #'(ast:app fun.e (list arg.e ...)))) 437 | 438 | (define-syntax-class q-assignment 439 | (pattern [column:id value:q-expr] 440 | #:fail-when (string-contains? (symbol->string (syntax->datum #'column)) ".") 441 | "assignments may not be qualified" 442 | #:with e (with-syntax ([name (datum->syntax #'r (id->column-name (syntax->datum #'column)))]) 443 | #'(cons (ast:column name) value.e)))) 444 | 445 | (define-syntax-class q-ordering 446 | #:literals (unquote) 447 | (pattern [column:q-expr (~optional 448 | (~seq (~or (~and #:asc dir-asc ) 449 | (~and #:desc dir-desc) 450 | (unquote dir-expr:expr)) 451 | (~optional 452 | (~or (~and #:nulls-first nulls-first*) 453 | (~and #:nulls-last nulls-last* ) 454 | (unquote nulls-expr:expr)))))] 455 | #:with dir 456 | (cond [(attribute dir-expr) #'dir-expr] 457 | [(attribute dir-desc) #''desc] 458 | [else #''asc]) 459 | #:with nulls-dir 460 | (cond [(attribute nulls-expr) #'nulls-expr] 461 | [(attribute nulls-first*) #''nulls-first] 462 | [(attribute nulls-last*) #''nulls-last] 463 | [else #'#f]) 464 | #:with e #'(list column.e dir nulls-dir)))) 465 | 466 | (define-syntax (from stx) 467 | (syntax-parse stx 468 | [(_ source:q-source #:as alias:id) 469 | #'(dyn:from source.e #:as 'alias)])) 470 | 471 | (define-syntax (group-by stx) 472 | (syntax-parse stx 473 | [(_ q:expr e:q-expr ...+) 474 | #'(dyn:group-by q e.e ...)])) 475 | 476 | (define-syntax (join stx) 477 | (define-syntax-class qualified-join-type 478 | (pattern #:inner #:with type #''inner) 479 | (pattern #:left #:with type #''left) 480 | (pattern #:right #:with type #''right) 481 | (pattern #:full #:with type #''full)) 482 | 483 | (syntax-parse stx 484 | [(_ q:expr 485 | #:cross 486 | (~optional (~and #:lateral lateral)) 487 | source:q-source 488 | #:as alias:id) 489 | #:with lateral? (if (attribute lateral) #'#t #'#f) 490 | #'(dyn:join q 491 | #:type 'cross 492 | #:lateral? lateral? 493 | #:with source.e 494 | #:as 'alias 495 | #:on #f)] 496 | [(_ q:expr 497 | (~optional t:qualified-join-type) 498 | (~optional (~and #:lateral lateral)) 499 | source:q-source 500 | #:as alias:id 501 | #:on constraint:q-expr) 502 | #:with type #'(~? t.type 'inner) 503 | #:with lateral? (if (attribute lateral) #'#t #'#f) 504 | #'(dyn:join q 505 | #:type type 506 | #:lateral? lateral? 507 | #:with source.e 508 | #:as 'alias 509 | #:on constraint.e)])) 510 | 511 | (define-syntax (limit stx) 512 | (syntax-parse stx 513 | [(_ q:expr n:number) 514 | #:fail-when (and (not (exact-nonnegative-integer? (syntax->datum #'n))) #'n) 515 | "n must be a positive integer" 516 | #'(dyn:limit q (ast:scalar n))] 517 | 518 | [(_ q:expr p:placeholder-expr) 519 | #'(dyn:limit q p.e)])) 520 | 521 | (define-syntax (offset stx) 522 | (syntax-parse stx 523 | [(_ q:expr n:number) 524 | #:fail-when (and (not (exact-nonnegative-integer? (syntax->datum #'n))) #'n) 525 | "n must be a positive integer" 526 | #'(dyn:offset q (ast:scalar n))] 527 | 528 | [(_ q:expr p:placeholder-expr) 529 | #'(dyn:offset q p.e)])) 530 | 531 | (define-syntax (or-where stx) 532 | (syntax-parse stx 533 | [(_ q:expr e:q-expr) 534 | #'(dyn:or-where q e.e)])) 535 | 536 | (define-syntax (order-by stx) 537 | (syntax-parse stx 538 | [(_ q:expr (e:q-ordering ...+)) 539 | #'(dyn:order-by q e.e ...)])) 540 | 541 | (define-syntax (returning stx) 542 | (syntax-parse stx 543 | [(_ q:expr e:q-expr ...+) 544 | #'(dyn:returning q e.e ...)])) 545 | 546 | (define-syntax (select stx) 547 | (define-syntax-class from-expr 548 | #:datum-literals (_) 549 | (pattern _ #:with e #'(dyn:make-empty-query)) 550 | (pattern e:expr)) 551 | 552 | (syntax-parse stx 553 | [(_ q:from-expr 554 | (~alt (~optional (~and #:distinct distinct))) ... 555 | e:q-expr ...+) 556 | #:with distinct? (if (attribute distinct) #'#t #'#f) 557 | #'(dyn:select 558 | #:distinct? distinct? 559 | q.e e.e ...)])) 560 | 561 | (define-syntax (select-for-schema stx) 562 | (define-syntax-class schema-expr 563 | #:literals (unquote) 564 | (pattern schema:id #:with e #''schema) 565 | (pattern (unquote e:expr))) 566 | 567 | (syntax-parse stx 568 | [(_ q:expr schema:schema-expr 569 | #:from tbl-alias:id) 570 | #'(select-for-schema q schema #:from tbl-alias #:customizing ())] 571 | 572 | [(_ q:expr schema:schema-expr 573 | #:from tbl-alias:id 574 | #:customizing ([fld-id:id e:q-expr] ...)) 575 | #'(dyn:select-for-schema q schema.e 576 | (symbol->string 'tbl-alias) 577 | (make-hasheq (list (cons 'fld-id e.e) ...)))])) 578 | 579 | (define-syntax (update stx) 580 | (syntax-parse stx 581 | [(_ q:expr ass:q-assignment ...+) 582 | #'(dyn:update q ass.e ...)])) 583 | 584 | (define-syntax (where stx) 585 | (syntax-parse stx 586 | [(_ q:expr e:q-expr) 587 | #'(dyn:where q e.e)])) 588 | -------------------------------------------------------------------------------- /deta-lib/reflect.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "private/field.rkt" 4 | "private/schema.rkt" 5 | "private/type.rkt") 6 | 7 | (provide 8 | current-schema-registry 9 | schema-registry-allow-conflicts? 10 | schema-registry-lookup 11 | 12 | schema-virtual? 13 | schema-fields 14 | schema-table 15 | 16 | field? 17 | field-id 18 | field-name 19 | field-type 20 | 21 | type? 22 | type-declaration) 23 | -------------------------------------------------------------------------------- /deta-lib/schema.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require (for-syntax racket/base 4 | racket/contract/base 5 | racket/list 6 | racket/provide-transform 7 | racket/struct-info 8 | racket/syntax 9 | syntax/parse/experimental/template 10 | syntax/parse/pre) 11 | db 12 | racket/contract/base 13 | racket/contract/region 14 | "private/entity.rkt" 15 | "private/field.rkt" 16 | "private/meta.rkt" 17 | "private/schema.rkt" 18 | "private/type.rkt") 19 | 20 | ;; schema ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 21 | 22 | (provide 23 | entity? 24 | entity-meta 25 | entity-schema 26 | entity->hash 27 | 28 | define-schema 29 | schema? 30 | schema-out) 31 | 32 | ;; Terms: 33 | ;; * anything ending in *id refers to a binding 34 | ;; * anything ending in *name refers to that thing's name in the database table 35 | (begin-for-syntax 36 | (define (pluralize name) 37 | (format "~as" name)) 38 | 39 | (define syntax->keyword 40 | (compose1 string->keyword symbol->string syntax->datum)) 41 | 42 | (define-template-metafunction (make-fld-setter stx) 43 | (syntax-parse stx 44 | [(_ struct-id struct-pred-id fld-id fld-contract fld-wrapper) 45 | (with-syntax ([setter-id (format-id #'struct-id "set-~a-~a" #'struct-id #'fld-id)]) 46 | #'(define/contract (setter-id e v [track-change? #t]) 47 | (->* (struct-pred-id fld-contract) (boolean?) struct-pred-id) 48 | (define meta 49 | (if track-change? 50 | (meta-track-change (entity-meta e) 'fld-id) 51 | (entity-meta e))) 52 | 53 | (struct-copy struct-id e 54 | [meta #:parent entity meta] 55 | [fld-id (fld-wrapper v)])))])) 56 | 57 | (define-template-metafunction (make-fld-updater stx) 58 | (syntax-parse stx 59 | [(_ struct-id struct-pred-id fld-id fld-contract fld-wrapper) 60 | (with-syntax ([getter-id (format-id #'struct-id "~a-~a" #'struct-id #'fld-id)] 61 | [updater-id (format-id #'struct-id "update-~a-~a" #'struct-id #'fld-id)]) 62 | #'(define/contract (updater-id e p [track-change? #t]) 63 | (->* (struct-pred-id (-> fld-contract fld-contract)) (boolean?) struct-pred-id) 64 | (define meta 65 | (if track-change? 66 | (meta-track-change (entity-meta e) 'fld-id) 67 | (entity-meta e))) 68 | 69 | (struct-copy struct-id e 70 | [meta #:parent entity meta] 71 | [fld-id (fld-wrapper (p (getter-id e)))])))])) 72 | 73 | (define-template-metafunction (make-fld-maker stx) 74 | (syntax-parse stx 75 | [(_ struct-id fld-id fld-name fld-type fld-pk? fld-ai? fld-nullable? fld-unique? fld-virtual?) 76 | (with-syntax ([getter-id (format-id #'struct-id "~a-~a" #'struct-id #'fld-id)] 77 | [setter-id (format-id #'struct-id "set-~a-~a" #'struct-id #'fld-id)] 78 | [updater-id (format-id #'struct-id "update-~a-~a" #'struct-id #'fld-id)]) 79 | #'(make-field #:id 'fld-id 80 | #:name fld-name 81 | #:type fld-type 82 | #:getter getter-id 83 | #:setter setter-id 84 | #:updater updater-id 85 | #:primary-key? fld-pk? 86 | #:auto-increment? fld-ai? 87 | #:nullable? fld-nullable? 88 | #:unique? fld-unique? 89 | #:virtual? fld-virtual?))])) 90 | 91 | (define-template-metafunction (make-ctor-contract stx) 92 | (syntax-parse stx 93 | [(_ [(fld-kwd fld-contract fld-required?) ...] struct-pred-id) 94 | (with-syntax ([((required-arg ...) ...) 95 | (filter-map (lambda (fld-kwd fld-contract fld-required?) 96 | (and (syntax->datum fld-required?) 97 | (quasisyntax/loc stx 98 | (#,fld-kwd #,fld-contract)))) 99 | (syntax-e #'(fld-kwd ...)) 100 | (syntax-e #'(fld-contract ...)) 101 | (syntax-e #'(fld-required? ...)))] 102 | [((optional-arg ...) ...) 103 | (filter-map (lambda (fld-kwd fld-contract fld-required?) 104 | (and (not (syntax->datum fld-required?)) 105 | (quasisyntax/loc stx 106 | (#,fld-kwd #,fld-contract)))) 107 | (syntax-e #'(fld-kwd ...)) 108 | (syntax-e #'(fld-contract ...)) 109 | (syntax-e #'(fld-required? ...)))]) 110 | #'(->* (required-arg ... ...) 111 | (optional-arg ... ...) 112 | struct-pred-id))])) 113 | 114 | (define-syntax-class fld 115 | (pattern (id:id type:expr (~alt (~optional (~and #:primary-key primary-key)) 116 | (~optional (~and #:auto-increment auto-increment)) 117 | (~optional (~and #:nullable nullable)) 118 | (~optional (~and #:unique unique)) 119 | (~optional (~seq #:name name-e:str)) 120 | (~optional (~seq #:contract contract-e:expr) #:defaults ([contract-e #'any/c])) 121 | (~optional (~seq #:wrapper wrapper:expr) #:defaults ([wrapper #'values]))) ...) 122 | #:fail-when (and (attribute primary-key) 123 | (attribute nullable)) 124 | "primary keys may not be nullable" 125 | 126 | #:with required? (if (or (attribute auto-increment) 127 | (attribute nullable)) #'#f #'t) 128 | #:with primary-key? (if (attribute primary-key) #'#t #'#f) 129 | #:with auto-increment? (if (attribute auto-increment) #'#t #'#f) 130 | #:with nullable? (if (attribute nullable) #'#t #'#f) 131 | #:with unique? (if (attribute unique) #'#t #'#f) 132 | #:with virtual? #'#f 133 | #:with name (if (attribute name-e) 134 | #'name-e 135 | #'(id->column-name 'id)) 136 | #:with contract (if (attribute nullable) 137 | #'(or/c sql-null? (and/c (type-contract type) contract-e)) 138 | #'(and/c (type-contract type) contract-e)) 139 | #:with ctor-kwd (syntax->keyword #'id) 140 | #:with ctor-arg (cond 141 | [(attribute primary-key) #'(ctor-kwd [id sql-null])] 142 | [(attribute nullable) #'(ctor-kwd [id sql-null])] 143 | [else #'(ctor-kwd id)])) 144 | 145 | (pattern ((id:id default:expr) type:expr (~alt (~optional (~and #:primary-key primary-key)) 146 | (~optional (~and #:auto-increment auto-increment)) 147 | (~optional (~and #:nullable nullable)) 148 | (~optional (~and #:unique unique)) 149 | (~optional (~and #:virtual virtual)) 150 | (~optional (~seq #:name name-e:str)) 151 | (~optional (~seq #:contract contract-e:expr) #:defaults ([contract-e #'any/c])) 152 | (~optional (~seq #:wrapper wrapper:expr) #:defaults ([wrapper #'values]))) ...) 153 | #:fail-when (and (attribute primary-key) 154 | (attribute nullable)) 155 | "primary keys may not be nullable" 156 | 157 | #:fail-when (and (attribute virtual) 158 | (or (attribute primary-key) 159 | (attribute auto-increment) 160 | (attribute nullable) 161 | (attribute unique) 162 | (attribute name-e))) 163 | "virtual fields may not have database-related attributes" 164 | 165 | #:with required? #'#f 166 | #:with primary-key? (if (attribute primary-key) #'#t #'#f) 167 | #:with auto-increment? (if (attribute auto-increment) #'#t #'#f) 168 | #:with nullable? (if (attribute nullable) #'#t #'#f) 169 | #:with unique? (if (attribute unique) #'#t #'#f) 170 | #:with virtual? (if (attribute virtual) #'#t #'#f) 171 | #:with name (if (attribute name-e) 172 | #'name-e 173 | #'(id->column-name 'id)) 174 | #:with contract (if (attribute nullable) 175 | #'(or/c sql-null? (and/c (type-contract type) contract-e)) 176 | #'(and/c (type-contract type) contract-e)) 177 | #:with ctor-kwd (syntax->keyword #'id) 178 | #:with ctor-arg #'(ctor-kwd [id default])))) 179 | 180 | (define-syntax (define-schema stx) 181 | (syntax-parse stx 182 | [(_ struct-id:id 183 | (~alt (~optional (~seq #:table table-name:str)) 184 | (~optional (~and #:virtual virtual))) ... 185 | (f:fld ...+) 186 | (~alt (~optional (~seq #:pre-persist-hook pre-persist-hook-e:expr) #:defaults ([pre-persist-hook-e #'values])) 187 | (~optional (~seq #:pre-delete-hook pre-delete-hook-e:expr) #:defaults ([pre-delete-hook-e #'values]))) ... 188 | struct-option ...) 189 | 190 | #:fail-when (> (length (filter values (syntax->datum #'(f.primary-key? ...)))) 1) 191 | "at most one field can be marked as a #:primary-key" 192 | 193 | (with-syntax* ([pluralized-name (datum->syntax #'struct-id (pluralize (syntax->datum #'struct-id)))] 194 | [table-name #'(~? table-name pluralized-name)] 195 | [virtual? (if (attribute virtual) #'#t #'#f)] 196 | [ctor-id (format-id #'struct-id "make-~a" #'struct-id)] 197 | [((ctor-arg ...) ...) #'(f.ctor-arg ...)] 198 | [meta-updater-id (format-id #'struct-id "update-~a-meta" #'struct-id)] 199 | [struct-ctor-id (gensym)] 200 | [struct-pred-id (format-id #'struct-id "~a?" #'struct-id)] 201 | [schema-id (format-id #'struct-id "~a-schema" #'struct-id)]) 202 | #'(begin 203 | (struct struct-id entity (f.id ...) 204 | #:constructor-name struct-ctor-id 205 | #:transparent 206 | struct-option ...) 207 | 208 | (define/contract (ctor-id ctor-arg ... ...) 209 | (make-ctor-contract [(f.ctor-kwd f.contract f.required?) ...] struct-pred-id) 210 | (struct-ctor-id (make-meta schema-id) 211 | (f.wrapper f.id) ...)) 212 | 213 | (define/contract (meta-updater-id e p) 214 | (-> entity? (-> meta? meta?) entity?) 215 | (struct-copy struct-id e [meta #:parent entity (p (entity-meta e))])) 216 | 217 | (begin (make-fld-setter struct-id struct-pred-id f.id f.contract f.wrapper) ...) 218 | (begin (make-fld-updater struct-id struct-pred-id f.id f.contract f.wrapper) ...) 219 | 220 | (define schema-id 221 | (make-schema #:id 'struct-id 222 | #:table table-name 223 | #:virtual? virtual? 224 | #:struct-ctor ctor-id 225 | #:struct-pred struct-pred-id 226 | #:meta-updater meta-updater-id 227 | #:pre-persist-hook (contract 228 | (-> struct-pred-id struct-pred-id) 229 | pre-persist-hook-e 230 | 'struct-id 'struct-id 231 | 'pre-persist-hook #f) 232 | #:pre-delete-hook (contract 233 | (-> struct-pred-id struct-pred-id) 234 | pre-delete-hook-e 235 | 'struct-id 'struct-id 236 | 'pre-delete-hook #f) 237 | #:fields (list (make-fld-maker struct-id 238 | f.id 239 | f.name 240 | f.type 241 | f.primary-key? 242 | f.auto-increment? 243 | f.nullable? 244 | f.unique? 245 | f.virtual?) ...)))))])) 246 | 247 | ;; Heavily inspired by: 248 | ;; https://github.com/racket/racket/blob/20e669f47842d47b085ddedc5782e4a95495653a/racket/collects/racket/private/reqprov.rkt#L978 249 | (define-syntax schema-out 250 | (make-provide-transformer 251 | (lambda (stx _modes) 252 | (syntax-parse stx 253 | [(_ struct-id:id) 254 | (define v (syntax-local-value #'struct-id (λ () #f))) 255 | (unless (struct-info? v) 256 | (raise-syntax-error #f "identifier is not bound to struct type information" stx #'struct-id)) 257 | 258 | (define info (extract-struct-info v)) 259 | (define accessors/without-super 260 | (for/list ([stx (in-list (list-ref info 3))] 261 | #:when (and stx (not (member (syntax->datum stx) 262 | '(entity-meta))))) 263 | stx)) 264 | 265 | (define accessors+setters+updaters 266 | (for/fold ([all null]) 267 | ([stx (in-list accessors/without-super)]) 268 | (append 269 | (list stx 270 | (format-id #'struct-id "set-~a" stx) 271 | (format-id #'struct-id "update-~a" stx)) 272 | all))) 273 | 274 | (define stxs 275 | (append 276 | (list 277 | #'struct-id 278 | (format-id #'struct-id "make-~a" #'struct-id) 279 | (format-id #'struct-id "~a-schema" #'struct-id) 280 | (list-ref info 0) 281 | (list-ref info 2)) 282 | accessors+setters+updaters)) 283 | 284 | (for/list ([stx (in-list stxs)]) 285 | (make-export stx (syntax-e stx) 0 #f stx))])))) 286 | -------------------------------------------------------------------------------- /deta-lib/type.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp racket/base 2 | 3 | (require (for-syntax racket/base 4 | racket/syntax 5 | syntax/parse/pre) 6 | db 7 | db/util/geometry 8 | db/util/postgresql 9 | racket/contract/base 10 | racket/format 11 | racket/lazy-require 12 | "private/type.rkt") 13 | 14 | (lazy-require 15 | [gregor (moment-provider? 16 | datetime-provider? 17 | date-provider? 18 | time-provider? 19 | moment 20 | datetime 21 | date 22 | time 23 | moment->iso8601/tzid 24 | datetime->iso8601 25 | date->iso8601 26 | iso8601/tzid->moment 27 | iso8601->datetime 28 | iso8601->date 29 | iso8601->time 30 | ->moment 31 | ->datetime/local 32 | ->date 33 | ->time 34 | ->year 35 | ->month 36 | ->day 37 | ->hours 38 | ->minutes 39 | ->seconds 40 | ->nanoseconds 41 | ->utc-offset)] 42 | [gregor/time (time->iso8601)] 43 | [json (jsexpr? 44 | string->jsexpr 45 | jsexpr->string)]) 46 | 47 | (provide 48 | type? 49 | define-type) 50 | 51 | (define (raise-dialect-error who d) 52 | (raise-user-error who "unsupported dialect ~s" d)) 53 | 54 | (define gen:type-contract type-contract) 55 | (define gen:type-declaration type-declaration) 56 | (define gen:type-load type-load) 57 | (define gen:type-dump type-dump) 58 | 59 | (define (get-type-declaration type dialect decl) 60 | (if (procedure? decl) 61 | (decl type dialect) 62 | decl)) 63 | 64 | (define-syntax (define-type stx) 65 | (syntax-parse stx 66 | [(_ id:id (~optional (fld:id ...)) 67 | (~alt 68 | (~optional (~or (~seq #:contract contract-e) 69 | (~seq #:contract-fn contract-fn-e))) 70 | (~optional (~seq #:declaration declaration-e)) 71 | (~optional (~seq #:load load-e)) 72 | (~optional (~seq #:dump dump-e)) 73 | (~optional (~seq #:constructor constructor-e))) ...) 74 | #:with id-field (format-id #'id "~a-field" #'id) 75 | #:with id-field? (format-id #'id "~a-field?" #'id) 76 | #:with id/f (format-id #'id "~a/f" #'id) 77 | #:with id/f? (format-id #'id "~a/f?" #'id) 78 | 79 | #:fail-unless (attribute declaration-e) 80 | "every type must have a #:declaration" 81 | 82 | #'(begin 83 | (provide id/f id/f?) 84 | (struct id-field (~? (fld ...) ()) 85 | #:methods gen:type 86 | [(define (type-contract type) 87 | (~? contract-e (~? (contract-fn-e type) any/c))) 88 | (define (type-declaration type dialect) 89 | (get-type-declaration type dialect declaration-e)) 90 | (define (type-load type dialect v) 91 | (~? (load-e type dialect v) v)) 92 | (define (type-dump type dialect v) 93 | (~? (dump-e type dialect v) v))]) 94 | (define id/f? id-field?) 95 | (define id/f 96 | (~? constructor-e (id-field))))])) 97 | 98 | (define-type id 99 | #:contract exact-nonnegative-integer? 100 | #:declaration "INTEGER") 101 | 102 | (define-type integer 103 | #:contract exact-integer? 104 | #:declaration "INTEGER") 105 | 106 | (define-type real 107 | #:contract real? 108 | #:declaration "REAL") 109 | 110 | (define-type numeric (precision scale) 111 | #:contract (or/c rational? +nan.0) 112 | #:declaration 113 | (lambda (t _dialect) 114 | @~a{NUMERIC(@(numeric-field-precision t), @(numeric-field-scale t))}) 115 | #:constructor 116 | (lambda (precision scale) 117 | (unless (exact-positive-integer? precision) 118 | (raise-argument-error 'numeric/f "exact-positive-integer?" precision)) 119 | (unless (exact-nonnegative-integer? scale) 120 | (raise-argument-error 'numeric/f "exact-nonnegative-integer?" scale)) 121 | (numeric-field precision scale))) 122 | 123 | (define-type string 124 | #:contract string? 125 | #:declaration "TEXT") 126 | 127 | (define-type binary 128 | #:contract bytes? 129 | #:declaration 130 | (lambda (_ dialect) 131 | (case dialect 132 | [(mysql sqlite3) "BLOB"] 133 | [(postgresql) "BYTEA"] 134 | [else (raise-dialect-error 'binary/f dialect)]))) 135 | 136 | (define-type symbol 137 | #:contract symbol? 138 | #:declaration "TEXT" 139 | #:load 140 | (lambda (_ _dialect v) 141 | (string->symbol v)) 142 | #:dump 143 | (lambda (_ _dialect v) 144 | (symbol->string v))) 145 | 146 | (define-type boolean 147 | #:contract boolean? 148 | #:declaration 149 | (lambda (_ dialect) 150 | (case dialect 151 | [(sqlite3) "INTEGER"] 152 | [else "BOOLEAN"])) 153 | #:load 154 | (lambda (_ dialect v) 155 | (case dialect 156 | [(sqlite3) (= v 1)] 157 | [else v])) 158 | #:dump 159 | (lambda (_ dialect v) 160 | (case dialect 161 | [(sqlite3) (if v 1 0)] 162 | [else v ]))) 163 | 164 | (define-type date 165 | #:contract date-provider? 166 | #:declaration 167 | (lambda (_ dialect) 168 | (case dialect 169 | [(sqlite3) "TEXT"] 170 | [else "DATE"])) 171 | #:load 172 | (lambda (_ dialect v) 173 | (case dialect 174 | [(sqlite3) 175 | (iso8601->date v)] 176 | 177 | [else 178 | (date (sql-date-year v) 179 | (sql-date-month v) 180 | (sql-date-day v))])) 181 | #:dump 182 | (lambda (_ dialect v) 183 | (case dialect 184 | [(sqlite3) 185 | (date->iso8601 (->date v))] 186 | 187 | [else 188 | (sql-date (->year v) 189 | (->month v) 190 | (->day v))]))) 191 | 192 | (define-type time 193 | #:contract time-provider? 194 | #:declaration 195 | (lambda (_ dialect) 196 | (case dialect 197 | [(sqlite3) "TEXT"] 198 | [else "TIME"])) 199 | #:load 200 | (lambda (_ dialect v) 201 | (case dialect 202 | [(sqlite3) 203 | (iso8601->time v)] 204 | 205 | [else 206 | (time (sql-time-hour v) 207 | (sql-time-minute v) 208 | (sql-time-second v) 209 | (sql-time-nanosecond v))])) 210 | #:dump 211 | (lambda (_ dialect v) 212 | (case dialect 213 | [(sqlite3) 214 | (time->iso8601 (->time v))] 215 | 216 | [else 217 | (sql-time (->hours v) 218 | (->minutes v) 219 | (->seconds v) 220 | (->nanoseconds v))]))) 221 | 222 | (define-type datetime 223 | #:contract datetime-provider? 224 | #:declaration 225 | (lambda (_ dialect) 226 | (case dialect 227 | [(mysql) "DATETIME"] 228 | [(postgresql) "TIMESTAMP"] 229 | [(sqlite3) "TEXT"] 230 | [else (raise-dialect-error 'datetime/f dialect)])) 231 | #:load 232 | (lambda (_ dialect v) 233 | (case dialect 234 | [(sqlite3) 235 | (iso8601->datetime v)] 236 | 237 | [else 238 | (datetime (sql-timestamp-year v) 239 | (sql-timestamp-month v) 240 | (sql-timestamp-day v) 241 | (sql-timestamp-hour v) 242 | (sql-timestamp-minute v) 243 | (sql-timestamp-second v) 244 | (sql-timestamp-nanosecond v))])) 245 | #:dump 246 | (lambda (_ dialect v) 247 | (case dialect 248 | [(sqlite3) 249 | (datetime->iso8601 (->datetime/local v))] 250 | 251 | [else 252 | (sql-timestamp (->year v) 253 | (->month v) 254 | (->day v) 255 | (->hours v) 256 | (->minutes v) 257 | (->seconds v) 258 | (->nanoseconds v) 259 | #f)]))) 260 | 261 | (define-type datetime-tz 262 | #:contract moment-provider? 263 | #:declaration 264 | (lambda (_ dialect) 265 | (case dialect 266 | [(mysql) "TIMESTAMP"] 267 | [(sqlite3) "TEXT"] 268 | [(postgresql) "TIMESTAMPTZ"])) 269 | #:load 270 | (lambda (_ dialect v) 271 | (case dialect 272 | [(sqlite3) 273 | (iso8601/tzid->moment v)] 274 | 275 | [else 276 | (moment (sql-timestamp-year v) 277 | (sql-timestamp-month v) 278 | (sql-timestamp-day v) 279 | (sql-timestamp-hour v) 280 | (sql-timestamp-minute v) 281 | (sql-timestamp-second v) 282 | (sql-timestamp-nanosecond v) 283 | #:tz (sql-timestamp-tz v))])) 284 | #:dump 285 | (lambda (_ dialect v) 286 | (case dialect 287 | [(sqlite3) 288 | (moment->iso8601/tzid (->moment v))] 289 | 290 | [else 291 | (sql-timestamp (->year v) 292 | (->month v) 293 | (->day v) 294 | (->hours v) 295 | (->minutes v) 296 | (->seconds v) 297 | (->nanoseconds v) 298 | (->utc-offset v))]))) 299 | 300 | (define-type array (subtype size) 301 | #:contract-fn 302 | (lambda (t) 303 | (vectorof (gen:type-contract (array-field-subtype t)))) 304 | #:constructor 305 | (lambda (subtype [size #f]) 306 | (array-field subtype size)) 307 | #:declaration 308 | (lambda (t dialect) 309 | (case dialect 310 | [(postgresql) 311 | (define subtype-declaration 312 | (gen:type-declaration (array-field-subtype t) dialect)) 313 | 314 | (define size:str 315 | (cond 316 | [(array-field-size t) => number->string] 317 | [else ""])) 318 | 319 | (~a subtype-declaration "[" size:str "]")] 320 | 321 | [else 322 | (raise-dialect-error 'array/f dialect)])) 323 | #:load 324 | (lambda (t dialect v) 325 | (define subtype (array-field-subtype t)) 326 | (for/vector ([x (in-vector (pg-array-contents v))]) 327 | (gen:type-load subtype dialect x))) 328 | #:dump 329 | (lambda (t dialect v) 330 | (define subtype (array-field-subtype t)) 331 | (for/list ([x (in-vector v)]) 332 | (gen:type-dump subtype dialect x)))) 333 | 334 | (define-type json 335 | #:contract jsexpr? 336 | #:declaration 337 | (lambda (_ dialect) 338 | (case dialect 339 | [(mysql postgresql) "JSON"] 340 | [(sqlite3) "TEXT"] 341 | [else (raise-dialect-error 'json/f dialect)])) 342 | #:load 343 | (lambda (_ dialect v) 344 | (case dialect 345 | [(mysql postgresql) v] 346 | [(sqlite3) (string->jsexpr v)] 347 | [else (raise-dialect-error 'json/f dialect)])) 348 | #:dump 349 | (lambda (_ dialect v) 350 | (case dialect 351 | [(mysql postgresql) v] 352 | [(sqlite3) (jsexpr->string v)] 353 | [else (raise-dialect-error 'json/f dialect)]))) 354 | 355 | (define-type jsonb 356 | #:contract jsexpr? 357 | #:declaration 358 | (lambda (_ dialect) 359 | (case dialect 360 | [(postgresql) "JSONB"] 361 | [else (raise-dialect-error 'jsonb/f dialect)]))) 362 | 363 | (define-type uuid 364 | #:contract uuid? 365 | #:declaration 366 | (lambda (_ dialect) 367 | (case dialect 368 | [(postgresql) "UUID"] 369 | [else (raise-dialect-error 'uuid/f dialect)]))) 370 | 371 | (define-type point 372 | #:contract point? 373 | #:declaration 374 | (lambda (_ dialect) 375 | (case dialect 376 | [(postgresql) "POINT"] 377 | [else (raise-dialect-error 'point/f dialect)]))) 378 | 379 | (define-type any 380 | #:contract any/c 381 | #:declaration 382 | (lambda (_ _dialect) 383 | (raise-user-error 'any/f "may only be used with virtual fields")) 384 | #:dump 385 | (lambda (_ _dialect _v) 386 | (raise-user-error 'any/f "may not be stored in the database"))) 387 | -------------------------------------------------------------------------------- /deta-lint-lib/examples/example.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require deta) 4 | 5 | (define has-pet?-default #f) 6 | 7 | (define-schema person 8 | #:table "people" 9 | ([id id/f] 10 | [name string/f] 11 | [(has-pet? has-pet?-default) boolean/f])) 12 | -------------------------------------------------------------------------------- /deta-lint-lib/examples/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define compile-omit-paths 'all) 4 | (define test-omit-paths 'all) 5 | -------------------------------------------------------------------------------- /deta-lint-lib/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define license 'BSD-3-Clause) 4 | (define collection "deta") 5 | (define deps 6 | '("base" 7 | "review")) 8 | (define review-exts 9 | '((deta/review should-review-syntax? review-syntax))) 10 | -------------------------------------------------------------------------------- /deta-lint-lib/review.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require review/ext 4 | syntax/parse/pre) 5 | 6 | #|review: ignore|# 7 | 8 | (provide 9 | should-review-syntax? 10 | review-syntax) 11 | 12 | (define (should-review-syntax? stx) 13 | (syntax-case stx (define-schema define-type) 14 | [(define-schema . _rest) #t] 15 | [(define-type . _rest) #t] 16 | [_ #f])) 17 | 18 | (define-splicing-syntax-class schema-field-option 19 | (pattern {~seq {~alt 20 | {~optional #:primary-key} 21 | {~optional #:auto-increment} 22 | {~optional #:nullable} 23 | {~optional #:unique} 24 | {~optional #:virtual} 25 | {~optional {~seq #:name name-e:expression}} 26 | {~optional {~seq #:contract contract-e:expression}} 27 | {~optional {~seq #:wrapper wrapper-e:expression}}} ...})) 28 | 29 | (define-syntax-class schema-field 30 | (pattern [id:id type-expr:expression opt:schema-field-option]) 31 | (pattern [(id:id default-expr:expression) type-expr:expression opt:schema-field-option]) 32 | (pattern e 33 | #:with id #'invalid 34 | #:do [(track-error this-syntax "expected a valid deta field definition")])) 35 | 36 | (define-syntax-class schema-definition 37 | #:datum-literals (define-schema) 38 | (pattern (define-schema 39 | ~! 40 | schema-id:id 41 | {~do (push-scope)} 42 | {~alt {~optional {~seq #:table table-name:str}} 43 | {~optional #:virtual}} ... 44 | (schema-field:schema-field ...+) 45 | {~alt {~optional {~seq #:pre-persist-hook pre-persist-hook-expr:expression}} 46 | {~optional {~seq #:pre-delete-hook pre-delete-hook-expr:expression}}} ... 47 | struct-option ... 48 | {~do (pop-scope)}) 49 | #:do [(track-binding #'schema-id #:check-usages? #f) 50 | (track-binding #'schema-id "~a?" #:check-usages? #f) 51 | (track-binding #'schema-id "make-~a" #:check-usages? #f) 52 | (define schema-id-sym (syntax->datum #'schema-id)) 53 | (for ([field-id-stx (in-list (syntax-e #'(schema-field.id ...)))]) 54 | (for ([p (in-list '("" "set-" "update-"))]) 55 | (track-binding 56 | field-id-stx 57 | #:related-to #'schema-id 58 | #:check-usages? #f 59 | (format "~a~a-~~a" p schema-id-sym))))])) 60 | 61 | (define-syntax-class type-definition 62 | #:datum-literals (define-type) 63 | (pattern (define-type 64 | ~! 65 | type-id:id 66 | {~do (push-scope)} 67 | {~optional (field-id:id ...)} 68 | {~alt {~optional {~seq {~or #:contract 69 | #:contract-fn} 70 | contract-expr:expression}} 71 | {~optional {~seq #:declaration declaration-expr:expression}} 72 | {~optional {~seq #:constructor constructor-expr:expression}} 73 | {~optional {~seq #:dump dump-expr:expression}} 74 | {~optional {~seq #:load load-expr:expression}}} ...) 75 | #:do [(pop-scope) 76 | (track-binding #'type-id "~a/f" #:check-usages? #f) 77 | (track-binding #'type-id "~a/f?" #:check-usages? #f)])) 78 | 79 | (define (review-syntax stx) 80 | (syntax-parse stx 81 | [d:schema-definition #'d] 82 | [t:type-definition #'t] 83 | [_ (track-error stx "expected a deta schema or type definition")])) 84 | -------------------------------------------------------------------------------- /deta-test/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2019 Bogdan Popa 2 | 3 | Redistribution and use in source and binary forms, with or without 4 | modification, are permitted provided that the following conditions are 5 | met: 6 | 7 | 1. Redistributions of source code must retain the above copyright 8 | notice, this list of conditions and the following disclaimer. 9 | 10 | 2. Redistributions in binary form must reproduce the above copyright 11 | notice, this list of conditions and the following disclaimer in the 12 | documentation and/or other materials provided with the distribution. 13 | 14 | 3. Neither the name of the copyright holder nor the names of its 15 | contributors may be used to endorse or promote products derived from 16 | this software without specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 24 | TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 25 | PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26 | LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | -------------------------------------------------------------------------------- /deta-test/deta/common.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require deta 4 | gregor 5 | racket/string) 6 | 7 | (provide 8 | deleted-users 9 | (schema-out book-with-nulls) 10 | (schema-out user) 11 | (schema-out password-reset) 12 | (schema-out hybrid) 13 | (schema-out reserved)) 14 | 15 | (define (generate-random-string) 16 | "a random string -- I promise") 17 | 18 | (define-schema book-with-nulls 19 | #:table "book_with_nulls" 20 | ([id id/f #:primary-key #:auto-increment] 21 | [title string/f #:contract non-empty-string? #:wrapper string-titlecase] 22 | [published-on datetime/f #:nullable])) 23 | 24 | (define deleted-users 25 | (make-parameter null)) 26 | 27 | (define-schema user 28 | ([id id/f #:primary-key #:auto-increment] 29 | [username string/f #:unique] 30 | [(active? #f) boolean/f] 31 | [(password-hash "") string/f] 32 | [(verified? #f) boolean/f #:name "verified"] 33 | [(verification-code (generate-random-string)) string/f] 34 | [(created-at (now/moment)) datetime-tz/f] 35 | [(updated-at (now/moment)) datetime-tz/f]) 36 | 37 | #:pre-persist-hook 38 | (lambda (u) 39 | (set-user-updated-at u (now/moment))) 40 | 41 | #:pre-delete-hook 42 | (lambda (u) 43 | (begin0 u 44 | (deleted-users (cons (user-id u) (deleted-users)))))) 45 | 46 | (define-schema password-reset 47 | #:table "password_reset_tokens" 48 | ([user-id id/f #:unique] 49 | [(token (generate-random-string)) string/f] 50 | [(expires-at (+days (now/moment) 1)) datetime-tz/f])) 51 | 52 | (define-schema hybrid 53 | ([id id/f #:primary-key #:auto-increment] 54 | [slug string/f #:unique] 55 | [(comment "irrelevant") string/f #:virtual])) 56 | 57 | (define-schema reserved 58 | ([user string/f] 59 | [timestamp datetime-tz/f])) 60 | -------------------------------------------------------------------------------- /deta-test/deta/entity.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require deta 4 | gregor 5 | rackunit) 6 | 7 | (provide 8 | entity-tests) 9 | 10 | (define-schema book 11 | #:virtual 12 | ([title string/f] 13 | [author string/f] 14 | [published-at datetime-tz/f])) 15 | 16 | (define-schema article 17 | #:virtual 18 | ([title string/f] 19 | [author string/f] 20 | [published-at datetime-tz/f])) 21 | 22 | (define entity-tests 23 | (test-suite 24 | "entity" 25 | 26 | (test-suite 27 | "entity=?" 28 | 29 | (test-case "entites with different schemas are not equal" 30 | (define d (now/moment)) 31 | (check-not-equal? 32 | (make-book #:title "A Title" #:author "An Author" #:published-at d) 33 | (make-article #:title "A Title" #:author "An Author" #:published-at d))) 34 | 35 | (test-case "entites with different data are not equal" 36 | (define d (now/moment)) 37 | (check-not-equal? 38 | (make-book #:title "A Title" #:author "An Author" #:published-at d) 39 | (make-book #:title "A Title" #:author "A Different Author" #:published-at d))) 40 | 41 | (test-case "entites with the same schema and data are equal" 42 | (define d (now/moment)) 43 | (check-equal? 44 | (make-book #:title "A Title" #:author "An Author" #:published-at d) 45 | (make-book #:title "A Title" #:author "An Author" #:published-at d)))) 46 | 47 | (test-suite 48 | "entity->hash" 49 | 50 | (test-case "converts entities to hashes" 51 | (define published-at 52 | (iso8601->moment "1954-07-29T00:00:00Z")) 53 | (define b 54 | (make-book 55 | #:title "Lord of the Rings" 56 | #:author "J. R. R. Tolkien" 57 | #:published-at (iso8601->moment "1954-07-29T00:00:00Z"))) 58 | 59 | (check-equal? 60 | (entity->hash b) 61 | (hasheq 62 | 'title "Lord of the Rings" 63 | 'author "J. R. R. Tolkien" 64 | 'published-at published-at)) 65 | 66 | (check-equal? 67 | (entity->hash b (λ (_ v) 68 | (cond 69 | [(moment? v) 70 | (moment->iso8601 v)] 71 | [else 72 | v]))) 73 | (hasheq 74 | 'title "Lord of the Rings" 75 | 'author "J. R. R. Tolkien" 76 | 'published-at "1954-07-29T00:00:00Z")))))) 77 | 78 | (module+ test 79 | (require rackunit/text-ui) 80 | (run-tests entity-tests)) 81 | -------------------------------------------------------------------------------- /deta-test/deta/query.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require db 4 | deta 5 | (prefix-in ast: deta/private/ast) 6 | deta/private/meta 7 | gregor 8 | racket/match 9 | racket/port 10 | racket/set 11 | rackunit 12 | syntax/macro-testing 13 | threading 14 | "common.rkt") 15 | 16 | (provide 17 | query-tests) 18 | 19 | (define current-conn 20 | (make-parameter #f)) 21 | 22 | (define (current-conn-postgres?) 23 | (eq? (dbsystem-name (connection-dbsystem (current-conn))) 'postgresql)) 24 | 25 | (define query-tests 26 | (test-suite 27 | "query" 28 | 29 | #:before 30 | (lambda () 31 | (drop-all! (current-conn)) 32 | (create-all! (current-conn))) 33 | 34 | (test-suite 35 | "prop:statement" 36 | 37 | (test-case "queries can be executed by the standard query functions" 38 | (check-equal? (query-value (current-conn) (select _ 1)) 1)) 39 | 40 | (test-case "queries with placeholders can be executed by the standard query functions" 41 | (check-equal? (query-value (current-conn) (select _ (cast ,1 int))) 1))) 42 | 43 | (test-suite 44 | "prop:custom-write" 45 | 46 | (test-case "prints queries" 47 | (check-equal? 48 | (with-output-to-string 49 | (lambda () 50 | (display (select _ 1)))) 51 | "#") 52 | 53 | (check-equal? 54 | (with-output-to-string 55 | (lambda () 56 | (display (select _ ,1)))) 57 | "#"))) 58 | 59 | (test-suite 60 | "create-table!" 61 | 62 | (test-case "fails with a user error if given an unknown schema id" 63 | (check-exn 64 | (lambda (e) 65 | (and (exn:fail:user? e) 66 | (check-regexp-match "unregistered schema" (exn-message e)))) 67 | (lambda () 68 | (create-table! (current-conn) 'idontexist)))) 69 | 70 | (test-case "ignores virtual fields" 71 | (define the-hybrid (make-hybrid #:slug "hello-world" #:comment "some value")) 72 | (insert-one! (current-conn) the-hybrid) 73 | (define row (query-row (current-conn) "SELECT * FROM hybrids")) 74 | (check-match row (vector (? number?) "hello-world")))) 75 | 76 | (test-suite 77 | "insert!" 78 | 79 | (test-case "persists entities" 80 | (define u (make-user #:username "bogdan@example.com")) 81 | (check-eq? (meta-state (entity-meta u)) 'created) 82 | 83 | (define u* (car (insert! (current-conn) u))) 84 | (check-eq? (meta-state (entity-meta u*)) 'persisted) 85 | (check-not-eq? (user-id u*) sql-null) 86 | 87 | (test-case "changing a persistent entity updates its meta state" 88 | (define u** (set-user-username u* "jim@example.com")) 89 | (check-eq? (meta-state (entity-meta u**)) 'changed))) 90 | 91 | (test-case "does not persist entities with virtual schemas" 92 | (define-schema v 93 | #:virtual 94 | ([x integer/f])) 95 | 96 | (check-exn 97 | exn:fail:user? 98 | (lambda () 99 | (insert! (current-conn) (make-v #:x 42))))) 100 | 101 | (test-case "persists entities w/o a primary key" 102 | (check-not-false 103 | (insert-one! (current-conn) (make-password-reset #:user-id 1)))) 104 | 105 | (test-case "persists entities containing nulls" 106 | (check-not-false 107 | (insert-one! (current-conn) (make-book-with-nulls #:title "Euclid")))) 108 | 109 | (test-case "persists entities containing datetime fields" 110 | (check-not-false 111 | (insert-one! (current-conn) (make-book-with-nulls #:title "Euclid" 112 | #:published-on (now)))))) 113 | 114 | (test-suite 115 | "update!" 116 | 117 | (test-case "does nothing to entities that haven't been persisted" 118 | (define u (make-user #:username "bogdan@example.com")) 119 | (check-equal? (update! (current-conn) u) null)) 120 | 121 | (test-case "does nothing to entities with only virtual fields changed" 122 | (define the-hybrid (make-hybrid #:slug "eureka" #:comment "some value")) 123 | (define changed-hybrid 124 | (~> (insert-one! (current-conn) the-hybrid) 125 | (set-hybrid-comment "some other value"))) 126 | (check-false (update-one! (current-conn) changed-hybrid))) 127 | 128 | (test-case "does nothing to entities that haven't been changed" 129 | (match-define (list u) 130 | (insert! (current-conn) 131 | (make-user #:username "bogdan-for-noop-update@example.com"))) 132 | 133 | (check-equal? (meta-changes (entity-meta u)) (seteq)) 134 | 135 | (define u* (update-one! (current-conn) u)) 136 | (check-false u*)) 137 | 138 | (test-case "updates entities that have been changed" 139 | (match-define (list u) 140 | (insert! (current-conn) 141 | (make-user #:username "bogdan-for-update@example.com"))) 142 | 143 | (define u* (set-user-username u "bogdan-for-update-changed@example.com")) 144 | (check-eq? (meta-state (entity-meta u*)) 'changed) 145 | (check-equal? (meta-changes (entity-meta u*)) (seteq 'username)) 146 | 147 | (match-define (list u**) (update! (current-conn) u*)) 148 | (check-eq? (meta-state (entity-meta u**)) 'persisted) 149 | (check-equal? (meta-changes (entity-meta u**)) (seteq))) 150 | 151 | (test-case "updates entities containing null values" 152 | (define book 153 | (insert-one! (current-conn) (make-book-with-nulls #:title "Euclid"))) 154 | 155 | (check-not-false 156 | (update-one! (current-conn) (set-book-with-nulls-title book "Euclid's Excellent Adventure")))) 157 | 158 | (test-case "runs pre-persist hooks" 159 | (define u 160 | (insert-one! (current-conn) 161 | (make-user #:username "bogdan-for-hooks@example.com"))) 162 | 163 | (sync (system-idle-evt)) 164 | (match-define (list u*) 165 | (update! (current-conn) 166 | (update-user-username u values))) 167 | 168 | (check-not-equal? (user-updated-at u) 169 | (user-updated-at u*)))) 170 | 171 | (test-suite 172 | "delete!" 173 | 174 | (test-case "does nothing to entities that haven't been persisted" 175 | (define u (make-user #:username "bogdan@example.com")) 176 | (check-equal? (delete! (current-conn) u) null)) 177 | 178 | (test-case "deletes persisted entities" 179 | (define u (make-user #:username "will-delete@example.com")) 180 | (match-define (list u*) (insert! (current-conn) u)) 181 | (match-define (list u**) (delete! (current-conn) u*)) 182 | (check-eq? (meta-state (entity-meta u**)) 'deleted)) 183 | 184 | (test-case "runs pre-delete hooks" 185 | (define u 186 | (insert-one! (current-conn) 187 | (make-user #:username "will-delete-for-hooks@example.com"))) 188 | 189 | (delete! (current-conn) u) 190 | (check-not-false (member (user-id u) (deleted-users))))) 191 | 192 | (test-suite 193 | "query" 194 | 195 | (test-suite 196 | "select" 197 | 198 | (test-case "can retrieve reserved columns" 199 | (insert-one! 200 | (current-conn) 201 | (make-reserved 202 | #:user "example" 203 | #:timestamp (now/moment))) 204 | (check-not-false 205 | (lookup 206 | (current-conn) 207 | (~> (from reserved #:as r) 208 | (where (= r.user "example")))))) 209 | 210 | (test-case "can retrieve arbitrary data" 211 | (define x 212 | (for/first ([(x) (in-entities (current-conn) (select _ 1))]) 213 | x)) 214 | 215 | (check-equal? x 1)) 216 | 217 | (test-case "can retrieve data containing nulls" 218 | (define book 219 | (insert-one! (current-conn) (make-book-with-nulls #:title "Euclid"))) 220 | 221 | (check-equal? (book-with-nulls-published-on book) 222 | (book-with-nulls-published-on 223 | (lookup (current-conn) (~> (from book-with-nulls #:as b) 224 | (where (= b.id ,(book-with-nulls-id book)))))))) 225 | 226 | (test-case "can retrieve data containing datetime fields without tz" 227 | (define book 228 | (insert-one! (current-conn) (make-book-with-nulls #:title "Euclid" 229 | #:published-on (now)))) 230 | 231 | (check-true (= (seconds-between 232 | (book-with-nulls-published-on book) 233 | (book-with-nulls-published-on 234 | (lookup (current-conn) (~> (from book-with-nulls #:as b) 235 | (where (= b.id ,(book-with-nulls-id book))))))) 236 | 0))) 237 | 238 | (test-case "can retrieve subsets of data from schemas" 239 | (define usernames 240 | (for/list ([(username) (in-entities (current-conn) 241 | (~> (from user #:as u) 242 | (select u.username)))]) 243 | username)) 244 | 245 | (check-true (not (null? usernames)))) 246 | 247 | (test-case "can project query results onto virtual schemas" 248 | (define-schema res 249 | #:virtual 250 | ([x integer/f] 251 | [y string/f])) 252 | 253 | (define r 254 | (for/first ([r (in-entities (current-conn) 255 | (~> (select _ 1 "hello") 256 | (project-onto res-schema)))]) 257 | r)) 258 | 259 | (check-true (res? r)) 260 | (check-equal? (res-x r) 1) 261 | (check-equal? (res-y r) "hello")) 262 | 263 | (test-case "can retrieve array data" 264 | (when (current-conn-postgres?) 265 | (define-schema res 266 | #:virtual 267 | ([roles (array/f string/f)])) 268 | 269 | (define r 270 | (for/first ([r (in-entities (current-conn) 271 | (~> (select _ (as (array "a" "b" "c") roles)) 272 | (project-onto res-schema)))]) 273 | r)) 274 | 275 | (check-true (res? r)) 276 | (check-equal? (res-roles r) #("a" "b" "c")))) 277 | 278 | (test-case "can retrieve JSON data" 279 | (when (current-conn-postgres?) 280 | (check-equal? 281 | (query-value 282 | (current-conn) 283 | (select _ (json-ref (json "{\"a\": {\"b\": 42}}") "a" "b"))) 284 | 42))) 285 | 286 | (test-suite 287 | "from" 288 | 289 | (test-case "retrieves whole entities from the database" 290 | (define all-users 291 | (for/list ([u (in-entities (current-conn) (from user #:as u))]) 292 | (check-equal? (meta-state (entity-meta u)) 'persisted) 293 | (check-true (user? u)))) 294 | 295 | (check-true (> (length all-users) 0)))) 296 | 297 | (test-case "retrieves whole entities containing virtual fields from the database" 298 | (drop-table! (current-conn) 'hybrid) 299 | (create-table! (current-conn) 'hybrid) 300 | (insert! (current-conn) 301 | (make-hybrid #:slug "hybrid-0" #:comment "some value") 302 | (make-hybrid #:slug "hybrid-1" #:comment "some other value")) 303 | (define default-comment (hybrid-comment (make-hybrid #:slug "n/a"))) 304 | (for ([h (in-entities (current-conn) (~> (from hybrid #:as h) (order-by ([slug]))))] 305 | [slug (in-list '("hybrid-0" "hybrid-1"))]) 306 | (check-equal? (hybrid-slug h) slug) 307 | (check-equal? (hybrid-comment h) default-comment))) 308 | 309 | (test-suite 310 | "where" 311 | 312 | (test-case "restricts which entities are retrieved from the database" 313 | (define query 314 | (~> (from user #:as u) 315 | (where u.active?))) 316 | 317 | (define all-active-users 318 | (for/list ([u (in-entities (current-conn) query)]) u)) 319 | 320 | (check-true (null? all-active-users)) 321 | 322 | (match-define (list _active-user-jim active-user-bob) 323 | (insert! (current-conn) 324 | (make-user #:username "active-user-jim@example.com" 325 | #:active? #t) 326 | (make-user #:username "active-user-bob@example.com" 327 | #:active? #t))) 328 | 329 | (define all-active-users* 330 | (for/list ([u (in-entities (current-conn) query)]) u)) 331 | 332 | (check-equal? (length all-active-users*) 2) 333 | 334 | (define all-active-users-named-bob 335 | (for/list ([u (in-entities (current-conn) 336 | (~> query 337 | (where (like u.username "%bob%"))))]) 338 | u)) 339 | 340 | (check-equal? (length all-active-users-named-bob) 1) 341 | (check-equal? (user-id active-user-bob) 342 | (user-id (car all-active-users-named-bob)))) 343 | 344 | (test-case "can handle boolean values within arbitrary queries" 345 | (check-not-exn 346 | (lambda () 347 | (for ([v '(#t #f)]) 348 | (query-exec (current-conn) 349 | (~> (from user #:as u) 350 | (select u.id) 351 | (where (= u.active? ,v)))))))))) 352 | 353 | (test-suite 354 | "update" 355 | 356 | (test-case "attempting to update a qualified field is a syntax error" 357 | (check-exn 358 | #rx"assignments may not be qualified" 359 | (lambda () 360 | (convert-compile-time-error 361 | (let () 362 | (~> (from user #:as e) 363 | (update [u.username "foo"]))))))) 364 | 365 | (test-case "supports returning clause" 366 | (define expected-id 367 | (query-value (current-conn) 368 | (~> (from user #:as u) 369 | (select id) 370 | (limit 1)))) 371 | (define returned-id 372 | (query-value (current-conn) 373 | (~> (from user #:as u) 374 | (update [active? #t]) 375 | (where (= id ,expected-id)) 376 | (returning id)))) 377 | (check-equal? expected-id returned-id)) 378 | 379 | (test-case "can update arbitrary tables" 380 | (query-exec (current-conn) 381 | (~> (from user #:as u) 382 | (update [active? #t]))) 383 | 384 | (for ([u (in-entities (current-conn) (from user #:as u))]) 385 | (check-true (user-active? u))))) 386 | 387 | (test-suite 388 | "delete" 389 | 390 | (test-case "can delete arbitrary data" 391 | (define q 392 | (~> (from user #:as u) 393 | (where u.active?))) 394 | 395 | (query-exec (current-conn) (delete q)) 396 | (check-equal? (query-value (current-conn) 397 | (select q (count *))) 0))) 398 | 399 | (test-suite 400 | "lookup" 401 | 402 | (test-case "can look up individual values" 403 | (check-equal? (lookup (current-conn) (select _ 1)) 1)) 404 | 405 | (test-case "can look up tuples of values" 406 | (define-values (a b) 407 | (lookup (current-conn) (select _ 1 2))) 408 | 409 | (check-equal? a 1) 410 | (check-equal? b 2)) 411 | 412 | (test-case "can look up entities" 413 | (define a-user 414 | (insert-one! (current-conn) 415 | (make-user #:username "user-for-lookup@example.com"))) 416 | 417 | (define user 418 | (lookup (current-conn) (~> (from user #:as u) 419 | (where (= u.id ,(user-id a-user)))))) 420 | 421 | (check-true (user? user))) 422 | 423 | (test-case "can fail to look up entities" 424 | (check-false (lookup (current-conn) 425 | (~> (from user #:as u) 426 | (where #f)))))) 427 | 428 | (test-suite 429 | "fragment" 430 | 431 | (test-case "fragment with ast nodes" 432 | (check-equal? 433 | (with-output-to-string 434 | (lambda () 435 | (display 436 | (~> (from user #:as u) 437 | (select u.name) 438 | (where (fragment (ast:app 439 | (ast:ident '=) 440 | (list (ast:qualified "u" "name") 441 | (ast:scalar "Bogdan"))))))))) 442 | "#")) 443 | 444 | (test-case "fragment with string" 445 | (check-equal? 446 | (with-output-to-string 447 | (lambda () 448 | (display 449 | (~> (from user #:as u) 450 | (select u.name) 451 | (where (fragment "u.name = 'Bogdan'")))))) 452 | "#")))))) 453 | 454 | (module+ test 455 | (require rackunit/text-ui) 456 | 457 | (let () 458 | (define (connect) 459 | (sqlite3-connect #:database 'memory)) 460 | 461 | (parameterize ([current-conn (connect)]) 462 | (run-tests 463 | (test-suite 464 | "sqlite (simple conn)" 465 | 466 | query-tests))) 467 | 468 | (parameterize ([current-conn (virtual-connection connect)]) 469 | (run-tests 470 | (test-suite 471 | "sqlite (virtual conn)" 472 | 473 | query-tests))) 474 | 475 | (let ([pool (connection-pool connect)]) 476 | (parameterize ([current-conn (connection-pool-lease pool)]) 477 | (run-tests 478 | (test-suite 479 | "sqlite (connection pool)" 480 | 481 | query-tests))))) 482 | 483 | (let () 484 | (define pg-database (getenv "DETA_POSTGRES_DB")) 485 | (define pg-username (getenv "DETA_POSTGRES_USER")) 486 | (define pg-password (getenv "DETA_POSTGRES_PASS")) 487 | (when pg-database 488 | (define (connect) 489 | (postgresql-connect #:server "127.0.0.1" 490 | #:port 5432 491 | #:database pg-database 492 | #:user pg-username 493 | #:password pg-password)) 494 | 495 | (parameterize ([current-conn (connect)]) 496 | (run-tests 497 | (test-suite 498 | "postgresql (simple conn)" 499 | 500 | query-tests))) 501 | 502 | (parameterize ([current-conn (virtual-connection connect)]) 503 | (run-tests 504 | (test-suite 505 | "postgresql (virtual conn)" 506 | 507 | query-tests))) 508 | 509 | (parameterize ([current-conn 510 | (connection-pool-lease 511 | (connection-pool connect))]) 512 | (run-tests 513 | (test-suite 514 | "postgresql (connection pool)" 515 | 516 | query-tests)))))) 517 | -------------------------------------------------------------------------------- /deta-test/deta/schema.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require deta 4 | deta/private/meta 5 | deta/private/schema 6 | racket/generic 7 | racket/match 8 | racket/port 9 | racket/set 10 | rackunit 11 | syntax/macro-testing 12 | threading 13 | "common.rkt") 14 | 15 | (provide 16 | schema-tests) 17 | 18 | (define-generics to-jsexpr 19 | (->jsexpr to-jsexpr)) 20 | 21 | (define-schema entry 22 | #:virtual 23 | ([id id/f #:primary-key #:auto-increment] 24 | [title string/f]) 25 | 26 | #:methods gen:to-jsexpr 27 | [(define (->jsexpr e) 28 | (hasheq 'title (entry-title e)))]) 29 | 30 | (module schema-out-test-sub racket/base 31 | (require deta) 32 | (provide (schema-out book)) 33 | 34 | (define-schema book 35 | #:virtual 36 | ([id id/f #:primary-key #:auto-increment] 37 | [title string/f] 38 | [author string/f] 39 | [(metadata #f) jsonb/f #:virtual]))) 40 | 41 | (require 'schema-out-test-sub) 42 | 43 | (define schema-tests 44 | (test-suite 45 | "schema" 46 | 47 | (test-suite 48 | "define-schema" 49 | 50 | (test-suite 51 | "fields" 52 | 53 | (test-case "at most one field can be a #:primary-key" 54 | (check-exn 55 | (lambda (e) 56 | (and (exn:fail:syntax? e) 57 | (regexp-match? "at most one field can be marked as a #:primary-key" (exn-message e)))) 58 | (lambda () 59 | (convert-compile-time-error 60 | (let () 61 | (define-schema invalid 62 | ([a integer/f #:primary-key] 63 | [b integer/f #:primary-key]))))))) 64 | 65 | (test-suite 66 | "virtual attribute" 67 | 68 | (test-case "raises an error on forbidden keywords on virtual fields" 69 | (define-syntax-rule (check-failure-cases [attr ...] ...) 70 | (begin 71 | (check-exn 72 | (lambda (e) 73 | (and (exn:fail:syntax? e) 74 | (regexp-match? "virtual fields may not have database-related attributes" (exn-message e)))) 75 | (lambda () 76 | (convert-compile-time-error 77 | (let () 78 | (define-schema illegal 79 | ([(metadata #f) jsonb/f attr ... #:virtual])) 80 | illegal-schema))) 81 | (format "keyword ~s must be forbidden on virtual field" 'kwd)) ...)) 82 | 83 | (check-failure-cases 84 | [#:primary-key] 85 | [#:auto-increment] 86 | [#:primary-key #:auto-increment] 87 | [#:nullable] 88 | [#:unique] 89 | [#:name "metadata"])))) 90 | 91 | (test-case "registers schema metadata in the registry" 92 | (check-eq? user-schema (schema-registry-lookup 'user))) 93 | 94 | (test-case "raises an error if two schemas are defined with the same name" 95 | (check-exn 96 | exn:fail:user? 97 | (lambda () 98 | (define-schema user 99 | ([id id/f #:primary-key #:auto-increment])) 100 | 101 | (fail "should never get here")))) 102 | 103 | (test-case "defined structs can be pattern matched" 104 | (match (make-user #:username "bogdan") 105 | [(struct* user ([username u])) 106 | (check-equal? u "bogdan")])) 107 | 108 | (test-case "defined structs have an associated smart constructor" 109 | (check-exn 110 | exn:fail:contract? 111 | (λ () (make-user #:username 1))) 112 | (check-true (user? (make-user #:username "bogdan@example.com")))) 113 | 114 | (test-case "defined structs have associated functional setters and updaters" 115 | (define a-user 116 | (make-user #:username "bogdan")) 117 | (check-equal? 118 | (~> a-user 119 | (set-user-username "bogdan-paul") 120 | (update-user-username string-upcase) 121 | (user-username)) 122 | "BOGDAN-PAUL")) 123 | 124 | (test-case "defined structs have associated metadata" 125 | (define m (entity-meta (make-user #:username "bogdan"))) 126 | (check-eq? (meta-state m) 'created) 127 | (check-equal? (meta-changes m) (seteq))) 128 | 129 | (test-case "schema fields can have custom names" 130 | (define q 131 | (with-output-to-string 132 | (λ () 133 | (display (select (from user #:as u) u.valid?))))) 134 | 135 | (check-equal? q "#")) 136 | 137 | (test-case "struct-options are passed to the struct definition" 138 | (define e (make-entry #:title "hello")) 139 | (check-equal? 140 | (->jsexpr e) 141 | (hasheq 'title "hello")))) 142 | 143 | (test-suite 144 | "schema-registry-lookup" 145 | 146 | (test-case "raises an error when given a nonexistent schema" 147 | (check-exn 148 | exn:fail? 149 | (λ () 150 | (schema-registry-lookup 'idontexist)))) 151 | 152 | (test-case "returns a schema given its name" 153 | (check-eq? (schema-registry-lookup 'user) user-schema)) 154 | 155 | (test-case "returns a schema given itself" 156 | (check-eq? (schema-registry-lookup user-schema) user-schema))) 157 | 158 | (test-suite 159 | "schema-out" 160 | 161 | (test-case "provides all schema-related identifiers" 162 | (check-true (schema? book-schema)) 163 | 164 | (define a-book 165 | (make-book #:title "The Lord of the Ring" 166 | #:author "J.R.R. Tolkien")) 167 | 168 | (check-true (book? a-book)) 169 | (check-equal? 170 | (~> (set-book-title a-book "The Lord of the Rings") 171 | (update-book-title string-upcase) 172 | (book-title)) 173 | "THE LORD OF THE RINGS"))))) 174 | 175 | (module+ test 176 | (require rackunit/text-ui) 177 | (run-tests schema-tests)) 178 | -------------------------------------------------------------------------------- /deta-test/deta/sql-postgresql.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp racket/base 2 | 3 | (require deta 4 | (prefix-in ast: deta/private/ast) 5 | deta/private/dialect/dialect 6 | deta/private/dialect/postgresql 7 | (only-in deta/private/query 8 | query-stmt) 9 | racket/format 10 | rackunit 11 | threading) 12 | 13 | (provide 14 | sql-tests) 15 | 16 | (define (query->stmt q) 17 | (if (query? q) 18 | (query-stmt q) 19 | q)) 20 | 21 | (define (emit q) 22 | (define-values (query _) 23 | (dialect-emit-query postgresql-dialect (query->stmt q))) 24 | query) 25 | 26 | (define-check (check-emitted q expected) 27 | (define query (emit q)) 28 | (with-check-info 29 | (['query query] 30 | ['expected expected]) 31 | (unless (equal? query expected) 32 | (fail-check)))) 33 | 34 | (define-check (check-emitted/placeholders q expected-query expected-placeholders) 35 | (define-values (query args) 36 | (dialect-emit-query postgresql-dialect (query->stmt q))) 37 | 38 | (with-check-info 39 | (['query query] 40 | ['expected expected-query]) 41 | (unless (equal? query expected-query) 42 | (fail-check))) 43 | 44 | (with-check-info 45 | (['placeholders args] 46 | ['expected expected-placeholders]) 47 | (unless (equal? args expected-placeholders) 48 | (fail-check)))) 49 | 50 | (define sql-tests 51 | (test-suite 52 | "postgresq-sql" 53 | 54 | (test-suite 55 | "select" 56 | 57 | (check-emitted (select _ 1) 58 | "SELECT 1") 59 | 60 | (check-emitted (select _ #:distinct 1) 61 | "SELECT DISTINCT 1") 62 | 63 | (check-emitted (select _ 1.5) 64 | "SELECT 1.5") 65 | 66 | (check-emitted (select _ (+ 1 2)) 67 | "SELECT 1 + 2") 68 | 69 | (check-emitted (select _ (* 3 (+ 1 2))) 70 | "SELECT 3 * (1 + 2)") 71 | 72 | (check-emitted (select _ (* 3 (+ 1 2) (* 2 3))) 73 | "SELECT 3 * (1 + 2) * (2 * 3)") 74 | 75 | (check-emitted (select _ (abs -1)) 76 | "SELECT ABS(-1)") 77 | 78 | (check-emitted (select _ (random)) 79 | "SELECT RANDOM()") 80 | 81 | (check-emitted (select _ #t) 82 | "SELECT TRUE") 83 | 84 | (check-emitted (select _ #f) 85 | "SELECT FALSE") 86 | 87 | (check-emitted (select _ u.UserName) 88 | @~a{SELECT u."UserName"}) 89 | 90 | (check-emitted (select _ u.user_name) 91 | "SELECT u.user_name") 92 | 93 | (check-emitted (select _ (and 1)) 94 | "SELECT 1") 95 | 96 | (check-emitted (select _ (and 1 2)) 97 | "SELECT 1 AND 2") 98 | 99 | (check-emitted (select _ (and 1 2 3)) 100 | "SELECT 1 AND 2 AND 3") 101 | 102 | (check-emitted (select _ (and 1 2 3 4)) 103 | "SELECT 1 AND 2 AND 3 AND 4") 104 | 105 | (check-emitted (select _ (or #t #f)) 106 | "SELECT TRUE OR FALSE") 107 | 108 | (check-emitted (select _ (or #t #f #f)) 109 | "SELECT TRUE OR FALSE OR FALSE") 110 | 111 | (check-emitted (select _ (or #t (+ 1 2 3) #f)) 112 | "SELECT TRUE OR (1 + 2 + 3) OR FALSE") 113 | 114 | (check-emitted (select _ (not #t)) 115 | "SELECT NOT TRUE") 116 | 117 | (check-emitted (select _ (not (or #t #f))) 118 | "SELECT NOT (TRUE OR FALSE)") 119 | 120 | (check-emitted (select _ (or (and (not #t) #f) 1)) 121 | "SELECT ((NOT TRUE) AND FALSE) OR 1") 122 | 123 | (check-emitted (select _ (sum 1)) 124 | "SELECT SUM(1)") 125 | 126 | (check-emitted (select _ (bitwise-not 1)) 127 | "SELECT ~ 1") 128 | 129 | (check-emitted (select _ (bitwise-and 1 2)) 130 | "SELECT 1 & 2") 131 | 132 | (check-emitted (select _ (bitwise-or 1 2)) 133 | "SELECT 1 | 2") 134 | 135 | (check-emitted (select _ (bitwise-xor 1 2)) 136 | "SELECT 1 # 2") 137 | 138 | (check-emitted (select _ (concat "hello " "world!")) 139 | "SELECT CONCAT('hello ', 'world!')") 140 | 141 | (check-emitted (select _ "quoting 'test'") 142 | "SELECT 'quoting ''test'''") 143 | 144 | (check-emitted (select _ (position "om" "Thomas")) 145 | "SELECT POSITION('om' IN 'Thomas')") 146 | 147 | (check-emitted (select _ (trim leading "x" "xxtestxx")) 148 | "SELECT TRIM(LEADING 'x' FROM 'xxtestxx')") 149 | 150 | (check-emitted (select _ (similar-to "x" "%x%")) 151 | "SELECT 'x' SIMILAR TO '%x%'") 152 | 153 | (check-emitted (select _ (is null null)) 154 | "SELECT NULL IS NULL") 155 | 156 | (check-emitted (select _ (like u.a "hello%")) 157 | "SELECT u.a LIKE 'hello%'") 158 | 159 | (check-emitted (select _ (ilike u.a "hello%")) 160 | "SELECT u.a ILIKE 'hello%'") 161 | 162 | (check-emitted (select _ (in 1 (list 1 2 3))) 163 | "SELECT 1 IN (1, 2, 3)") 164 | 165 | (check-emitted (select _ (in 1 '(1 2 3))) 166 | "SELECT 1 IN (1, 2, 3)") 167 | 168 | (check-emitted (select _ (array 1 2 3)) 169 | "SELECT ARRAY[1, 2, 3]") 170 | 171 | (check-emitted (select _ (array-concat (array "a") (array "b" "c"))) 172 | "SELECT ARRAY['a'] || ARRAY['b', 'c']") 173 | 174 | (check-emitted (select _ (array-contains? (array 1 2) (array 1))) 175 | "SELECT ARRAY[1, 2] @> ARRAY[1]") 176 | 177 | (check-emitted (select _ (array-overlap? (array "a") (array "b" "c"))) 178 | "SELECT ARRAY['a'] && ARRAY['b', 'c']") 179 | 180 | (check-emitted (select _ (array-ref (array 1 2 3) 2)) 181 | "SELECT (ARRAY[1, 2, 3])[2]") 182 | 183 | (check-emitted (select _ (array-slice (array 1 2 3) 2 5)) 184 | "SELECT (ARRAY[1, 2, 3])[2:5]") 185 | 186 | (check-emitted (select _ (array (array "a") 187 | (array "b") 188 | (array "c"))) 189 | "SELECT ARRAY[ARRAY['a'], ARRAY['b'], ARRAY['c']]") 190 | 191 | (check-emitted (select _ (= u.username (any (array "a" "b" "c")))) 192 | "SELECT u.username = ANY(ARRAY['a', 'b', 'c'])") 193 | 194 | (check-emitted (select _ (= u.username (any ,(list "a" "b" "c")))) 195 | "SELECT u.username = ANY($1)") 196 | 197 | (check-emitted (select _ (date "1950-01-01")) 198 | "SELECT DATE '1950-01-01'") 199 | 200 | (check-emitted (select _ (interval "7 days")) 201 | "SELECT INTERVAL '7 days'") 202 | 203 | (check-emitted (select _ (isfinite (interval "7 days"))) 204 | "SELECT ISFINITE(INTERVAL '7 days')") 205 | 206 | (check-emitted (select _ (time "12:30")) 207 | "SELECT TIME '12:30'") 208 | 209 | (check-emitted (select _ (timestamp "1950-01-01 00:00:00")) 210 | "SELECT TIMESTAMP '1950-01-01 00:00:00'") 211 | 212 | (check-emitted (select _ (date_part "year" (date "1950-01-01"))) 213 | "SELECT DATE_PART('year', DATE '1950-01-01')") 214 | 215 | (check-emitted (select _ (extract year (timestamp "1950-01-01 00:00:00"))) 216 | "SELECT EXTRACT(YEAR FROM (TIMESTAMP '1950-01-01 00:00:00'))") 217 | 218 | (check-emitted (select _ (cast "1950-01-01" date)) 219 | "SELECT CAST('1950-01-01' AS DATE)") 220 | 221 | (check-emitted 222 | (select _ (as (between (now) 223 | (- (now) (interval "7 days")) 224 | (+ (now) (interval "7 days"))) 225 | is_between)) 226 | 227 | "SELECT ((NOW()) BETWEEN ((NOW()) - (INTERVAL '7 days')) AND ((NOW()) + (INTERVAL '7 days'))) AS is_between") 228 | 229 | (test-case "fails when known operators are called with bad arities" 230 | (check-exn 231 | #rx"not: arity mismatch" 232 | (lambda () 233 | (emit (select _ (not))))) 234 | (check-exn 235 | #rx"json-subset.: arity mismatch" 236 | (lambda () 237 | (emit (select _ (json-subset? "{}" "{}" "{}")))))) 238 | 239 | (test-case "supports DISTINCT in from-queries" 240 | (check-emitted 241 | (~> (from "tags" #:as t) 242 | (select #:distinct t.name t.count)) 243 | "SELECT DISTINCT t.name, t.\"count\" FROM tags AS t")) 244 | 245 | (test-case "supports COND as an alias for CASE" 246 | (check-emitted 247 | (select 248 | (from "departments" #:as d) 249 | (cond 250 | [(> (min d.employees) 0) 251 | (avg (/ d.expenses d.employees))])) 252 | 253 | "SELECT CASE WHEN (MIN(d.employees)) > 0 THEN AVG(d.expenses / d.employees) END FROM departments AS d")) 254 | 255 | (test-case "COND expressions support ELSE clauses" 256 | (check-emitted 257 | (select 258 | (from "departments" #:as d) 259 | (cond 260 | [(> (min d.employees) 0) 261 | (avg (/ d.expenses d.employees))] 262 | [else 0])) 263 | 264 | "SELECT CASE WHEN (MIN(d.employees)) > 0 THEN AVG(d.expenses / d.employees) ELSE 0 END FROM departments AS d")) 265 | 266 | (test-suite 267 | "from" 268 | 269 | (test-case "supports runtime table names" 270 | (let ([tbl "example"]) 271 | (check-emitted 272 | (~> (from ,tbl #:as t) 273 | (select t.x)) 274 | 275 | "SELECT t.x FROM example AS t"))) 276 | 277 | (test-suite 278 | "subquery" 279 | 280 | (test-case "emits subqueries in select clauses" 281 | (check-emitted 282 | (select 283 | _ 284 | (as (subquery (select _ 1)) a) 285 | (as (subquery (select (from "b" #:as b) b.x)) x)) 286 | "SELECT (SELECT 1) AS a, (SELECT b.x FROM b AS b) AS x")) 287 | 288 | (test-case "emits subqueries in from clauses" 289 | (check-emitted 290 | (~> (from (subquery (select _ (as 1 x))) #:as a) 291 | (select a.x)) 292 | 293 | "SELECT a.x FROM (SELECT 1 AS x) AS a")) 294 | 295 | (test-case "allows queries to be composed" 296 | (define active-usernames 297 | (~> (from "users" #:as u) 298 | (select u.username) 299 | (group-by u.username))) 300 | 301 | (check-emitted 302 | (~> (from (subquery active-usernames) #:as a) 303 | (select (count a.*))) 304 | 305 | "SELECT COUNT(a.*) FROM (SELECT u.username FROM users AS u GROUP BY u.username) AS a")))) 306 | 307 | (test-suite 308 | "join" 309 | 310 | (test-case "emits inner join clauses" 311 | (check-emitted 312 | (~> (from "books" #:as b) 313 | (join "authors" #:as a #:on (= b.author-id a.id)) 314 | (select a.name (count b.title)) 315 | (group-by a.id)) 316 | 317 | "SELECT a.name, COUNT(b.title) FROM books AS b JOIN authors AS a ON b.author_id = a.id GROUP BY a.id")) 318 | 319 | (test-case "emits multiple join clauses" 320 | (check-emitted 321 | (~> (from "books" #:as b) 322 | (join "authors" #:as a #:on (= b.author-id a.id)) 323 | (join "author_pics" #:as ap #:on (= a.id ap.author-id)) 324 | (select a.name ap.picture (count b.title)) 325 | (group-by a.id ap.picture)) 326 | 327 | "SELECT a.name, ap.picture, COUNT(b.title) FROM books AS b JOIN authors AS a ON b.author_id = a.id JOIN author_pics AS ap ON a.id = ap.author_id GROUP BY a.id, ap.picture")) 328 | 329 | (test-case "emits different types of joins" 330 | (check-emitted 331 | (~> (from "posts" #:as p) 332 | (join #:left "comments" #:as c #:on (= p.id c.post-id)) 333 | (select a.* c.*)) 334 | 335 | "SELECT a.*, c.* FROM posts AS p LEFT JOIN comments AS c ON p.id = c.post_id")) 336 | 337 | (test-case "emits joins for subqueries" 338 | (check-emitted 339 | (~> (from "posts" #:as p) 340 | (join #:left (subquery (select _ 1)) #:as c #:on #t) 341 | (select p.* c.*)) 342 | 343 | "SELECT p.*, c.* FROM posts AS p LEFT JOIN (SELECT 1) AS c ON TRUE")) 344 | 345 | (test-case "emits lateral joins" 346 | (check-emitted 347 | (~> (from "posts" #:as p) 348 | (join #:left 349 | #:lateral 350 | (subquery (~> (from "post_images" #:as pi) 351 | (where (= pi.post-id p.id)) 352 | (order-by ([pi.id #:desc])) 353 | (limit 1))) 354 | #:as pi 355 | #:on #t) 356 | (select p.* pi.*)) 357 | "SELECT p.*, pi.* FROM posts AS p LEFT JOIN LATERAL (SELECT * FROM post_images AS pi WHERE pi.post_id = p.id ORDER BY pi.id DESC LIMIT 1) AS pi ON TRUE")) 358 | 359 | (test-case "emits cross joins" 360 | (check-emitted 361 | (~> (from "posts" #:as p) 362 | (join #:cross "post_images" #:as pi) 363 | (select p.* pi.*)) 364 | "SELECT p.*, pi.* FROM posts AS p CROSS JOIN post_images AS pi")) 365 | 366 | (test-case "emits cross lateral joins" 367 | (check-emitted 368 | (~> (from "posts" #:as p) 369 | (join #:cross 370 | #:lateral 371 | (subquery 372 | (~> (from "post_images" #:as pi) 373 | (where (= pi.post-id p.id)) 374 | (limit 1))) 375 | #:as pi) 376 | (select p.*)) 377 | "SELECT p.* FROM posts AS p CROSS JOIN LATERAL (SELECT * FROM post_images AS pi WHERE pi.post_id = p.id LIMIT 1) AS pi"))) 378 | 379 | (test-suite 380 | "group-by" 381 | 382 | (test-case "adds a group-by clause to the given query" 383 | (check-emitted 384 | (~> (from "books" #:as b) 385 | (select b.year (count b.title)) 386 | (group-by b.year)) 387 | "SELECT b.\"year\", COUNT(b.title) FROM books AS b GROUP BY b.\"year\"")) 388 | 389 | (test-case "augments existing group-by clauses" 390 | (check-emitted 391 | (~> (from "books" #:as b) 392 | (select b.year b.month (count *)) 393 | (group-by b.year) 394 | (group-by b.month)) 395 | "SELECT b.\"year\", b.\"month\", COUNT(*) FROM books AS b GROUP BY b.\"year\", b.\"month\""))) 396 | 397 | (test-suite 398 | "order-by" 399 | 400 | (test-case "adds an order-by clause to the given query" 401 | (check-emitted 402 | (~> (from "books" #:as b) 403 | (select b.title) 404 | (order-by ([b.year]))) 405 | "SELECT b.title FROM books AS b ORDER BY b.\"year\"")) 406 | 407 | (test-case "augments existing order-by clauses" 408 | (check-emitted 409 | (~> (from "books" #:as b) 410 | (select b.title) 411 | (order-by ([b.year #:desc])) 412 | (order-by ([b.title]))) 413 | "SELECT b.title FROM books AS b ORDER BY b.\"year\" DESC, b.title")) 414 | 415 | (test-case "supports descending directions" 416 | (check-emitted 417 | (~> (from "books" #:as b) 418 | (select b.title) 419 | (order-by ([b.year #:desc] 420 | [b.title]))) 421 | "SELECT b.title FROM books AS b ORDER BY b.\"year\" DESC, b.title")) 422 | 423 | (test-case "supports explicit #:asc directions" 424 | (check-emitted 425 | (~> (from "books" #:as b) 426 | (select b.title) 427 | (order-by ([b.year #:desc] 428 | [b.title #:asc]))) 429 | "SELECT b.title FROM books AS b ORDER BY b.\"year\" DESC, b.title")) 430 | 431 | (test-case "supports dynamic directions" 432 | (define order 'desc) 433 | 434 | (check-emitted 435 | (~> (from "books" #:as b) 436 | (order-by ([b.year ,order]))) 437 | "SELECT * FROM books AS b ORDER BY b.\"year\" DESC")) 438 | 439 | (test-case "errors out when given an invalid dynamic direction" 440 | (check-exn 441 | exn:fail:contract? 442 | (lambda () 443 | (~> (from "books" #:as b) 444 | (order-by ([b.year ,1])))))) 445 | 446 | (test-case "supports dynamic columns" 447 | (define column (ast:qualified "b" "title")) 448 | 449 | (check-emitted 450 | (~> (from "books" #:as b) 451 | (order-by ([(fragment column) #:desc]))) 452 | "SELECT * FROM books AS b ORDER BY b.title DESC")) 453 | 454 | (test-case "errors out when given an invalid dynamic column" 455 | (check-exn 456 | exn:fail:contract? 457 | (lambda () 458 | (~> (from "books" #:as b) 459 | (order-by ([(fragment 1)])))))) 460 | 461 | (test-case "supports NULLS FIRST" 462 | (define q (from "books" #:as b)) 463 | (define result 464 | "SELECT * FROM books AS b ORDER BY b.title NULLS FIRST, b.\"year\"") 465 | (check-emitted (order-by q ([b.title #:asc #:nulls-first] [b.year])) result) 466 | (check-emitted (order-by q ([b.title #:asc ,'nulls-first] [b.year])) result) 467 | (check-emitted (order-by q ([b.title ,'asc ,'nulls-first] [b.year])) result) 468 | (check-emitted (order-by q ([b.title ,'asc #:nulls-first] [b.year])) result)) 469 | 470 | (test-case "supports NULLS LAST" ; ASC NULLS LAST is actually Postgres' default 471 | (define q (from "books" #:as b)) 472 | (define result 473 | "SELECT * FROM books AS b ORDER BY b.title NULLS LAST, b.\"year\"") 474 | (check-emitted (order-by q ([b.title #:asc #:nulls-last] [b.year])) result)) 475 | 476 | (test-case "supports DESC NULLS LAST" 477 | (define q (from "books" #:as b)) 478 | (define result 479 | "SELECT * FROM books AS b ORDER BY b.title DESC NULLS LAST, b.\"year\"") 480 | (check-emitted (order-by q ([b.title #:desc #:nulls-last] [b.year])) result) 481 | (check-emitted (order-by q ([b.title ,'desc ,'nulls-last] [b.year])) result) 482 | (check-emitted (order-by q ([b.title #:desc ,'nulls-last] [b.year])) result) 483 | (check-emitted (order-by q ([b.title ,'desc #:nulls-last] [b.year])) result)) 484 | 485 | (test-case "errors out when given an invalid dynamic nulls direction" 486 | (check-exn 487 | exn:fail:contract? 488 | (lambda () 489 | (~> (from "books" #:as b) 490 | (order-by ([b.title #:asc ,'foo])))))) 491 | 492 | (test-case "supports dynamic lists" 493 | (check-emitted 494 | (~> (from "books" #:as b) 495 | (where (in b.id ,@(list 1 2 3)))) 496 | "SELECT * FROM books AS b WHERE b.id IN (1, 2, 3)") 497 | 498 | (check-emitted 499 | (~> (from "books" #:as b) 500 | (where (in b.title ,@(list "a" "b" "c")))) 501 | "SELECT * FROM books AS b WHERE b.title IN ('a', 'b', 'c')"))) 502 | 503 | (test-suite 504 | "offset" 505 | 506 | (check-emitted 507 | (~> (from "books" #:as b) 508 | (select b.title) 509 | (offset 20) 510 | (order-by ([b.title]))) 511 | 512 | "SELECT b.title FROM books AS b ORDER BY b.title OFFSET 20")) 513 | 514 | (test-suite 515 | "limit" 516 | 517 | (check-emitted 518 | (~> (from "books" #:as b) 519 | (limit 20)) 520 | 521 | "SELECT * FROM books AS b LIMIT 20") 522 | 523 | (check-emitted 524 | (~> (from "books" #:as b) 525 | (offset 10) 526 | (limit 20)) 527 | 528 | "SELECT * FROM books AS b LIMIT 20 OFFSET 10") 529 | 530 | (check-emitted/placeholders 531 | (~> (from "books" #:as b) 532 | (limit ,(add1 10))) 533 | 534 | "SELECT * FROM books AS b LIMIT $1" '(11)) 535 | 536 | (check-emitted/placeholders 537 | (~> (from "books" #:as b) 538 | (offset ,1) 539 | (limit ,(add1 10))) 540 | 541 | "SELECT * FROM books AS b LIMIT $1 OFFSET $2" '(11 1))) 542 | 543 | (test-suite 544 | "placeholders" 545 | 546 | (check-emitted/placeholders 547 | (select _ ,42) 548 | "SELECT $1" 549 | '(42)) 550 | 551 | (let ([x 1] 552 | [y "hello"]) 553 | (check-emitted/placeholders 554 | (select _ (<> ,x ,y)) 555 | "SELECT $1 <> $2" 556 | '(1 "hello")))) 557 | 558 | (test-suite 559 | "union" 560 | 561 | (check-emitted 562 | (union (select _ 1) 563 | (select _ 2)) 564 | "SELECT 1 UNION (SELECT 2)") 565 | 566 | (check-emitted 567 | (union 568 | (union (select _ 1) 569 | (select _ 2)) 570 | (select _ 3)) 571 | "SELECT 1 UNION (SELECT 2 UNION (SELECT 3))") 572 | 573 | (check-emitted 574 | (union 575 | (union 576 | (union (select _ 1) 577 | (select _ 2)) 578 | (select _ 3)) 579 | (select _ 4)) 580 | "SELECT 1 UNION (SELECT 2 UNION (SELECT 3 UNION (SELECT 4)))") 581 | 582 | (check-emitted 583 | (~> (select _ 1) 584 | (union (select _ 2)) 585 | (union (select _ 3)) 586 | (union (select _ 4))) 587 | "SELECT 1 UNION (SELECT 2 UNION (SELECT 3 UNION (SELECT 4)))")) 588 | 589 | (test-case "quotes reserved keywords" 590 | (check-emitted 591 | (~> (from "reserved" #:as r) 592 | (select r.user r.timestamp)) 593 | "SELECT r.\"user\", r.\"timestamp\" FROM reserved AS r")) 594 | 595 | (test-case "does not quote reserved keywords unless qualified" 596 | (check-emitted 597 | (select _ current_timestamp) 598 | "SELECT CURRENT_TIMESTAMP") 599 | (check-emitted 600 | (select _ (= user "postgresql")) 601 | "SELECT USER = 'postgresql'"))) 602 | 603 | (test-suite 604 | "select-for-schema" 605 | 606 | (let () 607 | (define-schema example 608 | #:virtual 609 | ([a integer/f] 610 | [b string/f])) 611 | 612 | (check-emitted 613 | (~> (from "examples" #:as e) 614 | (select-for-schema ,example-schema #:from e)) 615 | "SELECT e.a, e.b FROM examples AS e") 616 | 617 | (check-emitted 618 | (~> (from "examples" #:as e) 619 | (select-for-schema ,example-schema 620 | #:from e 621 | #:customizing 622 | ([b 42]))) 623 | "SELECT e.a, 42 FROM examples AS e"))) 624 | 625 | (test-suite 626 | "update" 627 | 628 | (check-emitted 629 | (~> (from "users" #:as u) 630 | (update [username ,1] 631 | [password-hash ,2])) 632 | 633 | "UPDATE users AS u SET username = $1, password_hash = $2") 634 | 635 | (check-emitted 636 | (~> (from "users" #:as u) 637 | (update [username ,1] 638 | [password-hash ,2]) 639 | (where (= u.id ,3))) 640 | 641 | "UPDATE users AS u SET username = $1, password_hash = $2 WHERE u.id = $3") 642 | 643 | (check-emitted 644 | (~> (from "users" #:as u) 645 | (update [username ,1] 646 | [password-hash ,2]) 647 | (where (= u.id ,3)) 648 | (or-where (= u.id ,4))) 649 | 650 | "UPDATE users AS u SET username = $1, password_hash = $2 WHERE (u.id = $3) OR (u.id = $4)") 651 | 652 | (check-emitted 653 | (~> (from "users" #:as u) 654 | (update [username "bill"]) 655 | (where (= u.id 1)) 656 | (returning u.username)) 657 | 658 | "UPDATE users AS u SET username = 'bill' WHERE u.id = 1 RETURNING u.username") 659 | 660 | (test-case "raises an error if trying to update a subquery" 661 | (check-exn 662 | exn:fail:contract? 663 | (lambda () 664 | (~> (from (subquery (select _ 1)) #:as t) 665 | (update [x 2])))))) 666 | 667 | (test-suite 668 | "delete" 669 | 670 | (test-case "generates DELETE queries" 671 | (check-emitted 672 | (delete (from "users" #:as u)) 673 | 674 | "DELETE FROM users AS u")) 675 | 676 | (test-case "supports WHERE clauses" 677 | (check-emitted 678 | (~> (delete (from "users" #:as u)) 679 | (where (not u.active?))) 680 | 681 | "DELETE FROM users AS u WHERE NOT u.is_active")) 682 | 683 | (test-case "supports RETURNING clauses" 684 | (check-emitted 685 | (~> (delete (from "users" #:as u)) 686 | (where u.active?) 687 | (returning u.id)) 688 | 689 | "DELETE FROM users AS u WHERE u.is_active RETURNING u.id")) 690 | 691 | (test-case "supports the augmentation of RETURNING clauses" 692 | (check-emitted 693 | (~> (delete (from "users" #:as u)) 694 | (where u.active?) 695 | (returning u.id) 696 | (returning u.username u.last-logged-in)) 697 | 698 | "DELETE FROM users AS u WHERE u.is_active RETURNING u.id, u.username, u.last_logged_in")) 699 | 700 | (test-case "raises an error if trying to delete a subquery" 701 | (check-exn 702 | exn:fail:contract? 703 | (lambda () 704 | (delete (from (subquery (select _ 1)) #:as t)))))))) 705 | 706 | (module+ test 707 | (require rackunit/text-ui) 708 | (run-tests sql-tests)) 709 | -------------------------------------------------------------------------------- /deta-test/deta/sql-sqlite3.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require deta 4 | deta/private/dialect/dialect 5 | deta/private/dialect/sqlite3 6 | (only-in deta/private/query 7 | query-stmt) 8 | rackunit 9 | threading) 10 | 11 | (provide 12 | sql-tests) 13 | 14 | (define-check (check-emitted q expected) 15 | (define-values (query _) 16 | (dialect-emit-query sqlite3-dialect (query-stmt q))) 17 | 18 | (with-check-info 19 | (['query query] 20 | ['expected expected]) 21 | (unless (equal? query expected) 22 | (fail-check)))) 23 | 24 | (define sql-tests 25 | (test-suite 26 | "sqlite3-sql" 27 | 28 | (test-suite 29 | "functions" 30 | 31 | (check-emitted 32 | (~> (from "books" #:as b) 33 | (where (< b.published-at (date "now")))) 34 | "SELECT * FROM books AS b WHERE b.published_at < (DATE('now'))") 35 | 36 | (check-emitted 37 | (~> (from "books" #:as b) 38 | (where (< b.published-at (date "now" "start of month" "+1 month" "-1 day")))) 39 | "SELECT * FROM books AS b WHERE b.published_at < (DATE('now', 'start of month', '+1 month', '-1 day'))") 40 | 41 | (check-emitted 42 | (~> (from "books" #:as b) 43 | (where (< b.published-at (time "now")))) 44 | "SELECT * FROM books AS b WHERE b.published_at < (TIME('now'))") 45 | 46 | (check-emitted 47 | (~> (from "books" #:as b) 48 | (where (< b.published-at (datetime "now")))) 49 | "SELECT * FROM books AS b WHERE b.published_at < (DATETIME('now'))")) 50 | 51 | (test-suite 52 | "limit" 53 | 54 | (check-emitted 55 | (~> (from "books" #:as b) 56 | (limit 20)) 57 | 58 | "SELECT * FROM books AS b LIMIT 20") 59 | 60 | (check-emitted 61 | (~> (from "books" #:as b) 62 | (offset 10) 63 | (limit 20)) 64 | 65 | "SELECT * FROM books AS b LIMIT 20 OFFSET 10")) 66 | 67 | (test-suite 68 | "returning" 69 | 70 | (check-emitted 71 | (~> (from "books" #:as b) 72 | (update [published-at (date "now")]) 73 | (returning title)) 74 | 75 | "UPDATE books AS b SET published_at = DATE('now') RETURNING TITLE")) 76 | 77 | (test-suite 78 | "union" 79 | 80 | (check-emitted 81 | (~> (select _ 1) 82 | (union (select _ 2)) 83 | (union (select _ 3))) 84 | "SELECT 1 UNION SELECT 2 UNION SELECT 3")))) 85 | 86 | (module+ test 87 | (require rackunit/text-ui) 88 | (run-tests sql-tests)) 89 | -------------------------------------------------------------------------------- /deta-test/deta/type.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require db 4 | db/util/postgresql 5 | deta 6 | deta/private/type 7 | gregor 8 | rackunit) 9 | 10 | (define type-tests 11 | (test-suite 12 | "type" 13 | 14 | (test-suite 15 | "array/f" 16 | 17 | (for ([dialect (in-list '(postgresql sqlite3))] 18 | [expected (in-list `((,(sql-date 1996 5 29) 19 | ,(sql-date 2019 5 29)) 20 | ("1996-05-29" 21 | "2019-05-29")))]) 22 | (test-case (format "roundtrip array values (~a)" dialect) 23 | (define type (array/f date/f)) 24 | (define value 25 | (vector (date 1996 5 29) 26 | (date 2019 5 29))) 27 | 28 | (define dumped (type-dump type dialect value)) 29 | (check-equal? dumped expected) 30 | 31 | (define loaded (type-load type dialect (list->pg-array dumped))) 32 | (check-equal? loaded value)))) 33 | 34 | (test-suite 35 | "json/f" 36 | 37 | (for ([dialect (in-list '(postgresql sqlite3))] 38 | [expected (in-list `(#hasheq((hello . "world")) 39 | "{\"hello\":\"world\"}"))]) 40 | (test-case (format "roundtrip json values (~a)" dialect) 41 | (define value (hasheq 'hello "world")) 42 | (define dumped (type-dump json/f dialect value)) 43 | (check-equal? dumped expected) 44 | (define loaded (type-load json/f dialect dumped)) 45 | (check-equal? loaded value)))) 46 | 47 | (test-suite 48 | "uuid/f" 49 | 50 | (test-case "raises when invalid uuid suppiled" 51 | (check-exn 52 | exn:fail:contract? 53 | (lambda () 54 | (define-schema with-uuid 55 | ([uuid uuid/f])) 56 | 57 | (make-with-uuid 58 | #:uuid "invalid-uuid")))) 59 | 60 | (test-case "raises when invoked for sqlite" 61 | (check-exn 62 | exn:fail:user? 63 | (lambda () 64 | (type-declaration uuid/f 'sqlite3)))) 65 | 66 | (test-case "dump and load" 67 | (define some-uuids 68 | '("e51f187c-6ee9-41fe-b30d-76fd9dc92225" 69 | "76db5072-6683-44a9-8bb0-33e582711a97" 70 | "fcd341f6-7731-42a1-9723-18242bdebb2b" 71 | "65640afa-6a5a-4f11-b373-7c2cfd970570" 72 | "df61bc00-7797-4a85-ac0f-23798ed44092" 73 | "08cfce0a-5749-420d-9944-7a37601bf22e" 74 | "bef42146-0060-44a1-bcf2-a7ed97cee580" 75 | "5ef93497-6bf4-478e-8d29-803deb4c42f6" 76 | "26c42415-46ac-4c42-85ac-4600c4ce0d5c" 77 | "0b36d520-cf66-4cfe-bc48-8b69904b9b3a")) 78 | (for ([initial (in-list some-uuids)]) 79 | (check-equal? (type-load uuid/f 'postgresql initial) initial) 80 | (check-equal? (type-dump uuid/f 'postrgesql initial) initial)))) 81 | 82 | (test-suite 83 | "any/f" 84 | 85 | (test-case "raises on type-declaration" 86 | (for ([dialect (in-list '(postgresql sqlite3))]) 87 | (check-exn 88 | exn:fail:user? 89 | (λ () 90 | (type-declaration any/f dialect))))) 91 | 92 | (test-case "raises on type-dump" 93 | (for ([dialect (in-list '(postgresql sqlite3))]) 94 | (check-exn 95 | exn:fail:user? 96 | (λ () 97 | (type-dump any/f dialect "somevalue"))))) 98 | 99 | (test-case "pass-through on type-load" 100 | (for* ([val (in-list '("string" symbol 5 '(another list)))] 101 | [dialect (in-list '(postgresql sqlite))]) 102 | (check-equal? (type-load any/f dialect val) val)))))) 103 | 104 | (module+ test 105 | (require rackunit/text-ui) 106 | (run-tests type-tests)) 107 | -------------------------------------------------------------------------------- /deta-test/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define license 'BSD-3-Clause) 4 | (define collection "tests") 5 | 6 | (define deps '()) 7 | (define build-deps 8 | '("base" 9 | "at-exp-lib" 10 | "db-lib" 11 | "deta-lib" 12 | "gregor-lib" 13 | ["libsqlite3-x86_64-linux" #:platform #rx"x86_64-linux(?!-natipkg)"] 14 | "rackunit-lib" 15 | "threading-lib")) 16 | 17 | (define update-implies '("deta-lib")) 18 | -------------------------------------------------------------------------------- /deta/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2019 Bogdan Popa 2 | 3 | Redistribution and use in source and binary forms, with or without 4 | modification, are permitted provided that the following conditions are 5 | met: 6 | 7 | 1. Redistributions of source code must retain the above copyright 8 | notice, this list of conditions and the following disclaimer. 9 | 10 | 2. Redistributions in binary form must reproduce the above copyright 11 | notice, this list of conditions and the following disclaimer in the 12 | documentation and/or other materials provided with the distribution. 13 | 14 | 3. Neither the name of the copyright holder nor the names of its 15 | contributors may be used to endorse or promote products derived from 16 | this software without specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 24 | TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 25 | PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26 | LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | -------------------------------------------------------------------------------- /deta/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define license 'BSD-3-Clause) 4 | (define collection 'multi) 5 | 6 | (define deps '("deta-doc" 7 | "deta-lib")) 8 | (define implies '("deta-doc" 9 | "deta-lib")) 10 | -------------------------------------------------------------------------------- /examples/books.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require db 4 | deta 5 | threading) 6 | 7 | (define-schema book 8 | ([id id/f #:primary-key #:auto-increment] 9 | [title string/f] 10 | [author string/f] 11 | [year-published integer/f #:nullable])) 12 | 13 | (define conn 14 | (sqlite3-connect #:database 'memory)) 15 | 16 | (void 17 | (create-all! conn) 18 | (insert! conn 19 | (make-book #:title "To Kill a Mockingbird" 20 | #:author "Harper Lee" 21 | #:year-published 1960) 22 | (make-book #:title "1984" 23 | #:author "George Orwell" 24 | #:year-published 1949) 25 | (make-book #:title "The Lord of the Rings" 26 | #:author "J.R.R. Tolkien" 27 | #:year-published 1955) 28 | (make-book #:title "The Catcher in the Rye" 29 | #:author "J.D. Salinger" 30 | #:year-published 1949))) 31 | 32 | (define (books-before year) 33 | (~> (from book #:as b) 34 | (where (< b.year-published ,year)))) 35 | 36 | (define (books-between start-year end-year) 37 | (~> (from book #:as b) 38 | (where (between b.year-published ,start-year ,end-year)))) 39 | 40 | (displayln "Books published before 1950:") 41 | (for ([b (in-entities conn (books-before 1950))]) 42 | (displayln (book-title b))) 43 | 44 | (displayln "") 45 | (displayln "Books published between 1950 and 1970:") 46 | (for ([b (in-entities conn (books-between 1950 1970))]) 47 | (displayln (book-title b))) 48 | 49 | (define-schema book-stats 50 | #:virtual 51 | ([year integer/f] 52 | [books integer/f])) 53 | 54 | (displayln "") 55 | (displayln "Statistics:") 56 | (for ([stats (in-entities conn (~> (from book #:as b) 57 | (select b.year-published (count *)) 58 | (group-by b.year-published) 59 | (order-by ([b.year-published #:desc])) 60 | (project-onto book-stats-schema)))]) 61 | (displayln (format "year: ~a books: ~a" 62 | (book-stats-year stats) 63 | (book-stats-books stats)))) 64 | 65 | (query-exec conn (delete (books-between 1950 1970))) 66 | 67 | (displayln "") 68 | (displayln "Books published between 1950 and 1970:") 69 | (for ([b (in-entities conn (books-between 1950 1970))]) 70 | (displayln (book-title b))) 71 | -------------------------------------------------------------------------------- /examples/issue-58.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require db 4 | deta 5 | gregor 6 | threading) 7 | 8 | (define conn 9 | (postgresql-connect 10 | #:database "deta_examples" 11 | #:user "deta" 12 | #:password "deta")) 13 | 14 | (define-schema reserved 15 | #:table "reserved" 16 | ([user string/f] 17 | [(timestamp (now/moment)) datetime-tz/f])) 18 | 19 | (create-all! conn) 20 | (query-exec conn "TRUNCATE reserved") 21 | 22 | (define entities 23 | (insert! 24 | conn 25 | (make-reserved #:user "example1") 26 | (make-reserved #:user "example2"))) 27 | 28 | (query-value conn (select _ user)) 29 | (query-value conn (select _ current_timestamp)) 30 | (for/list ([r (in-entities conn (from reserved #:as r))]) r) 31 | (for/list ([r (in-entities conn (~> (from reserved #:as r) 32 | (where (= r.user "example1"))))]) 33 | r) 34 | -------------------------------------------------------------------------------- /examples/json.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require db 4 | deta 5 | threading) 6 | 7 | (define-schema example 8 | ([id id/f #:primary-key #:auto-increment] 9 | [data json/f])) 10 | 11 | (define conn 12 | (sqlite3-connect #:database 'memory)) 13 | 14 | (void 15 | (create-all! conn) 16 | (insert! conn 17 | (make-example #:data (hasheq)) 18 | (make-example #:data (hasheq 'hello "world")))) 19 | 20 | (displayln "All rows:") 21 | (for ([e (in-entities conn (from example #:as e))]) 22 | (println e)) 23 | 24 | (displayln "Rows with a 'hello' key:") 25 | (for ([e (in-entities conn (~> (from example #:as e) 26 | (where (not (is (json-ref e.data "hello") null)))))]) 27 | (println e)) 28 | --------------------------------------------------------------------------------