├── .editorconfig ├── .github ├── PULL_REQUEST_TEMPLATE.md └── workflows │ └── haskell.yml ├── .gitignore ├── .stylish-haskell.yaml ├── .travis.yml ├── LICENSE ├── Makefile ├── README.md ├── Setup.hs ├── cabal.project ├── changelog.md ├── docs └── blog_post_2012_08_06 ├── esqueleto.cabal ├── esqueleto.png ├── examples ├── .gitignore ├── Blog.hs ├── LICENSE ├── Main.hs ├── README.md ├── Setup.hs ├── esqueleto-examples.cabal └── package.yaml ├── screwdriver.yaml ├── src └── Database │ ├── Esqueleto.hs │ └── Esqueleto │ ├── Experimental.hs │ ├── Experimental │ ├── From.hs │ ├── From │ │ ├── CommonTableExpression.hs │ │ ├── Join.hs │ │ └── SqlSetOperation.hs │ ├── ToAlias.hs │ ├── ToAliasReference.hs │ └── ToMaybe.hs │ ├── Internal │ ├── ExprParser.hs │ ├── Internal.hs │ └── PersistentImport.hs │ ├── Legacy.hs │ ├── MySQL.hs │ ├── PostgreSQL.hs │ ├── PostgreSQL │ ├── JSON.hs │ └── JSON │ │ └── Instances.hs │ ├── Record.hs │ └── SQLite.hs ├── stack-8.10.yaml ├── stack-8.2.yaml ├── stack-8.4.yaml ├── stack-8.6.yaml ├── stack-8.8.yaml ├── stack-8.8.yaml.lock ├── stack-9.0.yaml ├── stack-nightly.yaml ├── stack-nightly.yaml.lock ├── stack.yaml ├── style-guide.md └── test ├── Common ├── Record.hs ├── Test.hs └── Test │ ├── CTE.hs │ ├── Import.hs │ ├── Models.hs │ └── Select.hs ├── MySQL └── Test.hs ├── PostgreSQL ├── MigrateJSON.hs └── Test.hs ├── SQLite └── Test.hs ├── Spec.hs ├── docker-compose.yml ├── expected-compile-failures ├── .gitignore ├── README.md ├── Setup.hs ├── package.yaml ├── src │ └── Lib.hs ├── stack-8.2.yaml ├── stack-8.4.yaml ├── stack-8.6.yaml ├── stack.yaml ├── stack.yaml.lock ├── test.sh ├── update-read-role │ └── Main.hs └── write-read-role │ └── Main.hs └── new-join-compiler-errors ├── README.md ├── bad-errors └── Main.hs ├── new-join-compiler-errors.cabal ├── package.yaml ├── src └── Lib.hs └── stack.yaml /.editorconfig: -------------------------------------------------------------------------------- 1 | # http://editorconfig.org 2 | root = true 3 | 4 | [Makefile] 5 | indent_style = tabs 6 | indent_size = 8 7 | end_of_line = lf 8 | charset = utf-8 9 | trim_trailing_whitespace = true 10 | insert_final_newline = true 11 | 12 | [*.{hs,md,php}] 13 | indent_style = space 14 | indent_size = 4 15 | tab_width = 4 16 | end_of_line = lf 17 | charset = utf-8 18 | trim_trailing_whitespace = true 19 | insert_final_newline = true 20 | max_line_length = 80 21 | -------------------------------------------------------------------------------- /.github/PULL_REQUEST_TEMPLATE.md: -------------------------------------------------------------------------------- 1 | Before submitting your PR, check that you've: 2 | 3 | - [ ] Bumped the version number. 4 | - [ ] Documented new APIs with [Haddock markup](https://www.haskell.org/haddock/doc/html/index.html). 5 | - [ ] Added [`@since` declarations](http://haskell-haddock.readthedocs.io/en/latest/markup.html#since) to the Haddock. 6 | - [ ] Ran `stylish-haskell` and otherwise adhered to the [style guide](https://github.com/bitemyapp/esqueleto/blob/master/style-guide.yaml). 7 | 8 | After submitting your PR: 9 | 10 | - [ ] Update the Changelog.md file with a link to your PR. 11 | - [ ] Check that CI passes (or if it fails, for reasons unrelated to your change, like CI timeouts). 12 | 13 | 20 | -------------------------------------------------------------------------------- /.github/workflows/haskell.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | on: 3 | push: 4 | branches: 5 | - master 6 | pull_request: 7 | types: 8 | - opened 9 | - synchronize 10 | jobs: 11 | build: 12 | runs-on: ubuntu-latest 13 | services: 14 | # mysql-service Label used to access the service container 15 | mysql-service: 16 | # Docker Hub image (also with version) 17 | image: mysql:8.0 18 | env: 19 | ## Accessing to Github secrets, where you can store your configuration 20 | MYSQL_USER: travis 21 | MYSQL_PASSWORD: esqutest 22 | MYSQL_ROOT_PASSWORD: esqutest 23 | MYSQL_DATABASE: esqutest 24 | ## map the "external" 33306 port with the "internal" 3306 25 | ports: 26 | - 33306:3306 27 | # Set health checks to wait until mysql database has started (it takes some seconds to start) 28 | options: >- 29 | --health-cmd="mysqladmin ping" 30 | --health-interval=10s 31 | --health-timeout=5s 32 | --health-retries=3 33 | strategy: 34 | matrix: 35 | cabal: ["3.10.2.1"] 36 | ghc: 37 | - "8.6" 38 | - "8.8" 39 | - "8.10" 40 | - "9.0" 41 | - "9.2" 42 | - "9.4" 43 | - "9.6" 44 | - "9.8" 45 | - "9.10" 46 | # - "9.12" 47 | env: 48 | CONFIG: "--enable-tests --enable-benchmarks " 49 | steps: 50 | - uses: actions/checkout@v4 51 | - uses: haskell-actions/setup@v2 52 | id: setup-haskell-cabal 53 | with: 54 | ghc-version: ${{ matrix.ghc }} 55 | cabal-version: ${{ matrix.cabal }} 56 | - uses: harmon758/postgresql-action@v1 57 | with: 58 | postgresql version: '12' # See https://hub.docker.com/_/postgres for available versions 59 | postgresql user: esqutest 60 | postgresql password: esqutest 61 | postgresql db: esqutest 62 | - name: Create MySQL 63 | run: mysql -utravis -pesqutest -h127.0.0.1 --port=33306 esqutest -e "SELECT 1;" 64 | # - name: Shutdown Ubuntu MySQL (SUDO) 65 | # run: sudo service mysql stop 66 | # - uses: mirromutth/mysql-action@v1.1 67 | # with: 68 | # mysql version: '8.0' # Optional, default value is "latest". The version of the MySQL 69 | # mysql database: 'esqutest' # Optional, default value is "test". The specified database which will be create 70 | # mysql user: 'travis' # Required if "mysql root password" is empty, default is empty. The superuser for the specified database. Can use secrets, too 71 | # mysql password: 'esqutest' # Required if "mysql user" exists. The password for the "mysql user" 72 | - run: sudo apt-get update && sudo apt-get install -y libpcre3-dev 73 | - run: cabal v2-update 74 | - run: cabal v2-freeze $CONFIG 75 | - uses: actions/cache@v4 76 | with: 77 | path: | 78 | ${{ steps.setup-haskell-cabal.outputs.cabal-store }} 79 | dist-newstyle 80 | key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }} 81 | restore-keys: | 82 | ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }} 83 | ${{ runner.os }}-${{ matrix.ghc }}- 84 | - run: cabal v2-build --disable-optimization -j $CONFIG 85 | - run: cabal v2-test --disable-optimization -j $CONFIG --test-options "--fail-on-focus" 86 | - if: ${{ matrix.ghc != '8.6' }} 87 | run: cabal v2-haddock -j $CONFIG 88 | - run: cabal v2-sdist 89 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work 2 | stack.yaml.lock 3 | *.yaml.lock 4 | /dist* 5 | *~ 6 | .cabal-sandbox/ 7 | cabal.sandbox.config 8 | .hspec-failures 9 | *.sqlite* 10 | cabal.project.freeze 11 | -------------------------------------------------------------------------------- /.stylish-haskell.yaml: -------------------------------------------------------------------------------- 1 | steps: 2 | - imports: 3 | align: none 4 | list_align: with_module_name 5 | pad_module_names: false 6 | long_list_align: new_line_multiline 7 | empty_list_align: inherit 8 | list_padding: 7 # length "import " 9 | separate_lists: false 10 | space_surround: false 11 | - language_pragmas: 12 | style: vertical 13 | align: false 14 | remove_redundant: true 15 | - simple_align: 16 | cases: false 17 | top_level_patterns: false 18 | records: false 19 | - trailing_whitespace: {} 20 | indent: 4 21 | columns: 80 22 | newline: native 23 | language_extensions: 24 | - BlockArguments 25 | - DataKinds 26 | - DeriveGeneric 27 | - DerivingStrategies 28 | - DerivingVia 29 | - ExplicitForAll 30 | - FlexibleContexts 31 | - MultiParamTypeClasses 32 | - NamedFieldPuns 33 | - OverloadedStrings 34 | - QuantifiedConstraints 35 | - RecordWildCards 36 | - ScopedTypeVariables 37 | - TemplateHaskell 38 | - TypeApplications 39 | - ViewPatterns 40 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | 3 | services: 4 | - mysql 5 | 6 | addons: 7 | postgresql: "10" 8 | apt: 9 | packages: 10 | - libgmp-dev 11 | - postgresql-10 12 | - postgresql-client-10 13 | - postgresql-server-dev-all 14 | 15 | env: 16 | global: 17 | - PGPORT=5432 18 | matrix: 19 | - GHCVER=8.2 20 | - GHCVER=8.4 21 | - GHCVER=8.6 22 | - GHCVER=8.8 23 | - GHCVER=nightly 24 | 25 | jobs: 26 | fast_finish: true 27 | allow_failures: 28 | - env: GHCVER=nightly 29 | 30 | install: 31 | - export STACK_YAML=stack-$GHCVER.yaml 32 | - mkdir -p ~/.local/bin 33 | - export PATH=$HOME/.local/bin:$PATH 34 | - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 35 | - stack --version 36 | - psql -c "CREATE USER esqutest WITH PASSWORD 'esqutest';" -U postgres 37 | - createdb -O esqutest esqutest 38 | - mysql -e 'CREATE DATABASE esqutest;' 39 | - stack setup 40 | 41 | script: 42 | - stack build --fast $(if [[ $GHCVER == "nightly" ]]; then echo "--resolver nightly"; fi) 43 | - stack test --fast $(if [[ $GHCVER == "nightly" ]]; then echo "--resolver nightly"; fi) 44 | - cd test/expected-compile-failures/ 45 | - bash test.sh 46 | 47 | cache: 48 | directories: 49 | - $HOME/.stack 50 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012, Felipe Lessa 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Felipe Lessa nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | STACK := stack --jobs $(shell nproc) 2 | 3 | match ?= 4 | 5 | STACK_TEST_ARGS := $(if $(match),--test-arguments "--match $(match)",) 6 | 7 | .PHONY: build 8 | build: 9 | $(STACK) build 10 | 11 | .PHONY: build-tests 12 | build-tests: 13 | $(STACK) build --test --no-run-tests 14 | 15 | .PHONY: ghci 16 | ghci: 17 | $(STACK) ghci 18 | 19 | .PHONY: test 20 | test: 21 | $(STACK) test $(STACK_TEST_ARGS) 22 | 23 | # Intended for use in local dev 24 | .PHONY: test-postgresql 25 | test-postgresql: reset-pgsql 26 | $(STACK) test esqueleto:postgresql $(STACK_TEST_ARGS) 27 | 28 | .PHONY: test-mysql 29 | test-mysql: 30 | $(STACK) test esqueleto:mysql $(STACK_TEST_ARGS) 31 | 32 | .PHONY: test-ghci 33 | test-ghci: 34 | $(STACK) ghci esqueleto:test:sqlite $(STACK_TEST_ARGS) 35 | 36 | .PHONY: test-ghcid 37 | test-ghcid: 38 | ghcid -c "$(STACK) ghci --ghci-options -fobject-code esqueleto --test" \ 39 | --warnings \ 40 | --restart "stack.yaml" \ 41 | --restart "esqueleto.cabal" \ 42 | --test main 43 | 44 | .PHONY: test-ghcid-build 45 | test-ghcid-build: 46 | ghcid -c "$(STACK) ghci --ghci-options -fobject-code esqueleto --test" \ 47 | --warnings \ 48 | --restart "stack.yaml" \ 49 | --restart "esqueleto.cabal" 50 | 51 | .PHONY: haddock doc 52 | haddock: doc 53 | doc: 54 | $(STACK) haddock 55 | 56 | .PHONY: clean 57 | clean: 58 | $(STACK) clean 59 | 60 | .PHONY: init-pgsql 61 | 62 | init-pgsql: 63 | sudo -u postgres -- createuser -s esqutest 64 | 65 | .PHONY: reset-pgsql 66 | reset-pgsql: 67 | -sudo -u postgres dropdb esqutest 68 | -sudo -u postgres dropuser esqutest 69 | echo "CREATE USER esqutest WITH PASSWORD 'esqutest';" | sudo -u postgres psql 70 | sudo -u postgres createdb -O esqutest esqutest 71 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Esqueleto [![CI](https://github.com/bitemyapp/esqueleto/actions/workflows/haskell.yml/badge.svg?branch=master)](https://github.com/bitemyapp/esqueleto/actions/workflows/haskell.yml) 2 | ========== 3 | 4 | ![Skeleton](./esqueleto.png) 5 | Image courtesy [Chrissy Long](https://www.flickr.com/photos/chrissylong/313800029/) 6 | 7 | # Esqueleto, a SQL DSL for Haskell 8 | 9 | Esqueleto is a bare bones, type-safe EDSL for SQL queries that works with unmodified persistent SQL backends. The name of this library means "skeleton" in Portuguese and contains all three SQL letters in the correct order =). It was inspired by Scala's Squeryl but created from scratch. Its language closely resembles SQL. Currently, SELECTs, UPDATEs, INSERTs and DELETEs are supported. 10 | 11 | In particular, esqueleto is the recommended library for type-safe JOINs on persistent SQL backends. (The alternative is using raw SQL, but that's error prone and does not offer any composability.). For more information read [esqueleto](http://hackage.haskell.org/package/esqueleto). 12 | 13 | ## Setup 14 | 15 | If you're already using `persistent`, then you're ready to use `esqueleto`, no further setup is needed. If you're just starting a new project and would like to use `esqueleto`, take a look at `persistent`'s [book](http://www.yesodweb.com/book/persistent) first to learn how to define your schema. 16 | 17 | If you need to use `persistent`'s default support for queries as well, either import it qualified: 18 | 19 | ```haskell 20 | -- For a module that mostly uses esqueleto. 21 | import Database.Esqueleto 22 | import qualified Database.Persistent as P 23 | ``` 24 | 25 | or import `esqueleto` itself qualified: 26 | 27 | ```haskell 28 | -- For a module that uses esqueleto just on some queries. 29 | import Database.Persistent 30 | import qualified Database.Esqueleto as E 31 | ``` 32 | 33 | Other than identifier name clashes, `esqueleto` does not conflict with `persistent` in any way. 34 | 35 | 36 | ## Goals 37 | 38 | The main goals of `esqueleto` are: 39 | 40 | - Be easily translatable to SQL. (You should be able to know exactly how the SQL query will end up.) 41 | - Support the most widely used SQL features. 42 | - Be as type-safe as possible. 43 | 44 | It is _not_ a goal to be able to write portable SQL. We do not try to hide the differences between DBMSs from you 45 | 46 | 47 | ## Introduction 48 | 49 | For the following examples, we'll use this example schema: 50 | 51 | ```haskell 52 | share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persist| 53 | Person 54 | name String 55 | age Int Maybe 56 | deriving Eq Show 57 | BlogPost 58 | title String 59 | authorId PersonId 60 | deriving Eq Show 61 | Follow 62 | follower PersonId 63 | followed PersonId 64 | deriving Eq Show 65 | |] 66 | ``` 67 | 68 | ## Select 69 | 70 | Most of `esqueleto` was created with `SELECT` statements in mind, not only because they're the most common but also because they're the most complex kind of statement. The most simple kind of `SELECT` would be: 71 | 72 | ```haskell 73 | putPersons :: SqlPersist m () 74 | putPersons = do 75 | people <- select $ 76 | from $ \person -> do 77 | return person 78 | liftIO $ mapM_ (putStrLn . personName . entityVal) people 79 | ``` 80 | 81 | which generates this SQL: 82 | 83 | ```sql 84 | SELECT * 85 | FROM Person 86 | ``` 87 | 88 | `esqueleto` knows that we want an `Entity Person` just because of the `personName` that is printed. 89 | 90 | ## Where 91 | 92 | Filtering by `PersonName`: 93 | 94 | ```haskell 95 | select $ 96 | from $ \p -> do 97 | where_ (p ^. PersonName ==. val "John") 98 | return p 99 | ``` 100 | 101 | which generates this SQL: 102 | 103 | ```sql 104 | SELECT * 105 | FROM Person 106 | WHERE Person.name = "John" 107 | ``` 108 | 109 | The `(^.)` operator is used to project a field from an entity. The field name is the same one generated by `persistent`s Template Haskell functions. We use `val` to lift a constant Haskell value into the SQL query. 110 | 111 | Another example: 112 | 113 | In `esqueleto`, we may write the same query above as: 114 | 115 | ```haskell 116 | select $ 117 | from $ \p -> do 118 | where_ (p ^. PersonAge >=. just (val 18)) 119 | return p 120 | ``` 121 | 122 | which generates this SQL: 123 | 124 | ```sql 125 | SELECT * 126 | FROM Person 127 | WHERE Person.age >= 18 128 | ``` 129 | 130 | Since `age` is an optional `Person` field, we use `just` to lift `val 18 :: SqlExpr (Value Int)` into `just (val 18) ::SqlExpr (Value (Maybe Int))`. 131 | 132 | ### Alternative Field Projections 133 | 134 | The `(^.)` operator works on an `EntityField` value, which are generated by 135 | `persistent` as the table name + the field name. This can get a little bit 136 | verbose. As of `persistent-2.11`, you can use `OverloadedLabels` to make this a 137 | bit more concise: 138 | 139 | ```haskell 140 | {-# LANGUAGE OverloadedLabels #-} 141 | 142 | select $ do 143 | p <- from $ table @Person 144 | pure 145 | ( p ^. PersonName 146 | , p ^. #name 147 | ) 148 | ``` 149 | 150 | The `OverloadedLabels` support uses the `fieldName` as given by the Persistent 151 | entity definition syntax - no type name prefix necessary. Additionally, these 152 | field accesses are *polymorphic* - the following query filters any table that 153 | has a `name` column: 154 | 155 | ```haskell 156 | rowsByName 157 | :: forall rec. 158 | ( PersistEntity rec 159 | , PersistEntityBackend rec ~ SqlBackend 160 | , SymbolToField "name" rec Text 161 | ) 162 | => SqlExpr (Value Text) 163 | -> SqlQuery (SqlExpr (Entity rec)) 164 | rowsByName name = do 165 | rec <- from $ table @rec 166 | where_ $ rec ^. #name ==. name 167 | pure rec 168 | ``` 169 | 170 | GHC 9.2 introduces the `OverloadedRecordDot` language extension, and `esqueleto` 171 | supports this on `SqlExpr (Entity rec)` and `SqlExpr (Maybe (Entity rec))`. It 172 | looks like this: 173 | 174 | ```haskell 175 | select $ do 176 | (person, blogPost) <- 177 | from $ 178 | table @Person 179 | `leftJoin` table @BlogPost 180 | `on` do 181 | \(person :& blogPost) -> 182 | just person.id ==. blogPost.authorId 183 | pure (person.name, blogPost.title) 184 | ``` 185 | 186 | ## Experimental/New Joins 187 | 188 | There's a new way to write `JOIN`s in esqueleto! It has less potential for 189 | runtime errors and is much more powerful than the old syntax. To opt in to the 190 | new syntax, import: 191 | 192 | ```haskell 193 | import Database.Esqueleto.Experimental 194 | ``` 195 | 196 | This will conflict with the definition of `from` and `on` in the 197 | `Database.Esqueleto` module, so you'll want to remove that import. 198 | 199 | This style will become the new "default" in esqueleto-4.0.0.0, so it's a good 200 | idea to port your code to using it soon. 201 | 202 | The module documentation in `Database.Esqueleto.Experimental` has many examples, 203 | and they won't be repeated here. Here's a quick sample: 204 | 205 | ```haskell 206 | select $ do 207 | (a :& b) <- 208 | from $ 209 | Table @BlogPost 210 | `InnerJoin` 211 | Table @Person 212 | `on` do \(bp :& a) -> 213 | bp ^. BlogPostAuthorId ==. a ^. PersonId 214 | pure (a, b) 215 | ``` 216 | 217 | Advantages: 218 | 219 | - `ON` clause is attached directly to the relevant join, so you never need to 220 | worry about how they're ordered, nor will you ever run into bugs where the 221 | `on` clause is on the wrong `JOIN` 222 | - The `ON` clause lambda will exclusively have all the available tables in it. This forbids 223 | runtime errors where an `ON` clause refers to a table that isn't in scope yet. 224 | - You can join on a table twice, and the aliases work out fine with the `ON` 225 | clause. 226 | - You can use `UNION`, `EXCEPT`, `INTERSECTION` etc with this new syntax! 227 | - You can reuse subqueries more easily. 228 | 229 | ## Legacy Joins 230 | 231 | Implicit joins are represented by tuples. 232 | 233 | For example, to get the list of all blog posts and their authors, we could write: 234 | 235 | ```haskell 236 | select $ 237 | from $ \(b, p) -> do 238 | where_ (b ^. BlogPostAuthorId ==. p ^. PersonId) 239 | orderBy [asc (b ^. BlogPostTitle)] 240 | return (b, p) 241 | ``` 242 | 243 | which generates this SQL: 244 | 245 | ```sql 246 | SELECT BlogPost.*, Person.* 247 | FROM BlogPost, Person 248 | WHERE BlogPost.authorId = Person.id 249 | ORDER BY BlogPost.title ASC 250 | ``` 251 | 252 | 253 | However, you may want your results to include people who don't have any blog posts as well using a `LEFT OUTER JOIN`: 254 | 255 | ```haskell 256 | select $ 257 | from $ \(p `LeftOuterJoin` mb) -> do 258 | on (just (p ^. PersonId) ==. mb ?. BlogPostAuthorId) 259 | orderBy [asc (p ^. PersonName), asc (mb ?. BlogPostTitle)] 260 | return (p, mb) 261 | ``` 262 | 263 | which generates this SQL: 264 | 265 | ```sql 266 | SELECT Person.*, BlogPost.* 267 | FROM Person LEFT OUTER JOIN BlogPost 268 | ON Person.id = BlogPost.authorId 269 | ORDER BY Person.name ASC, BlogPost.title ASC 270 | ``` 271 | 272 | ## Left Outer Join 273 | 274 | On a `LEFT OUTER JOIN` the entity on the right hand side may not exist (i.e. there may be a `Person` without any `BlogPost`s), so while `p :: SqlExpr (Entity Person)`, we have `mb :: SqlExpr (Maybe (Entity BlogPost))`. The whole expression above has type `SqlPersist m [(Entity Person, Maybe (Entity BlogPost))]`. Instead of using `(^.)`, we used `(?.)` to project a field from a `Maybe (Entity a)`. 275 | 276 | We are by no means limited to joins of two tables, nor by joins of different tables. For example, we may want a list of the `Follow` entity: 277 | 278 | ```haskell 279 | select $ 280 | from $ \(p1 `InnerJoin` f `InnerJoin` p2) -> do 281 | on (p2 ^. PersonId ==. f ^. FollowFollowed) 282 | on (p1 ^. PersonId ==. f ^. FollowFollower) 283 | return (p1, f, p2) 284 | ``` 285 | 286 | which generates this SQL: 287 | 288 | ```sql 289 | SELECT P1.*, Follow.*, P2.* 290 | FROM Person AS P1 291 | INNER JOIN Follow ON P1.id = Follow.follower 292 | INNER JOIN Person AS P2 ON P2.id = Follow.followed 293 | ``` 294 | 295 | ## Update and Delete 296 | 297 | ```haskell 298 | do update $ \p -> do 299 | set p [ PersonName =. val "João" ] 300 | where_ (p ^. PersonName ==. val "Joao") 301 | delete $ 302 | from $ \p -> do 303 | where_ (p ^. PersonAge <. just (val 14)) 304 | ``` 305 | 306 | The results of queries can also be used for insertions. In `SQL`, we might write the following, inserting a new blog post for every user: 307 | 308 | ```haskell 309 | insertSelect $ from $ \p-> 310 | return $ BlogPost <# "Group Blog Post" <&> (p ^. PersonId) 311 | ``` 312 | 313 | which generates this SQL: 314 | 315 | ```sql 316 | INSERT INTO BlogPost 317 | SELECT ('Group Blog Post', id) 318 | FROM Person 319 | ``` 320 | 321 | Individual insertions can be performed through Persistent's `insert` function, reexported for convenience. 322 | 323 | ### Re-exports 324 | 325 | We re-export many symbols from `persistent` for convenience: 326 | - "Store functions" from "Database.Persist". 327 | - Everything from "Database.Persist.Class" except for `PersistQuery` and `delete` (use `deleteKey` instead). 328 | - Everything from "Database.Persist.Types" except for `Update`, `SelectOpt`, `BackendSpecificFilter` and `Filter`. 329 | - Everything from "Database.Persist.Sql" except for `deleteWhereCount` and `updateWhereCount`. 330 | 331 | ### RDBMS Specific 332 | 333 | There are many differences between SQL syntax and functions supported by different RDBMSs. Since version 2.2.8, `esqueleto` includes modules containing functions that are specific to a given RDBMS. 334 | 335 | - PostgreSQL: `Database.Esqueleto.PostgreSQL` 336 | - MySQL: `Database.Esqueleto.MySQL` 337 | - SQLite: `Database.Esqueleto.SQLite` 338 | 339 | In order to use these functions, you need to explicitly import their corresponding modules. 340 | 341 | ### Unsafe functions, operators and values 342 | 343 | Esqueleto doesn't support every possible function, and it can't - many functions aren't available on every RDBMS platform, and sometimes the same functionality is hidden behind different names. To overcome this problem, Esqueleto exports a number of unsafe functions to call any function, operator or value. These functions can be found in Database.Esqueleto.Internal.Sql module. 344 | 345 | Warning: the functions discussed in this section must always be used with an explicit type signature,and the user must be careful to provide a type signature that corresponds correctly with the underlying code. The functions have extremely general types, and if you allow type inference to figure everything out for you, it may not correspond with the underlying SQL types that you want. This interface is effectively the FFI to SQL database, so take care! 346 | 347 | The most common use of these functions is for calling RDBMS specific or custom functions, 348 | for that end we use `unsafeSqlFunction`. For example, if we wish to consult the postgres 349 | `now` function we could so as follow: 350 | 351 | ```haskell 352 | postgresTime :: (MonadIO m, MonadLogger m) => SqlWriteT m UTCTime 353 | postgresTime = 354 | result <- select (pure now) 355 | case result of 356 | [x] -> pure x 357 | _ -> error "now() is guaranteed to return a single result" 358 | where 359 | now :: SqlExpr (Value UTCTime) 360 | now = unsafeSqlFunction "now" () 361 | ``` 362 | 363 | which generates this SQL: 364 | 365 | ```sql 366 | SELECT now() 367 | ``` 368 | 369 | With the `now` function we could now use the current time of the postgres RDBMS on any query. 370 | Do notice that `now` does not use any arguments, so we use `()` that is an instance of 371 | `UnsafeSqlFunctionArgument` to represent no arguments, an empty list cast to a correct value 372 | will yield the same result as `()`. 373 | 374 | We can also use `unsafeSqlFunction` for more complex functions with customs values using 375 | `unsafeSqlValue` which turns any string into a sql value of whatever type we want, disclaimer: 376 | if you use it badly you will cause a runtime error. For example, say we want to try postgres' 377 | `date_part` function and get the day of a timestamp, we could use: 378 | 379 | ```haskell 380 | postgresTimestampDay :: (MonadIO m, MonadLogger m) => SqlWriteT m Int 381 | postgresTimestampDay = 382 | result <- select (return $ dayPart date) 383 | case result of 384 | [x] -> pure x 385 | _ -> error "dayPart is guaranteed to return a single result" 386 | where 387 | dayPart :: SqlExpr (Value UTCTime) -> SqlExpr (Value Int) 388 | dayPart s = unsafeSqlFunction "date_part" (unsafeSqlValue "\'day\'" :: SqlExpr (Value String) ,s) 389 | date :: SqlExpr (Value UTCTime) 390 | date = unsafeSqlValue "TIMESTAMP \'2001-02-16 20:38:40\'" 391 | ``` 392 | 393 | which generates this SQL: 394 | 395 | ```sql 396 | SELECT date_part('day', TIMESTAMP '2001-02-16 20:38:40') 397 | ``` 398 | 399 | Using `unsafeSqlValue` we were required to also define the type of the value. 400 | 401 | Another useful unsafe function is `unsafeSqlCastAs`, which allows us to cast any type 402 | to another within a query. For example, say we want to use our previews `dayPart` function 403 | on the current system time, we could: 404 | 405 | ```haskell 406 | postgresTimestampDay :: (MonadIO m, MonadLogger m) => SqlWriteT m Int 407 | postgresTimestampDay = do 408 | currentTime <- liftIO getCurrentTime 409 | result <- select (return $ dayPart (toTIMESTAMP $ val currentTime)) 410 | case result of 411 | [x] -> pure x 412 | _ -> error "dayPart is guaranteed to return a single result" 413 | where 414 | dayPart :: SqlExpr (Value UTCTime) -> SqlExpr (Value Int) 415 | dayPart s = unsafeSqlFunction "date_part" (unsafeSqlValue "\'day\'" :: SqlExpr (Value String) ,s) 416 | toTIMESTAMP :: SqlExpr (Value UTCTime) -> SqlExpr (Value UTCTime) 417 | toTIMESTAMP = unsafeSqlCastAs "TIMESTAMP" 418 | ``` 419 | 420 | which generates this SQL: 421 | 422 | ```sql 423 | SELECT date_part('day', CAST('2019-10-28 23:19:39.400898344Z' AS TIMESTAMP)) 424 | ``` 425 | 426 | ### SQL injection 427 | 428 | Esqueleto uses parameterization to prevent sql injections on values and arguments 429 | on all queries, for example, if we have: 430 | 431 | ```haskell 432 | myEvilQuery :: (MonadIO m, MonadLogger m) => SqlWriteT m () 433 | myEvilQuery = 434 | select (return $ val ("hi\'; DROP TABLE foo; select \'bye\'" :: String)) >>= liftIO . print 435 | ``` 436 | 437 | which generates this SQL(when using postgres): 438 | 439 | ```sql 440 | SELECT 'hi''; DROP TABLE foo; select ''bye''' 441 | ``` 442 | 443 | And the printed value is `hi\'; DROP TABLE foo; select \'bye\'` and no table is dropped. This is good 444 | and makes the use of strings values safe. Unfortunately this is not the case when using unsafe functions. 445 | Let's see an example of defining a new evil `now` function: 446 | 447 | ```haskell 448 | myEvilQuery :: (MonadIO m, MonadLogger m) => SqlWriteT m () 449 | myEvilQuery = 450 | select (return nowWithInjection) >>= liftIO . print 451 | where 452 | nowWithInjection :: SqlExpr (Value UTCTime) 453 | nowWithInjection = unsafeSqlFunction "0; DROP TABLE bar; select now" ([] :: [SqlExpr (Value Int)]) 454 | ``` 455 | 456 | which generates this SQL: 457 | 458 | ```sql 459 | SELECT 0; DROP TABLE bar; select now() 460 | ``` 461 | 462 | If we were to run the above code we would see the postgres time printed but the table `bar` 463 | will be erased with no indication whatsoever. Another example of this behavior is seen when using 464 | `unsafeSqlValue`: 465 | 466 | ```haskell 467 | myEvilQuery :: (MonadIO m, MonadLogger m) => SqlWriteT m () 468 | myEvilQuery = 469 | select (return $ dayPart dateWithInjection) >>= liftIO . print 470 | where 471 | dayPart :: SqlExpr (Value UTCTime) -> SqlExpr (Value Int) 472 | dayPart s = unsafeSqlFunction "date_part" (unsafeSqlValue "\'day\'" :: SqlExpr (Value String) ,s) 473 | dateWithInjection :: SqlExpr (Value UTCTime) 474 | dateWithInjection = unsafeSqlValue "TIMESTAMP \'2001-02-16 20:38:40\');DROP TABLE bar; select (16" 475 | ``` 476 | 477 | which generates this SQL: 478 | 479 | ```sql 480 | SELECT date_part('day', TIMESTAMP '2001-02-16 20:38:40');DROP TABLE bar; select (16) 481 | ``` 482 | 483 | This will print 16 and also erase the `bar` table. The main take away of this examples is to 484 | never use any user or third party input inside an unsafe function without first parsing it or 485 | heavily sanitizing the input. 486 | 487 | ### Tests 488 | 489 | To run the tests, do `stack test`. This tests all the backends, so you'll need 490 | to have MySQL and Postgresql installed. 491 | 492 | #### Postgres 493 | 494 | Using apt-get, you should be able to do: 495 | 496 | ``` 497 | sudo apt-get install postgresql postgresql-contrib 498 | sudo apt-get install libpq-dev 499 | ``` 500 | 501 | Using homebrew on OSx 502 | 503 | ``` 504 | brew install postgresql 505 | brew install libpq 506 | ``` 507 | 508 | Detailed instructions on the Postgres wiki [here](https://wiki.postgresql.org/wiki/Detailed_installation_guides) 509 | 510 | The connection details are located near the bottom of the [test/PostgreSQL/Test.hs](test/PostgreSQL/Test.hs) file: 511 | 512 | ``` 513 | withConn = 514 | R.runResourceT . withPostgresqlConn "host=localhost port=5432 user=esqutest password=esqutest dbname=esqutest" 515 | ``` 516 | 517 | You can change these if you like but to just get them working set up as follows on linux: 518 | 519 | ``` 520 | $ sudo -u postgres createuser esqutest 521 | $ sudo -u postgres createdb esqutest 522 | $ sudo -u postgres psql 523 | postgres=# \password esqutest 524 | ``` 525 | 526 | And on osx 527 | 528 | ``` 529 | $ createuser esqutest 530 | $ createdb esqutest 531 | $ psql postgres 532 | postgres=# \password esqutest 533 | ``` 534 | 535 | #### MySQL 536 | 537 | To test MySQL, you'll need to have a MySQL server installation. 538 | Then, you'll need to create a database `esqutest` and a `'travis'@'localhost'` 539 | user which can access it: 540 | 541 | ``` 542 | mysql> CREATE DATABASE esqutest; 543 | mysql> CREATE USER 'travis'@'localhost'; 544 | mysql> ALTER USER 'travis'@'localhost' IDENTIFIED BY 'esqutest'; 545 | mysql> GRANT ALL ON esqutest.* TO 'travis'@'localhost'; 546 | ``` 547 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | -- Generated by stackage-to-hackage 2 | 3 | packages: 4 | ./ 5 | , examples/ 6 | -------------------------------------------------------------------------------- /docs/blog_post_2012_08_06: -------------------------------------------------------------------------------- 1 | Announcing esqueleto, a type-safe ESDL for SQL queries 2 | 3 | I'm very pleased to announce a preview release of esqueleto, a bare bones, type-safe EDSL for SQL queries. 4 | 5 | 6 | 7 | On the first part of this blog post I'll talk about persistent and HaskellDB. You may jump right into where I talk about esqueleto if you want, though. 8 | 9 |

Background

10 | 11 | Yesod is very modular, and each of its components may be used separately. You may also take libraries from other web frameworks. However, it's more convenient to use Yesod with its standard set of libraries. 12 | 13 | One of those libraries is persistent. It fills the role of communicating with the database: serialization and deserialization of data types, insertions, updates, queries, schema migration, and so on. It currently has both SQL and NoSQL backends, such as persistent-mysql, persistent-postgresql, persistent-sqlite and persistent-mongoDB. 14 | 15 |

Persistent's weakness

16 | 17 | Even though persistent's use of Template Haskell has been criticized by some, it's almost consensual that its largest drawback lies on its query API. For example, if you want to see all of John's posts, and you know that John's key on the database is [cci_haskell]johnId[/cci_haskell], then you may write: 18 | 19 | [cc_haskell] 20 | posts <- selectList [BlogPostAuthorId ==. johnId] [] 21 | [/cc_haskell] 22 | 23 | Even though the meaning of those lists is somewhat cryptic, it's not a bad line of code. However, what if you didn't know John's key, just its e-mail (assuming that there is an uniqueness constraint on e-mails)? Unfortunately, with persistent you'll need either two queries: 24 | 25 | [cc_haskell] 26 | Entity johnId john <- getBy (UniqueEmail john'sEmail) 27 | posts <- selectList [BlogPostAuthorId ==. johnId] [] 28 | [/cc_haskell] 29 | 30 | Or you could do it in one query using the ad hoc Database.Persist.Query.Join.Sql module: 31 | 32 | [cc_haskell] 33 | runJoin $ SelectOneMany 34 | { somFilterOne = [ PersonEmail ==. john'sEmail ] 35 | , somOrderOne = [] 36 | , somFilterMany = [] 37 | , somOrderMany = [] 38 | , somFilterKeys = (BlogPostAuthorId <-.) 39 | , somGetKey = blogPostAuthorId 40 | , somIncludeNoMatch = False 41 | } 42 | [/cc_haskell] 43 | 44 | Compare to the equivalent SQL query: 45 | 46 | [cc_sql] 47 | SELECT BlogPost.* 48 | FROM Person INNER JOIN BlogPost 49 | ON Person.id = BlogPost.authorId 50 | WHERE Person.email = ? 51 | [/cc_sql] 52 | 53 | But it gets even worse: you have support only for simple queries (using [cci_haskell]selectList[/cci_haskell]) and for simple one-to-many joins (using the ad hoc [cci_haskell]SelectOneMany[/cci_haskell]). If you need anything else then you're on your own. For instance, there's no support for doing many-to-many joins. 54 | 55 | For these reasons I've created the [cci_haskell]rawSql[/cci_haskell] function 8 month ago. It was nice to be able to write raw SQL queries and still be able to use persistent to deserialize the results, but we still get all the drawbacks of using raw SQL queries: 56 | 57 | 62 | 63 | 64 |

HaskellDB: a solution?

65 | 66 | HaskellDB is a type-safe EDSL that allows you to write SQL queries using relational algebra. It's as old as Parsec, having been introduced in 1999! 67 | 68 | Recently some people have been showing interest in using it with Yesod. Last month Mats Rauhala wrote the following summary about his opinion at the time on Yesod's mailing list: 69 | 70 |
71 | 1. Direct sql 72 | - No, or very little type safety 73 | - No, or very little compile time checks 74 | - Raw queries are ugly 75 | + Full power of SQL 76 | 77 | 2. ORM 78 | + Type safety (ala persistent) 79 | - No control over queries 80 | - No proper join support(?, persistent) 81 | + Abstract 82 | +- High-level 83 | 84 | 3. Relational algebra 85 | + Type safety (ala HaskellDB) 86 | + Great control over queries 87 | + Good control over abstractions 88 | + It's algebra, therefore fits Haskell (tongue in cheek) 89 | - Forgotten (HaskellDB) 90 |
91 | 92 | Although it's rather painful to setup HaskellDB's tables, I'll won't count that as a big drawback since some Template Haskell could certainly solve this shortcoming. Its lack of migration capabilities is not a huge problem, too, since you may use persistent just for the migrations (although I'm not sure if anyone has ever put something like this into production). 93 | 94 | HaskellDB's biggest drawback is being a relational algebra library. "What?", I hear you say. I like relational algebra as much as the next functional programmer, but it comes with two drawbacks, one of them being a major one: 95 | 96 |
    97 |
  1. Being something different than what we're used to means that it takes some time to learn how to use it and get productive. This is a minor drawback, but nevertheless it is a drawback.
    2. 98 |
  2. However, the biggest drawback is that it's very hard to map into efficient SQL. Back in 2008, Geoff Wilson wrote a blog post about HaskellDB's performance. A simple [cci_sql]INNER JOIN[/cci_sql] was taking between 40x and 160x more time to execute when using HaskellDB and comparing against a handwritten SQL query.
    3. 99 |
100 | 101 | While I'm sure that some work has been done on HaskellDB's optimizer since that blog post, Chris Done found out last November that it still isn't very good: 102 | 103 |
104 | Don’t expect good performance from HaskellDB if you’re using MySQL. 105 |
106 | 107 | Even if I started using PostgreSQL, I wouldn't want to rely on its optimizer when doing, say, a join between five tables on HaskellDB. (If you didn't already know, I'm persistent-mysql's author.) 108 | 109 | Please don't get me wrong, HaskellDB is amazing! But it won't work for my production systems. 110 | 111 | 112 | 113 |

Esqueleto rises

114 | 115 | Last Sunday my co-worker was bitten by a nasty bug due to a raw SQL query. He changed an entity's field so that it would be optional. After fixing all type errors, he found out that some parts of the application were not working, but no error messages were to be found anywhere. Turns out an implicit join in a raw SQL query started dropping rows from the result since the value was [cci_sql]NULL[/cci_sql]. After we found the bug, he proceeded to show me Squeryl. My initial thought after seeing the examples was: how could I write this in Haskell? 116 | 117 | Thus esqueleto was born. It's a bare bones, type-safe EDSL for SQL-queries. Like HaskellDB, it has composable, type-checked queries. Unlike HaskellDB, it's not relational algebra, it's SQL. I was inspired by Squeryl but created esqueleto from scratch. 118 | 119 | It sits on top of persistent and requires no further setup: if you're already using persistent then you already have everything it takes to use esqueleto. Although I haven't tested, yet, it should work on any SQL backend. 120 | 121 | Let's remember the first query we did on the beginning of this post: 122 | 123 | [cc_haskell] 124 | selectList [BlogPostAuthorId ==. johnId] [] 125 | [/cc_haskell] 126 | 127 | You could write the same query in plain SQL as: 128 | 129 | [cc_sql] 130 | SELECT BlogPost.* 131 | FROM BlogPost 132 | WHERE BlogPost.authorId = ? 133 | [/cc_sql] 134 | 135 | With esqueleto, you may say: 136 | 137 | [cc_haskell] 138 | select $ 139 | from $ \b -> do 140 | where_ (b ^. BlogPostAuthorId ==. val johnId) 141 | return b 142 | [/cc_haskell] 143 | 144 | Arguably more verbose than persistent's [cci_haskell]selectList[/cci_haskell], but extremely close to the handwriten SQL: just take the [cci_haskell]return[/cci_haskell] and move it to the top! 145 | 146 | Better still, the SQL that esqueleto generates is: 147 | 148 | [cc_sql] 149 | SELECT BlogPost.id, BlogPost.title 150 | FROM BlogPost 151 | WHERE BlogPost.authorId = ? 152 | [/cc_sql] 153 | 154 | I'm not kidding! The only difference from the handwritten query is the explicit list of columns, which is needed for correctness (the order your database returns the columns may not be what persistent expects). 155 | 156 | Remember the one-to-many join? Here's the esqueleto version: 157 | 158 | [cc_haskell] 159 | select $ 160 | from $ \(p `InnerJoin` b) -> do 161 | on (p ^. PersonId ==. b ^. BlogPostAuthorId) 162 | where_ (p ^. PersonEmail ==. val john'sEmail) 163 | return b 164 | [/cc_haskell] 165 | 166 | The SQL esqueleto generates for this query is: 167 | 168 | [cc_sql] 169 | SELECT BlogPost.id, BlogPost.title 170 | FROM Person INNER JOIN BlogPost 171 | ON Person.id = BlogPost.authorId 172 | WHERE Person.email = ? 173 | [/cc_sql] 174 | 175 | Let's take Geoff Wilson's post as an example again. Since this is a preview release of esqueleto, it does not have support for [cci_sql]IN[/cci_sql] yet, so I'll rewrite his code slightly. The HaskellDB code he wrote was: 176 | 177 | [cc_haskell] 178 | query db $ do 179 | s <- table S.stock 180 | e <- table E.end_of_day 181 | restrict (s!S.stock_id .==. e!E.stock_id .&&. 182 | s!S.ticker .==. constant ticker .&&. 183 | e!E.trade_date .==. constant stockDate) 184 | r <- project (closing_price << e!E.closing_price # 185 | trade_date << e!E.trade_date) 186 | return r 187 | [/cc_haskell] 188 | 189 | The SQL that HaskellDB generated on 2008 was (adapted): 190 | 191 | [cc_sql] 192 | SELECT closing_price2 as closing_price, 193 | trade_date2 as trade_date 194 | FROM (SELECT stock_id as stock_id2, 195 | trade_date as trade_date2, 196 | closing_price as closing_price2 197 | FROM end_of_day as T1) as T1, 198 | (SELECT stock_id as stock_id1, 199 | ticker as ticker1 200 | FROM stock as T1) as T2 201 | WHERE stock_id1 = stock_id2 202 | AND ticker1 = 'FXJ' 203 | AND trade_date2 = '2008-02-14 00:00:00'; 204 | [/cc_sql] 205 | 206 | His handwritten SQL was (adapted as well): 207 | 208 | [cc_sql] 209 | SELECT e.closing_price as closing_price, 210 | e.trade_date as trade_date 211 | FROM 212 | stock s, end_of_day e 213 | WHERE 214 | s.stock_id = e.stock_id 215 | AND s.ticker = 'FXJ' 216 | AND e.trade_date = '2008-02-14 00:00:00'; 217 | [/cc_sql] 218 | 219 | The same query could be written using persistent and esqueleto as: 220 | 221 | [cc_haskell] 222 | select $ 223 | from $ \(s, e) -> do 224 | where_ (s ^. StockId ==. e ^. EndOfDayStockId &&. 225 | s ^. StockTicker ==. val ticker &&. 226 | s ^. EndOfDayTradeDate ==. val stockDate) 227 | return (e ^. EndOfDayClosingPrice, e ^. EndOfDayTradeDate) 228 | [/cc_haskell] 229 | 230 | The generated SQL would be: 231 | 232 | [cc_sql] 233 | SELECT end_of_day.closing_price, end_of_day.trade_date 234 | FROM stock, end_of_day 235 | WHERE stock.stock_id = end_of_day.stock_id AND (stock.ticker = ? AND end_of_day.trade_date = ?) 236 | [/cc_sql] 237 | 238 | 239 |

Conclusion

240 | 241 | The full power of raw SQL. Type-checked queries, no type signatures required. Complete control over the resulting SQL. The robustness and performance of persistent. And with only 800 source lines of code (+ 400 SLOC for the test suite). What's not to like about esqueleto? =D 242 | 243 | This is just a preview release. I'm eager to hear what you have to say about it. Send pull requests, open issues, comment about it on reddit or send e-mails to Yesod's mailing list. Or, even better, give it a spin a let me know how it went! Its Haddock documentation should get you started. 244 | 245 | Thanks for reading this rather long blog post! =) 246 | -------------------------------------------------------------------------------- /esqueleto.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | name: esqueleto 4 | version: 3.6.0.0 5 | synopsis: Type-safe EDSL for SQL queries on persistent backends. 6 | description: @esqueleto@ is a bare bones, type-safe EDSL for SQL queries that works with unmodified @persistent@ SQL backends. Its language closely resembles SQL, so you don't have to learn new concepts, just new syntax, and it's fairly easy to predict the generated SQL and optimize it for your backend. Most kinds of errors committed when writing SQL are caught as compile-time errors---although it is possible to write type-checked @esqueleto@ queries that fail at runtime. 7 | . 8 | @persistent@ is a library for type-safe data serialization. It has many kinds of backends, such as SQL backends (@persistent-mysql@, @persistent-postgresql@, @persistent-sqlite@) and NoSQL backends (@persistent-mongoDB@). While @persistent@ is a nice library for storing and retrieving records, including with filters, it does not try to support some of the features that are specific to SQL backends. In particular, @esqueleto@ is the recommended library for type-safe @JOIN@s on @persistent@ SQL backends. (The alternative is using raw SQL, but that's error prone and does not offer any composability.) 9 | . 10 | Currently, @SELECT@s, @UPDATE@s, @INSERT@s and @DELETE@s are supported. Not all SQL features are available, but most of them can be easily added (especially functions), so please open an issue or send a pull request if you need anything that is not covered by @esqueleto@ on . 11 | . 12 | The name of this library means \"skeleton\" in Portuguese and contains all three SQL letters in the correct order =). It was inspired by Scala's Squeryl but created from scratch. 13 | category: Database 14 | homepage: https://github.com/bitemyapp/esqueleto 15 | author: Felipe Lessa 16 | maintainer: cma@bitemyapp.com 17 | copyright: (c) 2012-2016 Felipe Almeida Lessa 18 | license: BSD3 19 | license-file: LICENSE 20 | build-type: Simple 21 | extra-source-files: 22 | README.md 23 | changelog.md 24 | 25 | source-repository head 26 | type: git 27 | location: git://github.com/bitemyapp/esqueleto.git 28 | 29 | library 30 | exposed-modules: 31 | Database.Esqueleto 32 | Database.Esqueleto.Legacy 33 | Database.Esqueleto.Experimental 34 | Database.Esqueleto.Internal.Internal 35 | Database.Esqueleto.Internal.ExprParser 36 | Database.Esqueleto.MySQL 37 | Database.Esqueleto.PostgreSQL 38 | Database.Esqueleto.PostgreSQL.JSON 39 | Database.Esqueleto.Record 40 | Database.Esqueleto.SQLite 41 | Database.Esqueleto.Experimental.From 42 | Database.Esqueleto.Experimental.From.CommonTableExpression 43 | Database.Esqueleto.Experimental.From.Join 44 | Database.Esqueleto.Experimental.From.SqlSetOperation 45 | Database.Esqueleto.Experimental.ToAlias 46 | Database.Esqueleto.Experimental.ToAliasReference 47 | Database.Esqueleto.Experimental.ToMaybe 48 | other-modules: 49 | Database.Esqueleto.PostgreSQL.JSON.Instances 50 | Database.Esqueleto.Internal.PersistentImport 51 | Paths_esqueleto 52 | hs-source-dirs: 53 | src/ 54 | build-depends: 55 | base >=4.12 && <5.0 56 | , aeson >=1.0 57 | , attoparsec >= 0.13 && < 0.15 58 | , blaze-html 59 | , bytestring 60 | , conduit >=1.3 61 | , containers 62 | , monad-logger 63 | , persistent >=2.13 && <3 64 | , resourcet >=1.2 65 | , tagged >=0.2 66 | , template-haskell 67 | , text >=0.11 && <2.2 68 | , time >=1.5.0.1 && <=1.13 69 | , transformers >=0.2 70 | , unliftio 71 | , unordered-containers >=0.2 72 | ghc-options: 73 | -Wall 74 | -Wno-redundant-constraints 75 | -Wincomplete-uni-patterns 76 | -Wincomplete-record-updates 77 | -Wpartial-fields 78 | -Wmissing-home-modules 79 | -Widentities 80 | -Wcpp-undef 81 | -Wcpp-undef 82 | default-language: Haskell2010 83 | 84 | test-suite specs 85 | type: exitcode-stdio-1.0 86 | main-is: Spec.hs 87 | other-modules: 88 | Common.Test 89 | Common.Test.CTE 90 | Common.Test.Models 91 | Common.Test.Import 92 | Common.Test.Select 93 | Common.Record 94 | PostgreSQL.MigrateJSON 95 | SQLite.Test 96 | PostgreSQL.Test 97 | MySQL.Test 98 | default-extensions: 99 | RankNTypes 100 | hs-source-dirs: 101 | test 102 | ghc-options: -Wall -threaded 103 | build-depends: 104 | base >=4.8 && <5.0 105 | , aeson 106 | , attoparsec 107 | , blaze-html 108 | , bytestring 109 | , conduit 110 | , containers 111 | , esqueleto 112 | , exceptions 113 | , hspec 114 | , hspec-core 115 | , monad-logger 116 | , mtl 117 | , mysql 118 | , mysql-simple 119 | , persistent 120 | , persistent-mysql 121 | , persistent-postgresql 122 | , persistent-sqlite 123 | , postgresql-simple 124 | , QuickCheck 125 | , resourcet 126 | , tagged 127 | , template-haskell 128 | , text 129 | , time 130 | , transformers 131 | , unliftio 132 | , unordered-containers 133 | default-language: Haskell2010 134 | -------------------------------------------------------------------------------- /esqueleto.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/bitemyapp/esqueleto/7821cbed8952aac76f5bbb9a9ab20815c1831baf/esqueleto.png -------------------------------------------------------------------------------- /examples/.gitignore: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/bitemyapp/esqueleto/7821cbed8952aac76f5bbb9a9ab20815c1831baf/examples/.gitignore -------------------------------------------------------------------------------- /examples/Blog.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE StandaloneDeriving #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | 8 | module Blog 9 | ( runBlogT 10 | ) where 11 | 12 | import Control.Monad.Base (MonadBase (..)) 13 | import Control.Monad.IO.Unlift (MonadUnliftIO(..), wrappedWithRunInIO) 14 | import Control.Monad.Logger (MonadLoggerIO, MonadLogger, NoLoggingT (..)) 15 | import Control.Monad.Reader 16 | import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..), 17 | MonadTransControl (..), 18 | defaultLiftBaseWith, 19 | defaultRestoreM) 20 | import Database.Persist.Postgresql (ConnectionString) 21 | 22 | newtype BlogT m a = BlogT { unBlogT :: NoLoggingT (ReaderT ConnectionString m) a } 23 | deriving ( Functor 24 | , Applicative 25 | , Monad 26 | , MonadLogger 27 | , MonadReader ConnectionString 28 | , MonadIO 29 | , MonadLoggerIO 30 | ) 31 | 32 | instance MonadUnliftIO m => MonadUnliftIO (BlogT m) where 33 | withRunInIO = wrappedWithRunInIO BlogT unBlogT 34 | 35 | instance MonadTrans BlogT where 36 | lift = BlogT . lift . lift 37 | 38 | 39 | deriving instance (MonadBase b m) => MonadBase b (BlogT m) 40 | 41 | 42 | instance MonadBaseControl b m => MonadBaseControl b (BlogT m) where 43 | type StM (BlogT m) a = ComposeSt BlogT m a 44 | liftBaseWith = defaultLiftBaseWith 45 | restoreM = defaultRestoreM 46 | 47 | 48 | instance MonadTransControl BlogT where 49 | type StT BlogT a = StT NoLoggingT (StT (ReaderT ConnectionString) a) 50 | liftWith f = BlogT $ liftWith $ \run -> 51 | liftWith $ \run' -> 52 | f (run' . run . unBlogT) 53 | restoreT = BlogT . restoreT . restoreT 54 | 55 | 56 | runBlogT :: ConnectionString -> BlogT m a -> m a 57 | runBlogT backend (BlogT m) = 58 | runReaderT (runNoLoggingT m) backend 59 | -------------------------------------------------------------------------------- /examples/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012, Felipe Lessa 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Felipe Lessa nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /examples/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DerivingStrategies #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE OverloadedStrings #-} 9 | {-# LANGUAGE QuasiQuotes #-} 10 | {-# LANGUAGE ScopedTypeVariables #-} 11 | {-# LANGUAGE StandaloneDeriving #-} 12 | {-# LANGUAGE TemplateHaskell #-} 13 | {-# LANGUAGE TypeApplications #-} 14 | {-# LANGUAGE TypeFamilies #-} 15 | {-# LANGUAGE UndecidableInstances #-} 16 | {-# OPTIONS_GHC -fno-warn-unused-top-binds #-} 17 | 18 | module Main 19 | ( main 20 | ) where 21 | 22 | import Blog 23 | import Control.Monad (void) 24 | import Control.Monad.IO.Class (MonadIO, liftIO) 25 | import Control.Monad.IO.Unlift (MonadUnliftIO) 26 | import Control.Monad.Logger (MonadLogger, MonadLoggerIO) 27 | import Control.Monad.Reader (MonadReader(..), runReaderT) 28 | import Control.Monad.Trans.Control (MonadBaseControl) 29 | import Database.Esqueleto.Experimental 30 | import Database.Persist.Postgresql (ConnectionString, withPostgresqlConn) 31 | import qualified Database.Persist.Sql as Persistent 32 | import Database.Persist.TH 33 | ( mkMigrate 34 | , mkPersist 35 | , persistLowerCase 36 | , share 37 | , sqlSettings 38 | ) 39 | 40 | share [ mkPersist sqlSettings 41 | , mkMigrate "migrateAll"] [persistLowerCase| 42 | Person 43 | name String 44 | age Int Maybe 45 | deriving Eq Show 46 | BlogPost 47 | title String 48 | authorId PersonId OnDeleteCascade 49 | deriving Eq Show 50 | Follow 51 | follower PersonId OnDeleteCascade 52 | followed PersonId OnDeleteCascade 53 | deriving Eq Show 54 | |] 55 | 56 | putPersons :: (MonadIO m, MonadLogger m) 57 | => SqlPersistT m () 58 | putPersons = do 59 | -- | Select all values from the `person` table 60 | people <- select $ from $ table @Person 61 | 62 | -- | entityVal extracts the Person value, which we then extract 63 | -- | the person name from the record and print it 64 | liftIO $ mapM_ (putStrLn . ("Name: " ++) . personName . entityVal) people 65 | 66 | 67 | getJohns :: (MonadIO m, MonadLogger m) 68 | => SqlReadT m [Entity Person] 69 | getJohns = 70 | -- | Select all persons where their name is equal to "John" 71 | select $ do 72 | people <- from $ table @Person 73 | where_ (people ^. PersonName ==. val "John") 74 | return people 75 | 76 | 77 | getAdults :: (MonadIO m, MonadLogger m) 78 | => SqlReadT m [Entity Person] 79 | getAdults = 80 | -- | Select any Person where their age is >= 18 and NOT NULL 81 | select $ do 82 | people <- from $ table @Person 83 | where_ (people ^. PersonAge >=. just (val 18)) 84 | return people 85 | 86 | 87 | getBlogPostsByAuthors :: (MonadIO m, MonadLogger m) 88 | => SqlReadT m [(Entity BlogPost, Entity Person)] 89 | getBlogPostsByAuthors = 90 | -- | Select all persons and their blogposts, ordering by title 91 | select $ do 92 | (people :& blogPosts) <- 93 | from $ table @Person 94 | `innerJoin` table @BlogPost 95 | `on` (\(people :& blogPosts) -> 96 | people ^. PersonId ==. blogPosts ^. BlogPostAuthorId) 97 | orderBy [asc (blogPosts ^. BlogPostTitle)] 98 | pure (blogPosts, people) 99 | 100 | 101 | getAuthorMaybePosts :: (MonadIO m, MonadLogger m) 102 | => SqlReadT m [(Entity Person, Maybe (Entity BlogPost))] 103 | getAuthorMaybePosts = 104 | -- | Select all persons doing a left outer join on blogposts 105 | -- | Since a person may not have any blogposts the BlogPost Entity is wrapped 106 | -- | in a Maybe 107 | select $ do 108 | p :& mb <- from $ 109 | table @Person 110 | `leftJoin` 111 | table @BlogPost 112 | `on` (do 113 | \(p :& mb) -> just (p ^. PersonId) ==. mb ?. BlogPostAuthorId) 114 | orderBy [asc (p ^. PersonName), asc (mb ?. BlogPostTitle)] 115 | return (p, mb) 116 | 117 | 118 | followers :: (MonadIO m, MonadLogger m) 119 | => SqlReadT m [(Entity Person, Entity Follow, Entity Person)] 120 | followers = 121 | -- | Select mutual follow relationships 122 | -- | Note carefully that the order of the ON clauses is reversed! 123 | -- | You're required to write your ons in reverse order because that helps composability 124 | -- | (see the documentation of on for more details). 125 | select $ do 126 | p1 :& f :& p2 <- from $ 127 | table @Person 128 | `innerJoin` 129 | table @Follow 130 | `on` (\(p1 :& f) -> p1 ^. PersonId ==. f ^. FollowFollowed) 131 | `innerJoin` 132 | table @Person 133 | `on` (\(_ :& f :& p2) -> f ^. FollowFollower ==. p2 ^. PersonId) 134 | pure (p1, f, p2) 135 | 136 | -- from $ \(p1 `InnerJoin` f `InnerJoin` p2) -> do 137 | -- on (p2 ^. PersonId ==. f ^. FollowFollowed) 138 | -- on (p1 ^. PersonId ==. f ^. FollowFollower) 139 | -- return (p1, f, p2) 140 | 141 | 142 | updateJoao :: (MonadIO m, MonadLogger m) 143 | => SqlWriteT m () 144 | updateJoao = 145 | -- Update the name of any Joao in our person table to João 146 | update $ \p -> do 147 | set p [ PersonName =. val "João" ] 148 | where_ (p ^. PersonName ==. val "Joao") 149 | 150 | 151 | deleteYoungsters :: (MonadIO m, MonadLogger m) 152 | => SqlPersistT m () 153 | deleteYoungsters = do 154 | -- | Delete any persons under the age of 14 155 | delete $ do 156 | p <- from $ table @Person 157 | where_ (p ^. PersonAge <. just (val 14)) 158 | 159 | 160 | insertBlogPosts :: (MonadIO m, MonadLogger m) 161 | => SqlWriteT m () 162 | insertBlogPosts = 163 | -- | Insert a new blogpost for every person 164 | insertSelect $ do 165 | p <- from $ table @Person 166 | return $ BlogPost <# (val "Group Blog Post") <&> (p ^. PersonId) 167 | 168 | 169 | runDB :: (MonadReader ConnectionString m, 170 | MonadIO m, 171 | MonadBaseControl IO m, 172 | MonadUnliftIO m, 173 | MonadLoggerIO m, 174 | MonadLogger m) 175 | => SqlPersistT m a -> m a 176 | runDB query = do 177 | -- | Helper for running a query 178 | conn <- ask 179 | withPostgresqlConn conn $ \backend -> runReaderT query backend 180 | 181 | 182 | setupDb :: (MonadIO m, MonadLogger m) 183 | => SqlPersistT m () 184 | setupDb = do 185 | -- | Run migrations and create the test database entries 186 | runMigration migrateAll 187 | createDb 188 | where 189 | createDb :: (MonadIO m, MonadLogger m) 190 | => SqlPersistT m () 191 | createDb = do 192 | john <- insert $ Person "John" (Just 24) 193 | sean <- insert $ Person "Seán" (Just 70) 194 | joao <- insert $ Person "Joao" (Just 13) 195 | void $ insertMany [ BlogPost "How to play a bodhrán" sean 196 | , BlogPost "Haskell for the working class hero" john 197 | ] 198 | void $ insert $ Follow john sean 199 | void $ insert $ Follow sean john 200 | void $ insert $ Follow joao sean 201 | 202 | 203 | cleanDb :: (MonadIO m, MonadLogger m) 204 | => SqlPersistT m () 205 | cleanDb = do 206 | -- | Drop the tables so we can re-run the script again if needed 207 | dropTable "follow" 208 | dropTable "blog_post" 209 | dropTable "person" 210 | where 211 | dropTable tableName = rawExecute ("DROP TABLE " <> tableName) [] 212 | 213 | main :: IO () 214 | main = do 215 | -- Connection string for the postrgesql database 216 | runBlogT connection . runDB $ do 217 | setupDb 218 | putPersons 219 | 220 | johns <- getJohns 221 | mapM_ say johns 222 | 223 | adults <- getAdults 224 | mapM_ say adults 225 | 226 | authorBlogPosts <- getBlogPostsByAuthors 227 | mapM_ say authorBlogPosts 228 | 229 | authoMaybePosts <- getAuthorMaybePosts 230 | mapM_ say authoMaybePosts 231 | 232 | mutualFollowers <- followers 233 | mapM_ say mutualFollowers 234 | 235 | updateJoao 236 | deleteYoungsters 237 | insertBlogPosts 238 | cleanDb 239 | where 240 | say :: (MonadIO m, Show a) => a -> m () 241 | say = liftIO . print 242 | connection = "host=localhost port=5432 user=postgres dbname=esqueleto_blog_example password=***" 243 | -------------------------------------------------------------------------------- /examples/README.md: -------------------------------------------------------------------------------- 1 | # Esqueleto Examples 2 | 3 | These examples can be build via `stack build`. 4 | -------------------------------------------------------------------------------- /examples/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /examples/esqueleto-examples.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.35.0. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: ec7b9640e401d9b5f6939c8ac50f7d322b4b00354179825fd41ef4ea92401aaa 8 | 9 | name: esqueleto-examples 10 | version: 0.0.0.0 11 | category: Database 12 | homepage: https://github.com/bitemyapp/esqueleto#readme 13 | bug-reports: https://github.com/bitemyapp/esqueleto/issues 14 | author: Fintan Halpenny 15 | maintainer: cma@bitemyapp.com 16 | copyright: 2019, Chris Allen 17 | license: BSD3 18 | license-file: LICENSE 19 | build-type: Simple 20 | extra-source-files: 21 | README.md 22 | 23 | source-repository head 24 | type: git 25 | location: https://github.com/bitemyapp/esqueleto 26 | 27 | flag werror 28 | description: Treat warnings as errors 29 | manual: True 30 | default: False 31 | 32 | executable blog-example 33 | main-is: Main.hs 34 | other-modules: 35 | Blog 36 | ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N 37 | build-depends: 38 | base 39 | , esqueleto 40 | , monad-control 41 | , monad-logger 42 | , mtl 43 | , persistent >=2.12 44 | , persistent-postgresql 45 | , transformers-base 46 | , unliftio-core 47 | default-language: Haskell2010 48 | if flag(werror) 49 | ghc-options: -Werror 50 | -------------------------------------------------------------------------------- /examples/package.yaml: -------------------------------------------------------------------------------- 1 | name: esqueleto-examples 2 | version: '0.0.0.0' 3 | category: Database 4 | author: Fintan Halpenny 5 | maintainer: cma@bitemyapp.com 6 | copyright: 2019, Chris Allen 7 | license: BSD3 8 | github: bitemyapp/esqueleto 9 | 10 | extra-source-files: 11 | - README.md 12 | 13 | dependencies: 14 | - base 15 | - esqueleto 16 | - persistent >= 2.12 17 | - persistent-postgresql 18 | - mtl 19 | - monad-logger 20 | - monad-control 21 | - transformers-base 22 | - unliftio-core 23 | 24 | ghc-options: 25 | - '-Wall' 26 | - '-threaded' 27 | - '-rtsopts' 28 | - '-with-rtsopts=-N' 29 | 30 | when: 31 | - condition: flag(werror) 32 | ghc-options: '-Werror' 33 | 34 | executables: 35 | blog-example: 36 | other-modules: 37 | - Blog 38 | main: Main.hs 39 | 40 | flags: 41 | werror: 42 | description: "Treat warnings as errors" 43 | manual: true 44 | default: false 45 | -------------------------------------------------------------------------------- /screwdriver.yaml: -------------------------------------------------------------------------------- 1 | workflow: 2 | - esqueleto 3 | 4 | shared: 5 | image: fpco/stack-build 6 | 7 | jobs: 8 | main: 9 | steps: 10 | - stack-setup: stack setup 11 | 12 | esqueleto: 13 | steps: 14 | - build: stack build 15 | - test: stack test 16 | -------------------------------------------------------------------------------- /src/Database/Esqueleto.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | 6 | -- | The @esqueleto@ EDSL (embedded domain specific language). 7 | -- This module replaces @Database.Persist@, so instead of 8 | -- importing that module you should just import this one: 9 | -- 10 | -- @ 11 | -- -- For a module using just esqueleto. 12 | -- import Database.Esqueleto 13 | -- @ 14 | -- 15 | -- If you need to use @persistent@'s default support for queries 16 | -- as well, either import it qualified: 17 | -- 18 | -- @ 19 | -- -- For a module that mostly uses esqueleto. 20 | -- import Database.Esqueleto 21 | -- import qualified Database.Persist as P 22 | -- @ 23 | -- 24 | -- or import @esqueleto@ itself qualified: 25 | -- 26 | -- @ 27 | -- -- For a module that uses esqueleto just on some queries. 28 | -- import Database.Persist 29 | -- import qualified Database.Esqueleto as E 30 | -- @ 31 | -- 32 | -- Other than identifier name clashes, @esqueleto@ does not 33 | -- conflict with @persistent@ in any way. 34 | -- 35 | -- Note that the facilities for @JOIN@ have been significantly improved in the 36 | -- "Database.Esqueleto.Experimental" module. The definition of 'from' and 'on' 37 | -- in this module will be replaced with those at the 4.0.0.0 version, so you are 38 | -- encouraged to migrate to the new method. 39 | -- 40 | -- This module has an attached WARNING message indicating that the Experimental 41 | -- syntax will become the default. If you want to continue using the old syntax, 42 | -- please refer to "Database.Esqueleto.Legacy" as a drop-in replacement. 43 | module Database.Esqueleto {-# WARNING "This module will switch over to the Experimental syntax in an upcoming major version release. Please migrate to the Database.Esqueleto.Legacy module to continue using the old syntax, or translate to the new and improved syntax in Database.Esqueleto.Experimental." #-} 44 | ( -- * Setup 45 | -- $setup 46 | 47 | -- * Introduction 48 | -- $introduction 49 | 50 | -- * Getting started 51 | -- $gettingstarted 52 | 53 | -- * @esqueleto@'s Language 54 | where_, on, groupBy, orderBy, asc, desc, limit, offset 55 | , distinct, distinctOn, don, distinctOnOrderBy, having, locking 56 | , (^.), (?.) 57 | , val, isNothing, just, just', nothing, joinV, joinV', withNonNull 58 | , countRows, count, countDistinct 59 | , not_, (==.), (>=.), (>.), (<=.), (<.), (!=.), (&&.), (||.) 60 | , between, (+.), (-.), (/.), (*.) 61 | , round_, ceiling_, floor_ 62 | , min_, max_, sum_, avg_, castNum, castNumM 63 | , coalesce, coalesceDefault 64 | , lower_, upper_, trim_, ltrim_, rtrim_, length_, left_, right_ 65 | , like, ilike, (%), concat_, (++.), castString 66 | , subList_select, valList, justList 67 | , in_, notIn, exists, notExists 68 | , set, (=.), (+=.), (-=.), (*=.), (/=.) 69 | , case_, toBaseId, fromBaseId, toBaseIdMaybe, fromBaseIdMaybe 70 | , subSelect 71 | , subSelectMaybe 72 | , subSelectCount 73 | , subSelectForeign 74 | , subSelectList 75 | , subSelectUnsafe 76 | , ToBaseId(..) 77 | , when_ 78 | , then_ 79 | , else_ 80 | , from 81 | , Value(..) 82 | , ValueList(..) 83 | , OrderBy 84 | , DistinctOn 85 | , LockingKind(..) 86 | , forUpdate 87 | , forUpdateSkipLocked 88 | , LockableEntity(..) 89 | , SqlString 90 | -- ** Joins 91 | , InnerJoin(..) 92 | , CrossJoin(..) 93 | , LeftOuterJoin(..) 94 | , RightOuterJoin(..) 95 | , FullOuterJoin(..) 96 | , JoinKind(..) 97 | , OnClauseWithoutMatchingJoinException(..) 98 | -- * SQL backend 99 | , SqlQuery 100 | , SqlExpr 101 | , SqlEntity 102 | , select 103 | , selectOne 104 | , selectSource 105 | , delete 106 | , deleteCount 107 | , update 108 | , updateCount 109 | , insertSelect 110 | , insertSelectCount 111 | , (<#) 112 | , (<&>) 113 | -- ** Rendering Queries 114 | , renderQueryToText 115 | , renderQuerySelect 116 | , renderQueryUpdate 117 | , renderQueryDelete 118 | , renderQueryInsertInto 119 | -- * Internal.Language 120 | , From 121 | -- * RDBMS-specific modules 122 | -- $rdbmsSpecificModules 123 | 124 | -- * Helpers 125 | , valkey 126 | , valJ 127 | , associateJoin 128 | 129 | -- * Re-exports 130 | -- $reexports 131 | , deleteKey 132 | , module Database.Esqueleto.Internal.PersistentImport 133 | ) where 134 | 135 | import Database.Esqueleto.Legacy 136 | import Database.Esqueleto.Internal.PersistentImport 137 | 138 | 139 | -- $setup 140 | -- 141 | -- If you're already using @persistent@, then you're ready to use 142 | -- @esqueleto@, no further setup is needed. If you're just 143 | -- starting a new project and would like to use @esqueleto@, take 144 | -- a look at @persistent@'s book first 145 | -- () to learn how to 146 | -- define your schema. 147 | 148 | 149 | ---------------------------------------------------------------------- 150 | 151 | 152 | -- $introduction 153 | -- 154 | -- The main goals of @esqueleto@ are to: 155 | -- 156 | -- * Be easily translatable to SQL. When you take a look at a 157 | -- @esqueleto@ query, you should be able to know exactly how 158 | -- the SQL query will end up. (As opposed to being a 159 | -- relational algebra EDSL such as HaskellDB, which is 160 | -- non-trivial to translate into SQL.) 161 | -- 162 | -- * Support the most widely used SQL features. We'd like you to be 163 | -- able to use @esqueleto@ for all of your queries, no 164 | -- exceptions. Send a pull request or open an issue on our 165 | -- project page () if 166 | -- there's anything missing that you'd like to see. 167 | -- 168 | -- * Be as type-safe as possible. We strive to provide as many 169 | -- type checks as possible. If you get bitten by some invalid 170 | -- code that type-checks, please open an issue on our project 171 | -- page so we can take a look. 172 | -- 173 | -- However, it is /not/ a goal to be able to write portable SQL. 174 | -- We do not try to hide the differences between DBMSs from you, 175 | -- and @esqueleto@ code that works for one database may not work 176 | -- on another. This is a compromise we have to make in order to 177 | -- give you as much control over the raw SQL as possible without 178 | -- losing too much convenience. This also means that you may 179 | -- type-check a query that doesn't work on your DBMS. 180 | 181 | 182 | ---------------------------------------------------------------------- 183 | 184 | 185 | -- $gettingstarted 186 | -- 187 | -- We like clean, easy-to-read EDSLs. However, in order to 188 | -- achieve this goal we've used a lot of type hackery, leading to 189 | -- some hard-to-read type signatures. On this section, we'll try 190 | -- to build some intuition about the syntax. 191 | -- 192 | -- For the following examples, we'll use this example schema: 193 | -- 194 | -- @ 195 | -- share [mkPersist sqlSettings, mkMigrate \"migrateAll\"] [persist| 196 | -- Person 197 | -- name String 198 | -- age Int Maybe 199 | -- deriving Eq Show 200 | -- BlogPost 201 | -- title String 202 | -- authorId PersonId 203 | -- deriving Eq Show 204 | -- Follow 205 | -- follower PersonId 206 | -- followed PersonId 207 | -- deriving Eq Show 208 | -- |] 209 | -- @ 210 | -- 211 | -- Most of @esqueleto@ was created with @SELECT@ statements in 212 | -- mind, not only because they're the most common but also 213 | -- because they're the most complex kind of statement. The most 214 | -- simple kind of @SELECT@ would be: 215 | -- 216 | -- @ 217 | -- SELECT * 218 | -- FROM Person 219 | -- @ 220 | -- 221 | -- In @esqueleto@, we may write the same query above as: 222 | -- 223 | -- @ 224 | -- do people <- 'select' $ 225 | -- 'from' $ \\person -> do 226 | -- return person 227 | -- liftIO $ mapM_ (putStrLn . personName . entityVal) people 228 | -- @ 229 | -- 230 | -- The expression above has type @SqlPersist m ()@, while 231 | -- @people@ has type @[Entity Person]@. The query above will be 232 | -- translated into exactly the same query we wrote manually, but 233 | -- instead of @SELECT *@ it will list all entity fields (using 234 | -- @*@ is not robust). Note that @esqueleto@ knows that we want 235 | -- an @Entity Person@ just because of the @personName@ that we're 236 | -- printing later. 237 | -- 238 | -- However, most of the time we need to filter our queries using 239 | -- @WHERE@. For example: 240 | -- 241 | -- @ 242 | -- SELECT * 243 | -- FROM Person 244 | -- WHERE Person.name = \"John\" 245 | -- @ 246 | -- 247 | -- In @esqueleto@, we may write the same query above as: 248 | -- 249 | -- @ 250 | -- 'select' $ 251 | -- 'from' $ \\p -> do 252 | -- 'where_' (p '^.' PersonName '==.' 'val' \"John\") 253 | -- return p 254 | -- @ 255 | -- 256 | -- Although @esqueleto@'s code is a bit more noisy, it's has 257 | -- almost the same structure (save from the @return@). The 258 | -- @('^.')@ operator is used to project a field from an entity. 259 | -- The field name is the same one generated by @persistent@'s 260 | -- Template Haskell functions. We use 'val' to lift a constant 261 | -- Haskell value into the SQL query. 262 | -- 263 | -- Another example would be: 264 | -- 265 | -- @ 266 | -- SELECT * 267 | -- FROM Person 268 | -- WHERE Person.age >= 18 269 | -- @ 270 | -- 271 | -- In @esqueleto@, we may write the same query above as: 272 | -- 273 | -- @ 274 | -- 'select' $ 275 | -- 'from' $ \\p -> do 276 | -- 'where_' (p '^.' PersonAge '>=.' 'just' ('val' 18)) 277 | -- return p 278 | -- @ 279 | -- 280 | -- Since @age@ is an optional @Person@ field, we use 'just' to lift 281 | -- @'val' 18 :: SqlExpr (Value Int)@ into @just ('val' 18) :: 282 | -- SqlExpr (Value (Maybe Int))@. 283 | -- 284 | -- Implicit joins are represented by tuples. For example, to get 285 | -- the list of all blog posts and their authors, we could write: 286 | -- 287 | -- @ 288 | -- SELECT BlogPost.*, Person.* 289 | -- FROM BlogPost, Person 290 | -- WHERE BlogPost.authorId = Person.id 291 | -- ORDER BY BlogPost.title ASC 292 | -- @ 293 | -- 294 | -- In @esqueleto@, we may write the same query above as: 295 | -- 296 | -- @ 297 | -- 'select' $ 298 | -- 'from' $ \\(b, p) -> do 299 | -- 'where_' (b '^.' BlogPostAuthorId '==.' p '^.' PersonId) 300 | -- 'orderBy' ['asc' (b '^.' BlogPostTitle)] 301 | -- return (b, p) 302 | -- @ 303 | -- 304 | -- However, you may want your results to include people who don't 305 | -- have any blog posts as well using a @LEFT OUTER JOIN@: 306 | -- 307 | -- @ 308 | -- SELECT Person.*, BlogPost.* 309 | -- FROM Person LEFT OUTER JOIN BlogPost 310 | -- ON Person.id = BlogPost.authorId 311 | -- ORDER BY Person.name ASC, BlogPost.title ASC 312 | -- @ 313 | -- 314 | -- In @esqueleto@, we may write the same query above as: 315 | -- 316 | -- @ 317 | -- 'select' $ 318 | -- 'from' $ \\(p `'LeftOuterJoin`` mb) -> do 319 | -- 'on' ('just' (p '^.' PersonId) '==.' mb '?.' BlogPostAuthorId) 320 | -- 'orderBy' ['asc' (p '^.' PersonName), 'asc' (mb '?.' BlogPostTitle)] 321 | -- return (p, mb) 322 | -- @ 323 | -- 324 | -- On a @LEFT OUTER JOIN@ the entity on the right hand side may 325 | -- not exist (i.e. there may be a @Person@ without any 326 | -- @BlogPost@s), so while @p :: SqlExpr (Entity Person)@, we have 327 | -- @mb :: SqlExpr (Maybe (Entity BlogPost))@. The whole 328 | -- expression above has type @SqlPersist m [(Entity Person, Maybe 329 | -- (Entity BlogPost))]@. Instead of using @(^.)@, we used 330 | -- @('?.')@ to project a field from a @Maybe (Entity a)@. 331 | -- 332 | -- We are by no means limited to joins of two tables, nor by 333 | -- joins of different tables. For example, we may want a list 334 | -- of the @Follow@ entity: 335 | -- 336 | -- @ 337 | -- SELECT P1.*, Follow.*, P2.* 338 | -- FROM Person AS P1 339 | -- INNER JOIN Follow ON P1.id = Follow.follower 340 | -- INNER JOIN Person AS P2 ON P2.id = Follow.followed 341 | -- @ 342 | -- 343 | -- In @esqueleto@, we may write the same query above as: 344 | -- 345 | -- @ 346 | -- 'select' $ 347 | -- 'from' $ \\(p1 `'InnerJoin`` f `'InnerJoin`` p2) -> do 348 | -- 'on' (p1 '^.' PersonId '==.' f '^.' FollowFollower) 349 | -- 'on' (p2 '^.' PersonId '==.' f '^.' FollowFollowed) 350 | -- return (p1, f, p2) 351 | -- @ 352 | -- 353 | -- We also currently support @UPDATE@ and @DELETE@ statements. 354 | -- For example: 355 | -- 356 | -- @ 357 | -- do 'update' $ \\p -> do 358 | -- 'set' p [ PersonName '=.' 'val' \"João\" ] 359 | -- 'where_' (p '^.' PersonName '==.' 'val' \"Joao\") 360 | -- 'delete' $ 361 | -- 'from' $ \\p -> do 362 | -- 'where_' (p '^.' PersonAge '<.' 'just' ('val' 14)) 363 | -- @ 364 | -- 365 | -- The results of queries can also be used for insertions. 366 | -- In @SQL@, we might write the following, inserting a new blog 367 | -- post for every user: 368 | -- 369 | -- @ 370 | -- INSERT INTO BlogPost 371 | -- SELECT ('Group Blog Post', id) 372 | -- FROM Person 373 | -- @ 374 | -- 375 | -- In @esqueleto@, we may write the same query above as: 376 | -- 377 | -- @ 378 | -- 'insertSelect' $ 'from' $ \\p-> 379 | -- return $ BlogPost '<#' \"Group Blog Post\" '<&>' (p '^.' PersonId) 380 | -- @ 381 | -- 382 | -- Individual insertions can be performed through Persistent's 383 | -- 'insert' function, reexported for convenience. 384 | 385 | 386 | ---------------------------------------------------------------------- 387 | 388 | 389 | -- $reexports 390 | -- 391 | -- We re-export many symbols from @persistent@ for convenince: 392 | -- 393 | -- * \"Store functions\" from "Database.Persist". 394 | -- 395 | -- * Everything from "Database.Persist.Class" except for 396 | -- @PersistQuery@ and @delete@ (use 'deleteKey' instead). 397 | -- 398 | -- * Everything from "Database.Persist.Types" except for 399 | -- @Update@, @SelectOpt@, @BackendSpecificFilter@ and @Filter@. 400 | -- 401 | -- * Everything from "Database.Persist.Sql" except for 402 | -- @deleteWhereCount@ and @updateWhereCount@. 403 | 404 | 405 | ---------------------------------------------------------------------- 406 | 407 | 408 | -- $rdbmsSpecificModules 409 | -- 410 | -- There are many differences between SQL syntax and functions 411 | -- supported by different RDBMSs. Since version 2.2.8, 412 | -- @esqueleto@ includes modules containing functions that are 413 | -- specific to a given RDBMS. 414 | -- 415 | -- * PostgreSQL: "Database.Esqueleto.PostgreSQL". 416 | -- 417 | -- In order to use these functions, you need to explicitly import 418 | -- their corresponding modules, they're not re-exported here. 419 | -------------------------------------------------------------------------------- /src/Database/Esqueleto/Experimental.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternSynonyms #-} 2 | 3 | -- | This module contains a new way (introduced in 3.3.3.0) of using @FROM@ in 4 | -- Haskell. The old method was a bit finicky and could permit runtime errors, 5 | -- and this new way is both significantly safer and much more powerful. 6 | -- 7 | -- This syntax will become the default syntax exported from the library in 8 | -- version @3.6.0.0@. To use the old syntax, see "Database.Esqueleto.Legacy". 9 | module Database.Esqueleto.Experimental 10 | ( -- * Setup 11 | -- $setup 12 | 13 | -- * Introduction 14 | -- $introduction 15 | 16 | -- * A New Syntax 17 | -- $new-syntax 18 | 19 | -- * Documentation 20 | 21 | -- ** Basic Queries 22 | from 23 | , table 24 | , Table(..) 25 | , selectQuery 26 | 27 | -- ** Joins 28 | , (:&)(..) 29 | , on 30 | , innerJoin 31 | , innerJoinLateral 32 | , leftJoin 33 | , leftJoinLateral 34 | , rightJoin 35 | , fullOuterJoin 36 | , crossJoin 37 | , crossJoinLateral 38 | 39 | -- ** Set Operations 40 | -- $sql-set-operations 41 | , union_ 42 | , unionAll_ 43 | , except_ 44 | , intersect_ 45 | 46 | -- ** Common Table Expressions 47 | , with 48 | , withRecursive 49 | 50 | -- ** Internals 51 | , From(..) 52 | , ToMaybe(..) 53 | , ToAlias(..) 54 | , ToAliasReference(..) 55 | , ToSqlSetOperation(..) 56 | , SqlSelect 57 | , Nullable 58 | 59 | -- * The Normal Stuff 60 | , where_ 61 | , groupBy 62 | , groupBy_ 63 | , orderBy 64 | , asc 65 | , desc 66 | , limit 67 | , offset 68 | 69 | , distinct 70 | , distinctOn 71 | , don 72 | , distinctOnOrderBy 73 | , having 74 | , locking 75 | , forUpdate 76 | , forUpdateSkipLocked 77 | 78 | , (^.) 79 | , (?.) 80 | 81 | , val 82 | , isNothing 83 | , isNothing_ 84 | , just 85 | , nothing 86 | , joinV 87 | , withNonNull 88 | 89 | , countRows 90 | , count 91 | , countDistinct 92 | 93 | , not_ 94 | , (==.) 95 | , (>=.) 96 | , (>.) 97 | , (<=.) 98 | , (<.) 99 | , (!=.) 100 | , (&&.) 101 | , (||.) 102 | 103 | , between 104 | , (+.) 105 | , (-.) 106 | , (/.) 107 | , (*.) 108 | 109 | , round_ 110 | , ceiling_ 111 | , floor_ 112 | 113 | , min_ 114 | , max_ 115 | , sum_ 116 | , avg_ 117 | , castNum 118 | , castNumM 119 | 120 | , coalesce 121 | , coalesceDefault 122 | 123 | , lower_ 124 | , upper_ 125 | , trim_ 126 | , ltrim_ 127 | , rtrim_ 128 | , length_ 129 | , left_ 130 | , right_ 131 | 132 | , like 133 | , ilike 134 | , (%) 135 | , concat_ 136 | , (++.) 137 | , castString 138 | 139 | , subList_select 140 | , valList 141 | , justList 142 | 143 | , in_ 144 | , notIn 145 | , exists 146 | , notExists 147 | 148 | , set 149 | , (=.) 150 | , (+=.) 151 | , (-=.) 152 | , (*=.) 153 | , (/=.) 154 | 155 | , case_ 156 | , toBaseId 157 | , toBaseIdMaybe 158 | , fromBaseId 159 | , fromBaseIdMaybe 160 | , subSelect 161 | , subSelectMaybe 162 | , subSelectCount 163 | , subSelectForeign 164 | , subSelectList 165 | , subSelectUnsafe 166 | , ToBaseId(..) 167 | , when_ 168 | , then_ 169 | , else_ 170 | , Value(..) 171 | , ValueList(..) 172 | , OrderBy 173 | , DistinctOn 174 | , LockingKind(..) 175 | , LockableEntity(..) 176 | , SqlString 177 | 178 | -- ** Joins 179 | , InnerJoin(..) 180 | , CrossJoin(..) 181 | , LeftOuterJoin(..) 182 | , RightOuterJoin(..) 183 | , FullOuterJoin(..) 184 | , JoinKind(..) 185 | , OnClauseWithoutMatchingJoinException(..) 186 | -- *** Join Helpers 187 | , getTable 188 | , getTableMaybe 189 | , GetFirstTable(..) 190 | 191 | -- ** SQL backend 192 | , SqlQuery 193 | , SqlExpr 194 | , SqlEntity 195 | , select 196 | , selectOne 197 | , selectSource 198 | , delete 199 | , deleteCount 200 | , update 201 | , updateCount 202 | , insertSelect 203 | , insertSelectCount 204 | , (<#) 205 | , (<&>) 206 | 207 | -- ** Rendering Queries 208 | , renderQueryToText 209 | , renderQuerySelect 210 | , renderQueryUpdate 211 | , renderQueryDelete 212 | , renderQueryInsertInto 213 | 214 | -- ** Helpers 215 | , valkey 216 | , valJ 217 | , associateJoin 218 | 219 | -- ** Re-exports 220 | -- $reexports 221 | , deleteKey 222 | , module Database.Esqueleto.Internal.PersistentImport 223 | ) where 224 | 225 | import Database.Esqueleto.Internal.Internal hiding (From, from, on) 226 | import Database.Esqueleto.Internal.PersistentImport 227 | 228 | import Database.Esqueleto.Experimental.From 229 | import Database.Esqueleto.Experimental.From.CommonTableExpression 230 | import Database.Esqueleto.Experimental.From.Join 231 | import Database.Esqueleto.Experimental.From.SqlSetOperation 232 | import Database.Esqueleto.Experimental.ToAlias 233 | import Database.Esqueleto.Experimental.ToAliasReference 234 | import Database.Esqueleto.Experimental.ToMaybe 235 | 236 | -- $setup 237 | -- 238 | -- If you're already using "Database.Esqueleto", then you can get 239 | -- started using this module just by changing your imports slightly, 240 | -- as well as enabling the [TypeApplications](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#extension-TypeApplications) extension. 241 | -- 242 | -- @ 243 | -- {-\# LANGUAGE TypeApplications \#-} 244 | -- 245 | -- ... 246 | -- 247 | -- import Database.Esqueleto.Experimental 248 | -- @ 249 | -- 250 | -- Note: Prior to @esqueleto-3.3.4.0@, the @Database.Esqueleto.Experimental@ 251 | -- module did not reexport @Data.Esqueleto@. 252 | 253 | ---------------------------------------------------------------------- 254 | 255 | -- $introduction 256 | -- 257 | -- This module is fully backwards-compatible extension to the @esqueleto@ 258 | -- EDSL that expands subquery functionality and enables 259 | -- [SQL set operations](https://en.wikipedia.org/wiki/Set_operations_(SQL\)) 260 | -- to be written directly in Haskell. Specifically, this enables: 261 | -- 262 | -- * Subqueries in 'JOIN' statements 263 | -- * 'UNION' 264 | -- * 'UNION' 'ALL' 265 | -- * 'INTERSECT' 266 | -- * 'EXCEPT' 267 | -- 268 | -- As a consequence of this, several classes of runtime errors are now 269 | -- caught at compile time. This includes missing 'on' clauses and improper 270 | -- handling of @Maybe@ values in outer joins. 271 | -- 272 | -- This module can be used in conjunction with the main "Database.Esqueleto" 273 | -- module, but doing so requires qualified imports to avoid ambiguous 274 | -- definitions of 'on' and 'from', which are defined in both modules. 275 | -- 276 | -- Below we will give an overview of how to use this module and the 277 | -- features it enables. 278 | 279 | ---------------------------------------------------------------------- 280 | 281 | -- $new-syntax 282 | -- 283 | -- This module introduces a new syntax that serves to enable the aforementioned 284 | -- features. This new syntax also changes how joins written in the @esqueleto@ 285 | -- EDSL to more closely resemble the underlying SQL. 286 | -- 287 | -- For our examples, we'll use a schema similar to the one in the Getting Started 288 | -- section of "Database.Esqueleto": 289 | -- 290 | -- @ 291 | -- share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persist| 292 | -- Person 293 | -- name String 294 | -- age Int Maybe 295 | -- deriving Eq Show 296 | -- BlogPost 297 | -- title String 298 | -- authorId PersonId 299 | -- deriving Eq Show 300 | -- Follow 301 | -- follower PersonId 302 | -- followed PersonId 303 | -- deriving Eq Show 304 | -- |] 305 | -- @ 306 | -- 307 | -- === Example 1: Simple select 308 | -- 309 | -- Let's select all people who are named \"John\". 310 | -- 311 | -- ==== "Database.Esqueleto": 312 | -- 313 | -- @ 314 | -- select $ 315 | -- from $ \\people -> do 316 | -- where_ (people ^. PersonName ==. val \"John\") 317 | -- pure people 318 | -- @ 319 | -- 320 | -- ==== "Database.Esqueleto.Experimental": 321 | -- 322 | -- @ 323 | -- select $ do 324 | -- people <- from $ table \@Person 325 | -- where_ (people ^. PersonName ==. val \"John\") 326 | -- pure people 327 | -- @ 328 | -- 329 | -- 330 | -- === Example 2: Select with join 331 | -- 332 | -- Let's select all people and their blog posts who are over 333 | -- the age of 18. 334 | -- 335 | -- ==== "Database.Esqueleto": 336 | -- 337 | -- @ 338 | -- select $ 339 | -- from $ \\(people \`LeftOuterJoin\` blogPosts) -> do 340 | -- on (just (people ^. PersonId) ==. blogPosts ?. BlogPostAuthorId) 341 | -- where_ (people ^. PersonAge >. just (val 18)) 342 | -- pure (people, blogPosts) 343 | -- @ 344 | -- 345 | -- ==== "Database.Esqueleto.Experimental": 346 | -- 347 | -- Here we use the ':&' operator to pattern match against the joined tables. 348 | -- 349 | -- @ 350 | -- select $ do 351 | -- (people :& blogPosts) <- 352 | -- from $ table \@Person 353 | -- \`leftJoin\` table \@BlogPost 354 | -- \`on\` (\\(people :& blogPosts) -> 355 | -- just (people ^. PersonId) ==. blogPosts ?. BlogPostAuthorId) 356 | -- where_ (people ^. PersonAge >. just (val 18)) 357 | -- pure (people, blogPosts) 358 | -- @ 359 | -- 360 | -- === Example 3: Select with multi-table join 361 | -- 362 | -- Let's select all people who follow a person named \"John\", including 363 | -- the name of each follower. 364 | -- 365 | -- ==== "Database.Esqueleto": 366 | -- 367 | -- @ 368 | -- select $ 369 | -- from $ \\( 370 | -- people1 371 | -- \`InnerJoin\` followers 372 | -- \`InnerJoin\` people2 373 | -- ) -> do 374 | -- on (people1 ^. PersonId ==. followers ^. FollowFollowed) 375 | -- on (followers ^. FollowFollower ==. people2 ^. PersonId) 376 | -- where_ (people1 ^. PersonName ==. val \"John\") 377 | -- pure (followers, people2) 378 | -- @ 379 | -- 380 | -- ==== "Database.Esqueleto.Experimental": 381 | -- 382 | -- In this version, with each successive 'on' clause, only the tables 383 | -- we have already joined into are in scope, so we must pattern match 384 | -- accordingly. In this case, in the second 'innerJoin', we do not use 385 | -- the first `Person` reference, so we use @_@ as a placeholder to 386 | -- ignore it. This prevents a possible runtime error where a table 387 | -- is referenced before it appears in the sequence of 'JOIN's. 388 | -- 389 | -- @ 390 | -- select $ do 391 | -- (people1 :& followers :& people2) <- 392 | -- from $ table \@Person 393 | -- \`innerJoin` table \@Follow 394 | -- \`on\` (\\(people1 :& followers) -> 395 | -- people1 ^. PersonId ==. followers ^. FollowFollowed) 396 | -- \`innerJoin` table \@Person 397 | -- \`on\` (\\(_ :& followers :& people2) -> 398 | -- followers ^. FollowFollower ==. people2 ^. PersonId) 399 | -- where_ (people1 ^. PersonName ==. val \"John\") 400 | -- pure (followers, people2) 401 | -- @ 402 | -- 403 | -- === Example 4: Counting results of a subquery 404 | -- 405 | -- Let's count the number of people who have posted at least 10 posts 406 | -- 407 | -- ==== "Database.Esqueleto": 408 | -- 409 | -- @ 410 | -- select $ pure $ subSelectCount $ 411 | -- from $ \\( 412 | -- people 413 | -- \`InnerJoin\` blogPosts 414 | -- ) -> do 415 | -- on (people ^. PersonId ==. blogPosts ^. BlogPostAuthorId) 416 | -- groupBy (people ^. PersonId) 417 | -- having ((count $ blogPosts ^. BlogPostId) >. val 10) 418 | -- pure people 419 | -- @ 420 | -- 421 | -- ==== "Database.Esqueleto.Experimental": 422 | -- 423 | -- @ 424 | -- select $ do 425 | -- peopleWithPosts <- 426 | -- from $ do 427 | -- (people :& blogPosts) <- 428 | -- from $ table \@Person 429 | -- \`innerJoin\` table \@BlogPost 430 | -- \`on\` (\\(p :& bP) -> 431 | -- p ^. PersonId ==. bP ^. BlogPostAuthorId) 432 | -- groupBy (people ^. PersonId) 433 | -- having ((count $ blogPosts ^. BlogPostId) >. val 10) 434 | -- pure people 435 | -- pure $ count (peopleWithPosts ^. PersonId) 436 | -- @ 437 | -- 438 | -- We now have the ability to refactor this 439 | -- 440 | -- === Example 5: Sorting the results of a UNION with limits 441 | -- 442 | -- Out of all of the posts created by a person and the people they follow, 443 | -- generate a list of the first 25 posts, sorted alphabetically. 444 | -- 445 | -- ==== "Database.Esqueleto": 446 | -- 447 | -- Since 'UNION' is not supported, this requires using `Database.Esqueleto.rawSql`. (Not shown) 448 | -- 449 | -- ==== "Database.Esqueleto.Experimental": 450 | -- 451 | -- Since this module supports all set operations (see `SqlSetOperation`), we can use 452 | -- `Union` to write this query. 453 | -- 454 | -- @ 455 | -- select $ do 456 | -- (authors, blogPosts) <- from $ 457 | -- (do 458 | -- (author :& blogPost) <- 459 | -- from $ table \@Person 460 | -- \`innerJoin\` table \@BlogPost 461 | -- \`on\` (\\(a :& bP) -> 462 | -- a ^. PersonId ==. bP ^. BlogPostAuthorId) 463 | -- where_ (author ^. PersonId ==. val currentPersonId) 464 | -- pure (author, blogPost) 465 | -- ) 466 | -- \`union_\` 467 | -- (do 468 | -- (follow :& blogPost :& author) <- 469 | -- from $ table \@Follow 470 | -- \`innerJoin\` table \@BlogPost 471 | -- \`on\` (\\(f :& bP) -> 472 | -- f ^. FollowFollowed ==. bP ^. BlogPostAuthorId) 473 | -- \`innerJoin\` table \@Person 474 | -- \`on\` (\\(_ :& bP :& a) -> 475 | -- bP ^. BlogPostAuthorId ==. a ^. PersonId) 476 | -- where_ (follow ^. FollowFollower ==. val currentPersonId) 477 | -- pure (author, blogPost) 478 | -- ) 479 | -- orderBy [ asc (blogPosts ^. BlogPostTitle) ] 480 | -- limit 25 481 | -- pure (authors, blogPosts) 482 | -- @ 483 | -- 484 | -- === Example 6: LATERAL JOIN 485 | -- 486 | -- As of version @3.4.0.0@, lateral subquery joins are supported. 487 | -- 488 | -- 489 | -- @ 490 | -- select $ do 491 | -- (salesPerson :& maxSaleAmount :& maxSaleCustomerName) <- 492 | -- from $ table \@SalesPerson 493 | -- \`crossJoinLateral\` (\\salesPerson -> do 494 | -- sales <- from $ table \@Sale 495 | -- where_ $ sales ^. SaleSalesPersonId ==. salesPerson ^. SalesPersonId 496 | -- pure $ max_ (sales ^. SaleAmount) 497 | -- ) 498 | -- \`crossJoinLateral\` (\\(salesPerson :& maxSaleAmount) -> do 499 | -- sales <- from $ table \@Sale 500 | -- where_ $ sales ^. SaleSalesPersonId ==. salesPerson ^. SalesPersonId 501 | -- &&. sales ^. SaleAmount ==. maxSaleAmount 502 | -- pure $ sales ^. SaleCustomerName) 503 | -- ) 504 | -- pure (salesPerson ^. SalesPersonName, maxSaleAmount, maxSaleCustomerName) 505 | -- @ 506 | -- 507 | -- This is the equivalent to the following SQL (example taken from the 508 | -- [MySQL Lateral Derived Table](https://dev.mysql.com/doc/refman/8.0/en/lateral-derived-tables.html) 509 | -- documentation): 510 | -- 511 | -- @ 512 | -- SELECT 513 | -- salesperson.name, 514 | -- max_sale.amount, 515 | -- max_sale_customer.customer_name 516 | -- FROM 517 | -- salesperson, 518 | -- -- calculate maximum size, cache it in transient derived table max_sale 519 | -- LATERAL 520 | -- (SELECT MAX(amount) AS amount 521 | -- FROM all_sales 522 | -- WHERE all_sales.salesperson_id = salesperson.id) 523 | -- AS max_sale, 524 | -- LATERAL 525 | -- (SELECT customer_name 526 | -- FROM all_sales 527 | -- WHERE all_sales.salesperson_id = salesperson.id 528 | -- AND all_sales.amount = 529 | -- -- the cached maximum size 530 | -- max_sale.amount) 531 | -- AS max_sale_customer; 532 | -- @ 533 | 534 | -- $sql-set-operations 535 | -- 536 | -- Data type that represents SQL set operations. This includes 537 | -- 'UNION', 'UNION' 'ALL', 'EXCEPT', and 'INTERSECT'. These types form 538 | -- a binary tree, with @SqlQuery@ values on the leaves. 539 | -- 540 | -- Each function corresponding to the aforementioned set operations 541 | -- can be used as an infix in a @from@ to help with readability 542 | -- and lead to code that closely resembles the underlying SQL. For example, 543 | -- 544 | -- @ 545 | -- select $ from $ 546 | -- (do 547 | -- a <- from $ table @A 548 | -- pure $ a ^. ASomeCol 549 | -- ) 550 | -- \`union_\` 551 | -- (do 552 | -- b <- from $ table @B 553 | -- pure $ b ^. BSomeCol 554 | -- ) 555 | -- @ 556 | -- 557 | -- is translated into 558 | -- 559 | -- @ 560 | -- SELECT * FROM ( 561 | -- (SELECT a.some_col FROM a) 562 | -- UNION 563 | -- (SELECT b.some_col FROM b) 564 | -- ) 565 | -- @ 566 | -- 567 | -------------------------------------------------------------------------------- /src/Database/Esqueleto/Experimental/From.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE DerivingStrategies #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE FunctionalDependencies #-} 7 | {-# LANGUAGE GADTs #-} 8 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 9 | {-# LANGUAGE MultiParamTypeClasses #-} 10 | {-# LANGUAGE OverloadedStrings #-} 11 | {-# LANGUAGE PatternSynonyms #-} 12 | {-# LANGUAGE ScopedTypeVariables #-} 13 | {-# LANGUAGE TypeApplications #-} 14 | {-# LANGUAGE TypeFamilies #-} 15 | {-# LANGUAGE TypeOperators #-} 16 | {-# LANGUAGE UndecidableInstances #-} 17 | 18 | module Database.Esqueleto.Experimental.From 19 | where 20 | 21 | import qualified Control.Monad.Trans.Writer as W 22 | import Data.Coerce (coerce) 23 | import Data.Proxy 24 | import qualified Data.Text.Lazy.Builder as TLB 25 | import Database.Esqueleto.Experimental.ToAlias 26 | import Database.Esqueleto.Experimental.ToAliasReference 27 | import Database.Esqueleto.Internal.Internal hiding (From(..), from, on) 28 | import Database.Esqueleto.Internal.PersistentImport 29 | 30 | -- | 'FROM' clause, used to bring entities into scope. 31 | -- 32 | -- Internally, this function uses the `From` datatype. 33 | -- Unlike the old `Database.Esqueleto.from`, this does not 34 | -- take a function as a parameter, but rather a value that 35 | -- represents a 'JOIN' tree constructed out of instances of `From`. 36 | -- This implementation eliminates certain 37 | -- types of runtime errors by preventing the construction of 38 | -- invalid SQL (e.g. illegal nested-@from@). 39 | from :: ToFrom a a' => a -> SqlQuery a' 40 | from f = do 41 | (a, clause) <- unFrom (toFrom f) 42 | Q $ W.tell mempty{sdFromClause=[FromRaw $ clause]} 43 | pure a 44 | 45 | type RawFn = NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue]) 46 | 47 | -- | Data type defining the "From" language. This should not 48 | -- constructed directly in application code. 49 | -- 50 | -- A @From@ is a SqlQuery which returns a reference to the result of calling from 51 | -- and a function that produces a portion of a FROM clause. This gets passed to 52 | -- the FromRaw FromClause constructor directly when converting 53 | -- from a @From@ to a @SqlQuery@ using @from@ 54 | -- 55 | -- @since 3.5.0.0 56 | newtype From a = From 57 | { unFrom :: SqlQuery (a, RawFn)} 58 | 59 | 60 | -- | A helper class primarily designed to allow using @SqlQuery@ directly in 61 | -- a From expression. This is also useful for embedding a @SqlSetOperation@, 62 | -- as well as supporting backwards compatibility for the 63 | -- data constructor join tree used prior to /3.5.0.0/ 64 | -- 65 | -- @since 3.5.0.0 66 | class ToFrom a r | a -> r where 67 | toFrom :: a -> From r 68 | instance ToFrom (From a) a where 69 | toFrom = id 70 | 71 | {-# DEPRECATED Table "@since 3.5.0.0 - use 'table' instead" #-} 72 | data Table a = Table 73 | 74 | instance PersistEntity ent => ToFrom (Table ent) (SqlExpr (Entity ent)) where 75 | toFrom _ = table 76 | 77 | -- | Bring a PersistEntity into scope from a table 78 | -- 79 | -- @ 80 | -- select $ from $ table \@People 81 | -- @ 82 | -- 83 | -- @since 3.5.0.0 84 | table :: forall ent. PersistEntity ent => From (SqlExpr (Entity ent)) 85 | table = From $ do 86 | let ed = entityDef (Proxy @ent) 87 | ident <- newIdentFor (coerce $ getEntityDBName ed) 88 | let entity = unsafeSqlEntity ident 89 | pure $ ( entity, const $ base ident ed ) 90 | where 91 | base ident@(I identText) def info = 92 | let db = coerce $ getEntityDBName def 93 | in ( (fromDBName info (coerce db)) <> 94 | if db == identText 95 | then mempty 96 | else " AS " <> useIdent info ident 97 | , mempty 98 | ) 99 | 100 | 101 | instance (SqlSelect a r, ToAlias a, ToAliasReference a) => ToFrom (SqlQuery a) a where 102 | toFrom = selectQuery 103 | 104 | -- | Select from a subquery, often used in conjuction with joins but can be 105 | -- used without any joins. Because @SqlQuery@ has a @ToFrom@ instance you probably 106 | -- dont need to use this function directly. 107 | -- 108 | -- @ 109 | -- select $ 110 | -- p <- from $ 111 | -- selectQuery do 112 | -- p <- from $ table \@Person 113 | -- limit 5 114 | -- orderBy [ asc p ^. PersonAge ] 115 | -- ... 116 | -- @ 117 | -- 118 | -- @since 3.5.0.0 119 | selectQuery :: (SqlSelect a r, ToAlias a, ToAliasReference a) => SqlQuery a -> From a 120 | selectQuery subquery = From $ do 121 | -- We want to update the IdentState without writing the query to side data 122 | (ret, sideData) <- Q $ W.censor (\_ -> mempty) $ W.listen $ unQ subquery 123 | aliasedValue <- toAlias ret 124 | -- Make a fake query with the aliased results, this allows us to ensure that the query is only run once 125 | let aliasedQuery = Q $ W.WriterT $ pure (aliasedValue, sideData) 126 | -- Add the FromQuery that renders the subquery to our side data 127 | subqueryAlias <- newIdentFor (DBName "q") 128 | -- Pass the aliased results of the subquery to the outer query 129 | -- create aliased references from the outer query results (e.g value from subquery will be `subquery`.`value`), 130 | -- this is probably overkill as the aliases should already be unique but seems to be good practice. 131 | ref <- toAliasReference subqueryAlias aliasedValue 132 | 133 | pure (ref, \_ info -> 134 | let (queryText,queryVals) = toRawSql SELECT info aliasedQuery 135 | in 136 | ( (parens queryText) <> " AS " <> useIdent info subqueryAlias 137 | , queryVals 138 | ) 139 | ) 140 | -------------------------------------------------------------------------------- /src/Database/Esqueleto/Experimental/From/CommonTableExpression.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | 5 | module Database.Esqueleto.Experimental.From.CommonTableExpression 6 | where 7 | 8 | import qualified Control.Monad.Trans.Writer as W 9 | import qualified Data.Text.Lazy.Builder as TLB 10 | import Database.Esqueleto.Experimental.From 11 | import Database.Esqueleto.Experimental.From.SqlSetOperation 12 | import Database.Esqueleto.Experimental.ToAlias 13 | import Database.Esqueleto.Experimental.ToAliasReference 14 | import Database.Esqueleto.Internal.Internal hiding (From(..), from, on) 15 | 16 | -- | @WITH@ clause used to introduce a [Common Table Expression (CTE)](https://en.wikipedia.org/wiki/Hierarchical_and_recursive_queries_in_SQL#Common_table_expression). 17 | -- CTEs are supported in most modern SQL engines and can be useful 18 | -- in performance tuning. In Esqueleto, CTEs should be used as a 19 | -- subquery memoization tactic. When writing plain SQL, CTEs 20 | -- are sometimes used to organize the SQL code, in Esqueleto, this 21 | -- is better achieved through function that return 'SqlQuery' values. 22 | -- 23 | -- @ 24 | -- select $ do 25 | -- cte <- with subQuery 26 | -- cteResult <- from cte 27 | -- where_ $ cteResult ... 28 | -- pure cteResult 29 | -- @ 30 | -- 31 | -- __WARNING__: In some SQL engines using a CTE can diminish performance. 32 | -- In these engines the CTE is treated as an optimization fence. You should 33 | -- always verify that using a CTE will in fact improve your performance 34 | -- over a regular subquery. 35 | -- 36 | -- Notably, in PostgreSQL prior to version 12, CTEs are always fully 37 | -- calculated, which can potentially significantly pessimize queries. As of 38 | -- PostgreSQL 12, non-recursive and side-effect-free queries may be inlined and 39 | -- optimized accordingly if not declared @MATERIALIZED@ to get the previous 40 | -- behaviour. See [the PostgreSQL CTE documentation](https://www.postgresql.org/docs/current/queries-with.html#id-1.5.6.12.7), 41 | -- section Materialization, for more information. To use a @MATERIALIZED@ query 42 | -- in Esquelto, see functions 'withMaterialized' and 'withRecursiveMaterialized'. 43 | -- 44 | -- /Since: 3.4.0.0/ 45 | with :: ( ToAlias a 46 | , ToAliasReference a 47 | , SqlSelect a r 48 | ) => SqlQuery a -> SqlQuery (From a) 49 | with query = do 50 | (ret, sideData) <- Q $ W.censor (\_ -> mempty) $ W.listen $ unQ query 51 | aliasedValue <- toAlias ret 52 | let aliasedQuery = Q $ W.WriterT $ pure (aliasedValue, sideData) 53 | ident <- newIdentFor (DBName "cte") 54 | let clause = CommonTableExpressionClause NormalCommonTableExpression (\_ _ -> "") ident (\info -> toRawSql SELECT info aliasedQuery) 55 | Q $ W.tell mempty{sdCteClause = [clause]} 56 | ref <- toAliasReference ident aliasedValue 57 | pure $ From $ do 58 | newIdent <- newIdentFor (DBName "cte") 59 | localRef <- toAliasReference newIdent ref 60 | let makeLH info = useIdent info ident <> " AS " <> useIdent info newIdent 61 | pure (localRef, (\_ info -> (makeLH info, mempty))) 62 | 63 | -- | @WITH@ @RECURSIVE@ allows one to make a recursive subquery, which can 64 | -- reference itself. Like @WITH@, this is supported in most modern SQL engines. 65 | -- Useful for hierarchical, self-referential data, like a tree of data. 66 | -- 67 | -- @ 68 | -- select $ do 69 | -- cte <- withRecursive 70 | -- (do 71 | -- person <- from $ table \@Person 72 | -- where_ $ person ^. PersonId ==. val personId 73 | -- pure person 74 | -- ) 75 | -- unionAll_ 76 | -- (\\self -> do 77 | -- (p :& f :& p2 :& pSelf) <- from self 78 | -- \`innerJoin\` $ table \@Follow 79 | -- \`on\` (\\(p :& f) -> 80 | -- p ^. PersonId ==. f ^. FollowFollower) 81 | -- \`innerJoin\` $ table \@Person 82 | -- \`on\` (\\(p :& f :& p2) -> 83 | -- f ^. FollowFollowed ==. p2 ^. PersonId) 84 | -- \`leftJoin\` self 85 | -- \`on\` (\\(_ :& _ :& p2 :& pSelf) -> 86 | -- just (p2 ^. PersonId) ==. pSelf ?. PersonId) 87 | -- where_ $ isNothing (pSelf ?. PersonId) 88 | -- groupBy (p2 ^. PersonId) 89 | -- pure p2 90 | -- ) 91 | -- from cte 92 | -- @ 93 | -- 94 | -- /Since: 3.4.0.0/ 95 | withRecursive :: ( ToAlias a 96 | , ToAliasReference a 97 | , SqlSelect a r 98 | ) 99 | => SqlQuery a 100 | -> UnionKind 101 | -> (From a -> SqlQuery a) 102 | -> SqlQuery (From a) 103 | withRecursive baseCase unionKind recursiveCase = do 104 | (ret, sideData) <- Q $ W.censor (\_ -> mempty) $ W.listen $ unQ baseCase 105 | aliasedValue <- toAlias ret 106 | let aliasedQuery = Q $ W.WriterT $ pure (aliasedValue, sideData) 107 | ident <- newIdentFor (DBName "cte") 108 | ref <- toAliasReference ident aliasedValue 109 | let refFrom = From (pure (ref, (\_ info -> (useIdent info ident, mempty)))) 110 | let recursiveQuery = recursiveCase refFrom 111 | let noModifier _ _ = "" 112 | let clause = CommonTableExpressionClause RecursiveCommonTableExpression noModifier ident 113 | (\info -> (toRawSql SELECT info aliasedQuery) 114 | <> ("\n" <> (unUnionKind unionKind) <> "\n", mempty) 115 | <> (toRawSql SELECT info recursiveQuery) 116 | ) 117 | Q $ W.tell mempty{sdCteClause = [clause]} 118 | pure refFrom 119 | 120 | newtype UnionKind = UnionKind { unUnionKind :: TLB.Builder } 121 | instance Union_ UnionKind where 122 | union_ = UnionKind "UNION" 123 | instance UnionAll_ UnionKind where 124 | unionAll_ = UnionKind "UNION ALL" 125 | -------------------------------------------------------------------------------- /src/Database/Esqueleto/Experimental/From/SqlSetOperation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE FunctionalDependencies #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE PatternSynonyms #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE TypeApplications #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | {-# LANGUAGE UndecidableInstances #-} 11 | 12 | module Database.Esqueleto.Experimental.From.SqlSetOperation 13 | where 14 | 15 | import Control.Arrow (first) 16 | import Control.Monad.Trans.Class (lift) 17 | import qualified Control.Monad.Trans.State as S 18 | import qualified Control.Monad.Trans.Writer as W 19 | import qualified Data.Text.Lazy.Builder as TLB 20 | import Database.Esqueleto.Experimental.From 21 | import Database.Esqueleto.Experimental.ToAlias 22 | import Database.Esqueleto.Experimental.ToAliasReference 23 | import Database.Esqueleto.Internal.Internal hiding (From(..), from, on) 24 | import Database.Esqueleto.Internal.PersistentImport (PersistValue) 25 | 26 | -- | Data type used to implement the SqlSetOperation language 27 | -- this type is implemented in the same way as a @From@ 28 | -- 29 | -- Semantically a @SqlSetOperation@ is always a @From@ but not vice versa 30 | -- 31 | -- @since 3.5.0.0 32 | newtype SqlSetOperation a = SqlSetOperation 33 | { unSqlSetOperation :: NeedParens -> SqlQuery (a, IdentInfo -> (TLB.Builder, [PersistValue]))} 34 | 35 | instance ToAliasReference a => ToFrom (SqlSetOperation a) a where 36 | toFrom setOperation = From $ do 37 | ident <- newIdentFor (DBName "u") 38 | (a, fromClause) <- unSqlSetOperation setOperation Never 39 | ref <- toAliasReference ident a 40 | pure (ref, \_ info -> (first parens $ fromClause info) <> (" AS " <> useIdent info ident, mempty)) 41 | 42 | -- | Type class to support direct use of @SqlQuery@ in a set operation tree 43 | -- 44 | -- @since 3.5.0.0 45 | class ToSqlSetOperation a r | a -> r where 46 | toSqlSetOperation :: a -> SqlSetOperation r 47 | instance ToSqlSetOperation (SqlSetOperation a) a where 48 | toSqlSetOperation = id 49 | instance (SqlSelect a r, ToAlias a, ToAliasReference a) => ToSqlSetOperation (SqlQuery a) a where 50 | toSqlSetOperation subquery = 51 | SqlSetOperation $ \p -> do 52 | (ret, sideData) <- Q $ W.censor (\_ -> mempty) $ W.listen $ unQ subquery 53 | aliasedValue <- toAlias ret 54 | let aliasedQuery = Q $ W.WriterT $ pure (aliasedValue, sideData) 55 | let p' = 56 | case p of 57 | Parens -> Parens 58 | Never -> 59 | if (sdLimitClause sideData) /= mempty 60 | || length (sdOrderByClause sideData) > 0 then 61 | Parens 62 | else 63 | Never 64 | pure (aliasedValue, \info -> first (parensM p') $ toRawSql SELECT info aliasedQuery) 65 | 66 | -- | Helper function for defining set operations 67 | -- @since 3.5.0.0 68 | mkSetOperation :: (ToSqlSetOperation a a', ToSqlSetOperation b a') 69 | => TLB.Builder -> a -> b -> SqlSetOperation a' 70 | mkSetOperation operation lhs rhs = SqlSetOperation $ \p -> do 71 | state <- Q $ lift S.get 72 | (leftValue, leftClause) <- unSqlSetOperation (toSqlSetOperation lhs) p 73 | Q $ lift $ S.put state 74 | (_, rightClause) <- unSqlSetOperation (toSqlSetOperation rhs) p 75 | pure (leftValue, \info -> leftClause info <> (operation, mempty) <> rightClause info) 76 | 77 | -- | Overloaded @union_@ function to support use in both 'SqlSetOperation' 78 | -- and 'withRecursive' 79 | -- 80 | -- @since 3.5.0.0 81 | class Union_ a where 82 | -- | @UNION@ SQL set operation. Can be used as an infix function between 'SqlQuery' values. 83 | union_ :: a 84 | 85 | instance (ToSqlSetOperation a c, ToSqlSetOperation b c, res ~ SqlSetOperation c) 86 | => Union_ (a -> b -> res) where 87 | union_ = mkSetOperation " UNION " 88 | 89 | -- | Overloaded @unionAll_@ function to support use in both 'SqlSetOperation' 90 | -- and 'withRecursive' 91 | -- 92 | -- @since 3.5.0.0 93 | class UnionAll_ a where 94 | -- | @UNION@ @ALL@ SQL set operation. Can be used as an infix function between 'SqlQuery' values. 95 | unionAll_ :: a 96 | instance (ToSqlSetOperation a c, ToSqlSetOperation b c, res ~ SqlSetOperation c) 97 | => UnionAll_ (a -> b -> res) where 98 | unionAll_ = mkSetOperation " UNION ALL " 99 | 100 | -- | @EXCEPT@ SQL set operation. Can be used as an infix function between 'SqlQuery' values. 101 | except_ :: (ToSqlSetOperation a a', ToSqlSetOperation b a') => a -> b -> SqlSetOperation a' 102 | except_ = mkSetOperation " EXCEPT " 103 | 104 | -- | @INTERSECT@ SQL set operation. Can be used as an infix function between 'SqlQuery' values. 105 | intersect_ :: (ToSqlSetOperation a a', ToSqlSetOperation b a') => a -> b -> SqlSetOperation a' 106 | intersect_ = mkSetOperation " INTERSECT " 107 | -------------------------------------------------------------------------------- /src/Database/Esqueleto/Experimental/ToAlias.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | 5 | module Database.Esqueleto.Experimental.ToAlias 6 | where 7 | 8 | import Database.Esqueleto.Internal.Internal hiding (From, from, on) 9 | import Database.Esqueleto.Internal.PersistentImport 10 | 11 | -- Tedious tuple magic 12 | class ToAlias a where 13 | toAlias :: a -> SqlQuery a 14 | 15 | instance ToAlias (SqlExpr (Value a)) where 16 | toAlias e@(ERaw m f) 17 | | Just _ <- sqlExprMetaAlias m = pure e 18 | | otherwise = do 19 | ident <- newIdentFor (DBName "v") 20 | pure $ ERaw noMeta{sqlExprMetaAlias = Just ident} f 21 | 22 | instance ToAlias (SqlExpr (Entity a)) where 23 | toAlias e@(ERaw m f) 24 | | Just _ <- sqlExprMetaAlias m = pure e 25 | | otherwise = do 26 | ident <- newIdentFor (DBName "v") 27 | pure $ ERaw m{sqlExprMetaIsReference = False, sqlExprMetaAlias = Just ident} f 28 | 29 | instance ToAlias (SqlExpr (Maybe (Entity a))) where 30 | -- FIXME: Code duplication because the compiler doesnt like half final encoding 31 | toAlias e@(ERaw m f) 32 | | Just _ <- sqlExprMetaAlias m = pure e 33 | | otherwise = do 34 | ident <- newIdentFor (DBName "v") 35 | pure $ ERaw m{sqlExprMetaIsReference = False, sqlExprMetaAlias = Just ident} f 36 | 37 | instance (ToAlias a, ToAlias b) => ToAlias (a,b) where 38 | toAlias (a,b) = (,) <$> toAlias a <*> toAlias b 39 | 40 | instance ( ToAlias a 41 | , ToAlias b 42 | , ToAlias c 43 | ) => ToAlias (a,b,c) where 44 | toAlias x = to3 <$> (toAlias $ from3 x) 45 | 46 | instance ( ToAlias a 47 | , ToAlias b 48 | , ToAlias c 49 | , ToAlias d 50 | ) => ToAlias (a,b,c,d) where 51 | toAlias x = to4 <$> (toAlias $ from4 x) 52 | 53 | instance ( ToAlias a 54 | , ToAlias b 55 | , ToAlias c 56 | , ToAlias d 57 | , ToAlias e 58 | ) => ToAlias (a,b,c,d,e) where 59 | toAlias x = to5 <$> (toAlias $ from5 x) 60 | 61 | instance ( ToAlias a 62 | , ToAlias b 63 | , ToAlias c 64 | , ToAlias d 65 | , ToAlias e 66 | , ToAlias f 67 | ) => ToAlias (a,b,c,d,e,f) where 68 | toAlias x = to6 <$> (toAlias $ from6 x) 69 | 70 | instance ( ToAlias a 71 | , ToAlias b 72 | , ToAlias c 73 | , ToAlias d 74 | , ToAlias e 75 | , ToAlias f 76 | , ToAlias g 77 | ) => ToAlias (a,b,c,d,e,f,g) where 78 | toAlias x = to7 <$> (toAlias $ from7 x) 79 | 80 | instance ( ToAlias a 81 | , ToAlias b 82 | , ToAlias c 83 | , ToAlias d 84 | , ToAlias e 85 | , ToAlias f 86 | , ToAlias g 87 | , ToAlias h 88 | ) => ToAlias (a,b,c,d,e,f,g,h) where 89 | toAlias x = to8 <$> (toAlias $ from8 x) 90 | 91 | instance ( ToAlias a 92 | , ToAlias b 93 | , ToAlias c 94 | , ToAlias d 95 | , ToAlias e 96 | , ToAlias f 97 | , ToAlias g 98 | , ToAlias h 99 | , ToAlias i 100 | ) => ToAlias (a,b,c,d,e,f,g,h,i) where 101 | toAlias x = to9 <$> (toAlias $ from9 x) 102 | 103 | instance ( ToAlias a 104 | , ToAlias b 105 | , ToAlias c 106 | , ToAlias d 107 | , ToAlias e 108 | , ToAlias f 109 | , ToAlias g 110 | , ToAlias h 111 | , ToAlias i 112 | , ToAlias j 113 | ) => ToAlias (a,b,c,d,e,f,g,h,i,j) where 114 | toAlias x = to10 <$> (toAlias $ from10 x) 115 | 116 | instance ( ToAlias a 117 | , ToAlias b 118 | , ToAlias c 119 | , ToAlias d 120 | , ToAlias e 121 | , ToAlias f 122 | , ToAlias g 123 | , ToAlias h 124 | , ToAlias i 125 | , ToAlias j 126 | , ToAlias k 127 | ) => ToAlias (a,b,c,d,e,f,g,h,i,j,k) where 128 | toAlias x = to11 <$> (toAlias $ from11 x) 129 | 130 | instance ( ToAlias a 131 | , ToAlias b 132 | , ToAlias c 133 | , ToAlias d 134 | , ToAlias e 135 | , ToAlias f 136 | , ToAlias g 137 | , ToAlias h 138 | , ToAlias i 139 | , ToAlias j 140 | , ToAlias k 141 | , ToAlias l 142 | ) => ToAlias (a,b,c,d,e,f,g,h,i,j,k,l) where 143 | toAlias x = to12 <$> (toAlias $ from12 x) 144 | 145 | instance ( ToAlias a 146 | , ToAlias b 147 | , ToAlias c 148 | , ToAlias d 149 | , ToAlias e 150 | , ToAlias f 151 | , ToAlias g 152 | , ToAlias h 153 | , ToAlias i 154 | , ToAlias j 155 | , ToAlias k 156 | , ToAlias l 157 | , ToAlias m 158 | ) => ToAlias (a,b,c,d,e,f,g,h,i,j,k,l,m) where 159 | toAlias x = to13 <$> (toAlias $ from13 x) 160 | 161 | instance ( ToAlias a 162 | , ToAlias b 163 | , ToAlias c 164 | , ToAlias d 165 | , ToAlias e 166 | , ToAlias f 167 | , ToAlias g 168 | , ToAlias h 169 | , ToAlias i 170 | , ToAlias j 171 | , ToAlias k 172 | , ToAlias l 173 | , ToAlias m 174 | , ToAlias n 175 | ) => ToAlias (a,b,c,d,e,f,g,h,i,j,k,l,m,n) where 176 | toAlias x = to14 <$> (toAlias $ from14 x) 177 | 178 | instance ( ToAlias a 179 | , ToAlias b 180 | , ToAlias c 181 | , ToAlias d 182 | , ToAlias e 183 | , ToAlias f 184 | , ToAlias g 185 | , ToAlias h 186 | , ToAlias i 187 | , ToAlias j 188 | , ToAlias k 189 | , ToAlias l 190 | , ToAlias m 191 | , ToAlias n 192 | , ToAlias o 193 | ) => ToAlias (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) where 194 | toAlias x = to15 <$> (toAlias $ from15 x) 195 | 196 | instance ( ToAlias a 197 | , ToAlias b 198 | , ToAlias c 199 | , ToAlias d 200 | , ToAlias e 201 | , ToAlias f 202 | , ToAlias g 203 | , ToAlias h 204 | , ToAlias i 205 | , ToAlias j 206 | , ToAlias k 207 | , ToAlias l 208 | , ToAlias m 209 | , ToAlias n 210 | , ToAlias o 211 | , ToAlias p 212 | ) => ToAlias (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) where 213 | toAlias x = to16 <$> (toAlias $ from16 x) 214 | -------------------------------------------------------------------------------- /src/Database/Esqueleto/Experimental/ToAliasReference.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | 5 | module Database.Esqueleto.Experimental.ToAliasReference 6 | where 7 | 8 | import Database.Esqueleto.Internal.Internal hiding (From, from, on) 9 | import Database.Esqueleto.Internal.PersistentImport 10 | 11 | -- more tedious tuple magic 12 | class ToAliasReference a where 13 | toAliasReference :: Ident -> a -> SqlQuery a 14 | 15 | instance ToAliasReference (SqlExpr (Value a)) where 16 | toAliasReference aliasSource (ERaw m _) 17 | | Just alias <- sqlExprMetaAlias m = pure $ ERaw m{sqlExprMetaIsReference = True} $ \_ info -> 18 | (useIdent info aliasSource <> "." <> useIdent info alias, []) 19 | toAliasReference _ e = pure e 20 | 21 | instance ToAliasReference (SqlExpr (Entity a)) where 22 | toAliasReference aliasSource (ERaw m _) 23 | | Just _ <- sqlExprMetaAlias m = 24 | pure $ ERaw m{sqlExprMetaIsReference = True} $ \_ info -> 25 | (useIdent info aliasSource, []) 26 | toAliasReference _ e = pure e 27 | 28 | instance ToAliasReference (SqlExpr (Maybe (Entity a))) where 29 | toAliasReference aliasSource e = 30 | veryUnsafeCoerceSqlExpr <$> toAliasReference aliasSource (veryUnsafeCoerceSqlExpr e :: SqlExpr (Entity a)) 31 | 32 | 33 | instance (ToAliasReference a, ToAliasReference b) => ToAliasReference (a, b) where 34 | toAliasReference ident (a,b) = (,) <$> (toAliasReference ident a) <*> (toAliasReference ident b) 35 | 36 | instance ( ToAliasReference a 37 | , ToAliasReference b 38 | , ToAliasReference c 39 | ) => ToAliasReference (a,b,c) where 40 | toAliasReference ident x = fmap to3 $ toAliasReference ident $ from3 x 41 | 42 | instance ( ToAliasReference a 43 | , ToAliasReference b 44 | , ToAliasReference c 45 | , ToAliasReference d 46 | ) => ToAliasReference (a,b,c,d) where 47 | toAliasReference ident x = fmap to4 $ toAliasReference ident $ from4 x 48 | 49 | instance ( ToAliasReference a 50 | , ToAliasReference b 51 | , ToAliasReference c 52 | , ToAliasReference d 53 | , ToAliasReference e 54 | ) => ToAliasReference (a,b,c,d,e) where 55 | toAliasReference ident x = fmap to5 $ toAliasReference ident $ from5 x 56 | 57 | instance ( ToAliasReference a 58 | , ToAliasReference b 59 | , ToAliasReference c 60 | , ToAliasReference d 61 | , ToAliasReference e 62 | , ToAliasReference f 63 | ) => ToAliasReference (a,b,c,d,e,f) where 64 | toAliasReference ident x = to6 <$> (toAliasReference ident $ from6 x) 65 | 66 | instance ( ToAliasReference a 67 | , ToAliasReference b 68 | , ToAliasReference c 69 | , ToAliasReference d 70 | , ToAliasReference e 71 | , ToAliasReference f 72 | , ToAliasReference g 73 | ) => ToAliasReference (a,b,c,d,e,f,g) where 74 | toAliasReference ident x = to7 <$> (toAliasReference ident $ from7 x) 75 | 76 | instance ( ToAliasReference a 77 | , ToAliasReference b 78 | , ToAliasReference c 79 | , ToAliasReference d 80 | , ToAliasReference e 81 | , ToAliasReference f 82 | , ToAliasReference g 83 | , ToAliasReference h 84 | ) => ToAliasReference (a,b,c,d,e,f,g,h) where 85 | toAliasReference ident x = to8 <$> (toAliasReference ident $ from8 x) 86 | 87 | instance ( ToAliasReference a 88 | , ToAliasReference b 89 | , ToAliasReference c 90 | , ToAliasReference d 91 | , ToAliasReference e 92 | , ToAliasReference f 93 | , ToAliasReference g 94 | , ToAliasReference h 95 | , ToAliasReference i 96 | ) => ToAliasReference (a,b,c,d,e,f,g,h,i) where 97 | toAliasReference ident x = to9 <$> (toAliasReference ident $ from9 x) 98 | 99 | instance ( ToAliasReference a 100 | , ToAliasReference b 101 | , ToAliasReference c 102 | , ToAliasReference d 103 | , ToAliasReference e 104 | , ToAliasReference f 105 | , ToAliasReference g 106 | , ToAliasReference h 107 | , ToAliasReference i 108 | , ToAliasReference j 109 | ) => ToAliasReference (a,b,c,d,e,f,g,h,i,j) where 110 | toAliasReference ident x = to10 <$> (toAliasReference ident $ from10 x) 111 | 112 | instance ( ToAliasReference a 113 | , ToAliasReference b 114 | , ToAliasReference c 115 | , ToAliasReference d 116 | , ToAliasReference e 117 | , ToAliasReference f 118 | , ToAliasReference g 119 | , ToAliasReference h 120 | , ToAliasReference i 121 | , ToAliasReference j 122 | , ToAliasReference k 123 | ) => ToAliasReference (a,b,c,d,e,f,g,h,i,j,k) where 124 | toAliasReference ident x = to11 <$> (toAliasReference ident $ from11 x) 125 | 126 | instance ( ToAliasReference a 127 | , ToAliasReference b 128 | , ToAliasReference c 129 | , ToAliasReference d 130 | , ToAliasReference e 131 | , ToAliasReference f 132 | , ToAliasReference g 133 | , ToAliasReference h 134 | , ToAliasReference i 135 | , ToAliasReference j 136 | , ToAliasReference k 137 | , ToAliasReference l 138 | ) => ToAliasReference (a,b,c,d,e,f,g,h,i,j,k,l) where 139 | toAliasReference ident x = to12 <$> (toAliasReference ident $ from12 x) 140 | 141 | instance ( ToAliasReference a 142 | , ToAliasReference b 143 | , ToAliasReference c 144 | , ToAliasReference d 145 | , ToAliasReference e 146 | , ToAliasReference f 147 | , ToAliasReference g 148 | , ToAliasReference h 149 | , ToAliasReference i 150 | , ToAliasReference j 151 | , ToAliasReference k 152 | , ToAliasReference l 153 | , ToAliasReference m 154 | ) => ToAliasReference (a,b,c,d,e,f,g,h,i,j,k,l,m) where 155 | toAliasReference ident x = to13 <$> (toAliasReference ident $ from13 x) 156 | 157 | instance ( ToAliasReference a 158 | , ToAliasReference b 159 | , ToAliasReference c 160 | , ToAliasReference d 161 | , ToAliasReference e 162 | , ToAliasReference f 163 | , ToAliasReference g 164 | , ToAliasReference h 165 | , ToAliasReference i 166 | , ToAliasReference j 167 | , ToAliasReference k 168 | , ToAliasReference l 169 | , ToAliasReference m 170 | , ToAliasReference n 171 | ) => ToAliasReference (a,b,c,d,e,f,g,h,i,j,k,l,m,n) where 172 | toAliasReference ident x = to14 <$> (toAliasReference ident $ from14 x) 173 | 174 | instance ( ToAliasReference a 175 | , ToAliasReference b 176 | , ToAliasReference c 177 | , ToAliasReference d 178 | , ToAliasReference e 179 | , ToAliasReference f 180 | , ToAliasReference g 181 | , ToAliasReference h 182 | , ToAliasReference i 183 | , ToAliasReference j 184 | , ToAliasReference k 185 | , ToAliasReference l 186 | , ToAliasReference m 187 | , ToAliasReference n 188 | , ToAliasReference o 189 | ) => ToAliasReference (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) where 190 | toAliasReference ident x = to15 <$> (toAliasReference ident $ from15 x) 191 | 192 | instance ( ToAliasReference a 193 | , ToAliasReference b 194 | , ToAliasReference c 195 | , ToAliasReference d 196 | , ToAliasReference e 197 | , ToAliasReference f 198 | , ToAliasReference g 199 | , ToAliasReference h 200 | , ToAliasReference i 201 | , ToAliasReference j 202 | , ToAliasReference k 203 | , ToAliasReference l 204 | , ToAliasReference m 205 | , ToAliasReference n 206 | , ToAliasReference o 207 | , ToAliasReference p 208 | ) => ToAliasReference (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) where 209 | toAliasReference ident x = to16 <$> (toAliasReference ident $ from16 x) 210 | -------------------------------------------------------------------------------- /src/Database/Esqueleto/Experimental/ToMaybe.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | 4 | module Database.Esqueleto.Experimental.ToMaybe 5 | ( module Database.Esqueleto.Experimental.ToMaybe 6 | , Nullable 7 | ) 8 | where 9 | 10 | import Database.Esqueleto.Internal.Internal hiding (From(..), from, on) 11 | import Database.Esqueleto.Internal.PersistentImport (Entity(..)) 12 | 13 | class ToMaybe a where 14 | type ToMaybeT a 15 | toMaybe :: a -> ToMaybeT a 16 | 17 | instance ToMaybe (SqlExpr (Maybe a)) where 18 | type ToMaybeT (SqlExpr (Maybe a)) = SqlExpr (Maybe a) 19 | toMaybe = id 20 | 21 | instance ToMaybe (SqlExpr (Entity a)) where 22 | type ToMaybeT (SqlExpr (Entity a)) = SqlExpr (Maybe (Entity a)) 23 | toMaybe (ERaw f m) = (ERaw f m) 24 | 25 | instance ToMaybe (SqlExpr (Value a)) where 26 | type ToMaybeT (SqlExpr (Value a)) = SqlExpr (Value (Maybe (Nullable a))) 27 | toMaybe = veryUnsafeCoerceSqlExprValue 28 | 29 | 30 | instance (ToMaybe a, ToMaybe b) => ToMaybe (a,b) where 31 | type ToMaybeT (a, b) = (ToMaybeT a, ToMaybeT b) 32 | toMaybe (a, b) = (toMaybe a, toMaybe b) 33 | 34 | instance ( ToMaybe a , ToMaybe b , ToMaybe c) => ToMaybe (a,b,c) where 35 | type ToMaybeT (a, b, c) = (ToMaybeT a, ToMaybeT b, ToMaybeT c) 36 | toMaybe = to3 . toMaybe . from3 37 | 38 | instance ( ToMaybe a , ToMaybe b , ToMaybe c , ToMaybe d) => ToMaybe (a,b,c,d) where 39 | type ToMaybeT (a, b, c, d) = (ToMaybeT a, ToMaybeT b, ToMaybeT c, ToMaybeT d) 40 | toMaybe = to4 . toMaybe . from4 41 | 42 | instance ( ToMaybe a , ToMaybe b , ToMaybe c , ToMaybe d , ToMaybe e) => ToMaybe (a,b,c,d,e) where 43 | type ToMaybeT (a, b, c, d, e) = (ToMaybeT a, ToMaybeT b, ToMaybeT c, ToMaybeT d, ToMaybeT e) 44 | toMaybe = to5 . toMaybe . from5 45 | 46 | instance ( ToMaybe a 47 | , ToMaybe b 48 | , ToMaybe c 49 | , ToMaybe d 50 | , ToMaybe e 51 | , ToMaybe f 52 | ) => ToMaybe (a,b,c,d,e,f) where 53 | type ToMaybeT (a, b, c, d, e, f) = (ToMaybeT a, ToMaybeT b, ToMaybeT c, ToMaybeT d, ToMaybeT e, ToMaybeT f) 54 | toMaybe = to6 . toMaybe . from6 55 | 56 | instance ( ToMaybe a 57 | , ToMaybe b 58 | , ToMaybe c 59 | , ToMaybe d 60 | , ToMaybe e 61 | , ToMaybe f 62 | , ToMaybe g 63 | ) => ToMaybe (a,b,c,d,e,f,g) where 64 | type ToMaybeT (a, b, c, d, e, f, g) = (ToMaybeT a, ToMaybeT b, ToMaybeT c, ToMaybeT d, ToMaybeT e, ToMaybeT f, ToMaybeT g) 65 | toMaybe = to7 . toMaybe . from7 66 | 67 | instance ( ToMaybe a 68 | , ToMaybe b 69 | , ToMaybe c 70 | , ToMaybe d 71 | , ToMaybe e 72 | , ToMaybe f 73 | , ToMaybe g 74 | , ToMaybe h 75 | ) => ToMaybe (a,b,c,d,e,f,g,h) where 76 | type ToMaybeT (a, b, c, d, e, f, g, h) = (ToMaybeT a, ToMaybeT b, ToMaybeT c, ToMaybeT d, ToMaybeT e, ToMaybeT f, ToMaybeT g, ToMaybeT h) 77 | toMaybe = to8 . toMaybe . from8 78 | 79 | -------------------------------------------------------------------------------- /src/Database/Esqueleto/Internal/ExprParser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | 4 | -- | This is an internal module. This module may have breaking changes without 5 | -- a corresponding major version bump. If you use this module, please open an 6 | -- issue with your use-case so we can safely support it. 7 | module Database.Esqueleto.Internal.ExprParser where 8 | 9 | import Prelude hiding (takeWhile) 10 | 11 | import Control.Applicative ((<|>)) 12 | import Control.Monad (void) 13 | import Data.Attoparsec.Text 14 | import Data.Set (Set) 15 | import qualified Data.Set as Set 16 | import Data.Text (Text) 17 | import qualified Data.Text as Text 18 | import Database.Persist.Sql 19 | import Database.Persist.SqlBackend 20 | 21 | -- | A type representing the access of a table value. In Esqueleto, we get 22 | -- a guarantee that the access will look something like: 23 | -- 24 | -- @ 25 | -- escape-char [character] escape-char . escape-char [character] escape-char 26 | -- ^^^^^^^^^^^ ^^^^^^^^^^^ 27 | -- table name column name 28 | -- @ 29 | data TableAccess = TableAccess 30 | { tableAccessTable :: Text 31 | , tableAccessColumn :: Text 32 | } 33 | deriving (Eq, Ord, Show) 34 | 35 | -- | Parse a @SqlExpr (Value Bool)@'s textual representation into a list of 36 | -- 'TableAccess' 37 | parseOnExpr :: SqlBackend -> Text -> Either String (Set TableAccess) 38 | parseOnExpr sqlBackend text = do 39 | c <- mkEscapeChar sqlBackend 40 | parseOnly (onExpr c) text 41 | 42 | -- | This function uses the 'connEscapeName' function in the 'SqlBackend' with an 43 | -- empty identifier to pull out an escape character. This implementation works 44 | -- with postgresql, mysql, and sqlite backends. 45 | mkEscapeChar :: SqlBackend -> Either String Char 46 | mkEscapeChar sqlBackend = 47 | case Text.uncons (getEscapedRawName "" sqlBackend) of 48 | Nothing -> 49 | Left "Failed to get an escape character from the SQL backend." 50 | Just (c, _) -> 51 | Right c 52 | 53 | type ExprParser a = Char -> Parser a 54 | 55 | onExpr :: ExprParser (Set TableAccess) 56 | onExpr e = Set.fromList <$> many' tableAccesses 57 | where 58 | tableAccesses = do 59 | skipToEscape e "Skipping to an escape char" 60 | parseTableAccess e "Parsing a table access" 61 | 62 | skipToEscape :: ExprParser () 63 | skipToEscape escapeChar = void (takeWhile (/= escapeChar)) 64 | 65 | parseEscapedIdentifier :: ExprParser [Char] 66 | parseEscapedIdentifier escapeChar = do 67 | _ <- char escapeChar 68 | str <- parseEscapedChars escapeChar 69 | _ <- char escapeChar 70 | pure str 71 | 72 | parseTableAccess :: ExprParser TableAccess 73 | parseTableAccess ec = do 74 | tableAccessTable <- Text.pack <$> parseEscapedIdentifier ec 75 | _ <- char '.' 76 | tableAccessColumn <- Text.pack <$> parseEscapedIdentifier ec 77 | pure TableAccess {..} 78 | 79 | parseEscapedChars :: ExprParser [Char] 80 | parseEscapedChars escapeChar = go 81 | where 82 | twoEscapes = char escapeChar *> char escapeChar 83 | go = many' (notChar escapeChar <|> twoEscapes) 84 | -------------------------------------------------------------------------------- /src/Database/Esqueleto/Internal/PersistentImport.hs: -------------------------------------------------------------------------------- 1 | {-# language CPP #-} 2 | 3 | -- | Re-export "Database.Persist.Sql" without any clashes with 4 | -- @esqueleto@. 5 | module Database.Esqueleto.Internal.PersistentImport 6 | (module Database.Persist.Sql) where 7 | 8 | import Database.Persist.Sql hiding 9 | ( BackendSpecificFilter 10 | , Filter(..) 11 | , PersistQuery 12 | , SelectOpt(..) 13 | , Update(..) 14 | , count 15 | , delete 16 | , deleteWhereCount 17 | , exists 18 | , getPersistMap 19 | , limitOffsetOrder 20 | , listToJSON 21 | , mapToJSON 22 | , selectKeysList 23 | , selectList 24 | , selectSource 25 | , update 26 | , updateWhereCount 27 | , (!=.) 28 | , (*=.) 29 | , (+=.) 30 | , (-=.) 31 | , (/<-.) 32 | , (/=.) 33 | , (<-.) 34 | , (<.) 35 | , (<=.) 36 | , (=.) 37 | , (==.) 38 | , (>.) 39 | , (>=.) 40 | , (||.) 41 | ) 42 | -------------------------------------------------------------------------------- /src/Database/Esqueleto/Legacy.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | 6 | -- | WARNING 7 | -- 8 | -- This module is introduced in version @3.5.0.0@ to provide a smooth migration 9 | -- experience from this legacy syntax to the new and improved syntax. If you've 10 | -- imported this module, it means you've decided to use the old syntax for 11 | -- a little bit longer, rather than migrate to the new stuff. That's fine! 12 | -- 13 | -- But you should know that this module, and all of the legacy syntax, will be 14 | -- completely removed from the library in version @4.0.0.0@. 15 | -- 16 | -- The @esqueleto@ EDSL (embedded domain specific language). 17 | -- This module replaces @Database.Persist@, so instead of 18 | -- importing that module you should just import this one: 19 | -- 20 | -- @ 21 | -- -- For a module using just esqueleto. 22 | -- import Database.Esqueleto 23 | -- @ 24 | -- 25 | -- If you need to use @persistent@'s default support for queries 26 | -- as well, either import it qualified: 27 | -- 28 | -- @ 29 | -- -- For a module that mostly uses esqueleto. 30 | -- import Database.Esqueleto 31 | -- import qualified Database.Persist as P 32 | -- @ 33 | -- 34 | -- or import @esqueleto@ itself qualified: 35 | -- 36 | -- @ 37 | -- -- For a module that uses esqueleto just on some queries. 38 | -- import Database.Persist 39 | -- import qualified Database.Esqueleto as E 40 | -- @ 41 | -- 42 | -- Other than identifier name clashes, @esqueleto@ does not 43 | -- conflict with @persistent@ in any way. 44 | module Database.Esqueleto.Legacy 45 | ( -- * Setup 46 | -- $setup 47 | 48 | -- * Introduction 49 | -- $introduction 50 | 51 | -- * Getting started 52 | -- $gettingstarted 53 | 54 | -- * @esqueleto@'s Language 55 | where_, on, groupBy, orderBy, asc, desc, limit, offset 56 | , distinct, distinctOn, don, distinctOnOrderBy, having, locking 57 | , (^.), (?.) 58 | , val, isNothing, just, just', nothing, joinV, joinV', withNonNull 59 | , countRows, count, countDistinct 60 | , not_, (==.), (>=.), (>.), (<=.), (<.), (!=.), (&&.), (||.) 61 | , between, (+.), (-.), (/.), (*.) 62 | , round_, ceiling_, floor_ 63 | , min_, max_, sum_, avg_, castNum, castNumM 64 | , coalesce, coalesceDefault 65 | , lower_, upper_, trim_, ltrim_, rtrim_, length_, left_, right_ 66 | , like, ilike, (%), concat_, (++.), castString 67 | , subList_select, valList, justList 68 | , in_, notIn, exists, notExists 69 | , set, (=.), (+=.), (-=.), (*=.), (/=.) 70 | , case_, toBaseId, fromBaseId, fromBaseIdMaybe, toBaseIdMaybe 71 | , subSelect 72 | , subSelectMaybe 73 | , subSelectCount 74 | , subSelectForeign 75 | , subSelectList 76 | , subSelectUnsafe 77 | , ToBaseId(..) 78 | , when_ 79 | , then_ 80 | , else_ 81 | , from 82 | , Value(..) 83 | , ValueList(..) 84 | , OrderBy 85 | , DistinctOn 86 | , LockingKind(..) 87 | , forUpdate 88 | , forUpdateSkipLocked 89 | , LockableEntity(..) 90 | , SqlString 91 | -- ** Joins 92 | , InnerJoin(..) 93 | , CrossJoin(..) 94 | , LeftOuterJoin(..) 95 | , RightOuterJoin(..) 96 | , FullOuterJoin(..) 97 | , JoinKind(..) 98 | , OnClauseWithoutMatchingJoinException(..) 99 | -- * SQL backend 100 | , SqlQuery 101 | , SqlExpr 102 | , SqlEntity 103 | , select 104 | , selectOne 105 | , selectSource 106 | , delete 107 | , deleteCount 108 | , update 109 | , updateCount 110 | , insertSelect 111 | , insertSelectCount 112 | , (<#) 113 | , (<&>) 114 | -- ** Rendering Queries 115 | , renderQueryToText 116 | , renderQuerySelect 117 | , renderQueryUpdate 118 | , renderQueryDelete 119 | , renderQueryInsertInto 120 | -- * Internal.Language 121 | , From 122 | -- * RDBMS-specific modules 123 | -- $rdbmsSpecificModules 124 | 125 | -- * Helpers 126 | , valkey 127 | , valJ 128 | , associateJoin 129 | 130 | -- * Re-exports 131 | -- $reexports 132 | , deleteKey 133 | , module Database.Esqueleto.Internal.PersistentImport 134 | ) where 135 | 136 | import Database.Esqueleto.Internal.Internal 137 | import Database.Esqueleto.Internal.PersistentImport 138 | 139 | 140 | -- $setup 141 | -- 142 | -- If you're already using @persistent@, then you're ready to use 143 | -- @esqueleto@, no further setup is needed. If you're just 144 | -- starting a new project and would like to use @esqueleto@, take 145 | -- a look at @persistent@'s book first 146 | -- () to learn how to 147 | -- define your schema. 148 | 149 | 150 | ---------------------------------------------------------------------- 151 | 152 | 153 | -- $introduction 154 | -- 155 | -- The main goals of @esqueleto@ are to: 156 | -- 157 | -- * Be easily translatable to SQL. When you take a look at a 158 | -- @esqueleto@ query, you should be able to know exactly how 159 | -- the SQL query will end up. (As opposed to being a 160 | -- relational algebra EDSL such as HaskellDB, which is 161 | -- non-trivial to translate into SQL.) 162 | -- 163 | -- * Support the most widely used SQL features. We'd like you to be 164 | -- able to use @esqueleto@ for all of your queries, no 165 | -- exceptions. Send a pull request or open an issue on our 166 | -- project page () if 167 | -- there's anything missing that you'd like to see. 168 | -- 169 | -- * Be as type-safe as possible. We strive to provide as many 170 | -- type checks as possible. If you get bitten by some invalid 171 | -- code that type-checks, please open an issue on our project 172 | -- page so we can take a look. 173 | -- 174 | -- However, it is /not/ a goal to be able to write portable SQL. 175 | -- We do not try to hide the differences between DBMSs from you, 176 | -- and @esqueleto@ code that works for one database may not work 177 | -- on another. This is a compromise we have to make in order to 178 | -- give you as much control over the raw SQL as possible without 179 | -- losing too much convenience. This also means that you may 180 | -- type-check a query that doesn't work on your DBMS. 181 | 182 | 183 | ---------------------------------------------------------------------- 184 | 185 | 186 | -- $gettingstarted 187 | -- 188 | -- We like clean, easy-to-read EDSLs. However, in order to 189 | -- achieve this goal we've used a lot of type hackery, leading to 190 | -- some hard-to-read type signatures. On this section, we'll try 191 | -- to build some intuition about the syntax. 192 | -- 193 | -- For the following examples, we'll use this example schema: 194 | -- 195 | -- @ 196 | -- share [mkPersist sqlSettings, mkMigrate \"migrateAll\"] [persist| 197 | -- Person 198 | -- name String 199 | -- age Int Maybe 200 | -- deriving Eq Show 201 | -- BlogPost 202 | -- title String 203 | -- authorId PersonId 204 | -- deriving Eq Show 205 | -- Follow 206 | -- follower PersonId 207 | -- followed PersonId 208 | -- deriving Eq Show 209 | -- |] 210 | -- @ 211 | -- 212 | -- Most of @esqueleto@ was created with @SELECT@ statements in 213 | -- mind, not only because they're the most common but also 214 | -- because they're the most complex kind of statement. The most 215 | -- simple kind of @SELECT@ would be: 216 | -- 217 | -- @ 218 | -- SELECT * 219 | -- FROM Person 220 | -- @ 221 | -- 222 | -- In @esqueleto@, we may write the same query above as: 223 | -- 224 | -- @ 225 | -- do people <- 'select' $ 226 | -- 'from' $ \\person -> do 227 | -- return person 228 | -- liftIO $ mapM_ (putStrLn . personName . entityVal) people 229 | -- @ 230 | -- 231 | -- The expression above has type @SqlPersist m ()@, while 232 | -- @people@ has type @[Entity Person]@. The query above will be 233 | -- translated into exactly the same query we wrote manually, but 234 | -- instead of @SELECT *@ it will list all entity fields (using 235 | -- @*@ is not robust). Note that @esqueleto@ knows that we want 236 | -- an @Entity Person@ just because of the @personName@ that we're 237 | -- printing later. 238 | -- 239 | -- However, most of the time we need to filter our queries using 240 | -- @WHERE@. For example: 241 | -- 242 | -- @ 243 | -- SELECT * 244 | -- FROM Person 245 | -- WHERE Person.name = \"John\" 246 | -- @ 247 | -- 248 | -- In @esqueleto@, we may write the same query above as: 249 | -- 250 | -- @ 251 | -- 'select' $ 252 | -- 'from' $ \\p -> do 253 | -- 'where_' (p '^.' PersonName '==.' 'val' \"John\") 254 | -- return p 255 | -- @ 256 | -- 257 | -- Although @esqueleto@'s code is a bit more noisy, it's has 258 | -- almost the same structure (save from the @return@). The 259 | -- @('^.')@ operator is used to project a field from an entity. 260 | -- The field name is the same one generated by @persistent@'s 261 | -- Template Haskell functions. We use 'val' to lift a constant 262 | -- Haskell value into the SQL query. 263 | -- 264 | -- Another example would be: 265 | -- 266 | -- @ 267 | -- SELECT * 268 | -- FROM Person 269 | -- WHERE Person.age >= 18 270 | -- @ 271 | -- 272 | -- In @esqueleto@, we may write the same query above as: 273 | -- 274 | -- @ 275 | -- 'select' $ 276 | -- 'from' $ \\p -> do 277 | -- 'where_' (p '^.' PersonAge '>=.' 'just' ('val' 18)) 278 | -- return p 279 | -- @ 280 | -- 281 | -- Since @age@ is an optional @Person@ field, we use 'just' to lift 282 | -- @'val' 18 :: SqlExpr (Value Int)@ into @just ('val' 18) :: 283 | -- SqlExpr (Value (Maybe Int))@. 284 | -- 285 | -- Implicit joins are represented by tuples. For example, to get 286 | -- the list of all blog posts and their authors, we could write: 287 | -- 288 | -- @ 289 | -- SELECT BlogPost.*, Person.* 290 | -- FROM BlogPost, Person 291 | -- WHERE BlogPost.authorId = Person.id 292 | -- ORDER BY BlogPost.title ASC 293 | -- @ 294 | -- 295 | -- In @esqueleto@, we may write the same query above as: 296 | -- 297 | -- @ 298 | -- 'select' $ 299 | -- 'from' $ \\(b, p) -> do 300 | -- 'where_' (b '^.' BlogPostAuthorId '==.' p '^.' PersonId) 301 | -- 'orderBy' ['asc' (b '^.' BlogPostTitle)] 302 | -- return (b, p) 303 | -- @ 304 | -- 305 | -- However, you may want your results to include people who don't 306 | -- have any blog posts as well using a @LEFT OUTER JOIN@: 307 | -- 308 | -- @ 309 | -- SELECT Person.*, BlogPost.* 310 | -- FROM Person LEFT OUTER JOIN BlogPost 311 | -- ON Person.id = BlogPost.authorId 312 | -- ORDER BY Person.name ASC, BlogPost.title ASC 313 | -- @ 314 | -- 315 | -- In @esqueleto@, we may write the same query above as: 316 | -- 317 | -- @ 318 | -- 'select' $ 319 | -- 'from' $ \\(p `'LeftOuterJoin`` mb) -> do 320 | -- 'on' ('just' (p '^.' PersonId) '==.' mb '?.' BlogPostAuthorId) 321 | -- 'orderBy' ['asc' (p '^.' PersonName), 'asc' (mb '?.' BlogPostTitle)] 322 | -- return (p, mb) 323 | -- @ 324 | -- 325 | -- On a @LEFT OUTER JOIN@ the entity on the right hand side may 326 | -- not exist (i.e. there may be a @Person@ without any 327 | -- @BlogPost@s), so while @p :: SqlExpr (Entity Person)@, we have 328 | -- @mb :: SqlExpr (Maybe (Entity BlogPost))@. The whole 329 | -- expression above has type @SqlPersist m [(Entity Person, Maybe 330 | -- (Entity BlogPost))]@. Instead of using @(^.)@, we used 331 | -- @('?.')@ to project a field from a @Maybe (Entity a)@. 332 | -- 333 | -- We are by no means limited to joins of two tables, nor by 334 | -- joins of different tables. For example, we may want a list 335 | -- of the @Follow@ entity: 336 | -- 337 | -- @ 338 | -- SELECT P1.*, Follow.*, P2.* 339 | -- FROM Person AS P1 340 | -- INNER JOIN Follow ON P1.id = Follow.follower 341 | -- INNER JOIN Person AS P2 ON P2.id = Follow.followed 342 | -- @ 343 | -- 344 | -- In @esqueleto@, we may write the same query above as: 345 | -- 346 | -- @ 347 | -- 'select' $ 348 | -- 'from' $ \\(p1 `'InnerJoin`` f `'InnerJoin`` p2) -> do 349 | -- 'on' (p1 '^.' PersonId '==.' f '^.' FollowFollower) 350 | -- 'on' (p2 '^.' PersonId '==.' f '^.' FollowFollowed) 351 | -- return (p1, f, p2) 352 | -- @ 353 | -- 354 | -- We also currently support @UPDATE@ and @DELETE@ statements. 355 | -- For example: 356 | -- 357 | -- @ 358 | -- do 'update' $ \\p -> do 359 | -- 'set' p [ PersonName '=.' 'val' \"João\" ] 360 | -- 'where_' (p '^.' PersonName '==.' 'val' \"Joao\") 361 | -- 'delete' $ 362 | -- 'from' $ \\p -> do 363 | -- 'where_' (p '^.' PersonAge '<.' 'just' ('val' 14)) 364 | -- @ 365 | -- 366 | -- The results of queries can also be used for insertions. 367 | -- In @SQL@, we might write the following, inserting a new blog 368 | -- post for every user: 369 | -- 370 | -- @ 371 | -- INSERT INTO BlogPost 372 | -- SELECT ('Group Blog Post', id) 373 | -- FROM Person 374 | -- @ 375 | -- 376 | -- In @esqueleto@, we may write the same query above as: 377 | -- 378 | -- @ 379 | -- 'insertSelect' $ 'from' $ \\p-> 380 | -- return $ BlogPost '<#' \"Group Blog Post\" '<&>' (p '^.' PersonId) 381 | -- @ 382 | -- 383 | -- Individual insertions can be performed through Persistent's 384 | -- 'insert' function, reexported for convenience. 385 | 386 | 387 | ---------------------------------------------------------------------- 388 | 389 | 390 | -- $reexports 391 | -- 392 | -- We re-export many symbols from @persistent@ for convenince: 393 | -- 394 | -- * \"Store functions\" from "Database.Persist". 395 | -- 396 | -- * Everything from "Database.Persist.Class" except for 397 | -- @PersistQuery@ and @delete@ (use 'deleteKey' instead). 398 | -- 399 | -- * Everything from "Database.Persist.Types" except for 400 | -- @Update@, @SelectOpt@, @BackendSpecificFilter@ and @Filter@. 401 | -- 402 | -- * Everything from "Database.Persist.Sql" except for 403 | -- @deleteWhereCount@ and @updateWhereCount@. 404 | 405 | 406 | ---------------------------------------------------------------------- 407 | 408 | 409 | -- $rdbmsSpecificModules 410 | -- 411 | -- There are many differences between SQL syntax and functions 412 | -- supported by different RDBMSs. Since version 2.2.8, 413 | -- @esqueleto@ includes modules containing functions that are 414 | -- specific to a given RDBMS. 415 | -- 416 | -- * PostgreSQL: "Database.Esqueleto.PostgreSQL". 417 | -- 418 | -- In order to use these functions, you need to explicitly import 419 | -- their corresponding modules, they're not re-exported here. 420 | -------------------------------------------------------------------------------- /src/Database/Esqueleto/MySQL.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | -- | This module contain MySQL-specific functions. 4 | -- 5 | -- @since 2.2.8 6 | module Database.Esqueleto.MySQL 7 | ( random_ 8 | , lockInShareMode 9 | ) where 10 | 11 | import Database.Esqueleto.Internal.Internal hiding (random_) 12 | import Database.Esqueleto.Internal.PersistentImport 13 | 14 | -- | (@random()@) Split out into database specific modules 15 | -- because MySQL uses `rand()`. 16 | -- 17 | -- @since 2.6.0 18 | random_ :: (PersistField a, Num a) => SqlExpr (Value a) 19 | random_ = unsafeSqlValue "RAND()" 20 | 21 | -- | @LOCK IN SHARE MODE@ syntax. 22 | -- 23 | -- Example: 24 | -- 25 | -- @ 26 | -- 'locking' 'lockInShareMode' 27 | -- @ 28 | -- 29 | -- @since 3.6.0.0 30 | lockInShareMode :: LockingKind 31 | lockInShareMode = LockInShareMode 32 | -------------------------------------------------------------------------------- /src/Database/Esqueleto/PostgreSQL/JSON/Instances.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFoldable #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE DeriveTraversable #-} 5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# language DerivingStrategies #-} 8 | 9 | module Database.Esqueleto.PostgreSQL.JSON.Instances where 10 | 11 | import Data.Aeson (FromJSON(..), ToJSON(..), encode, eitherDecodeStrict) 12 | import Data.Bifunctor (first) 13 | import qualified Data.ByteString.Lazy as BSL (toStrict) 14 | import Data.String (IsString(..)) 15 | import Data.Text (Text) 16 | import qualified Data.Text as T (concat, pack) 17 | import qualified Data.Text.Encoding as TE (decodeUtf8, encodeUtf8) 18 | import Database.Esqueleto.Internal.PersistentImport 19 | import Database.Esqueleto.Internal.Internal (SqlExpr, Value, just, val) 20 | import GHC.Generics (Generic) 21 | 22 | -- | Newtype wrapper around any type with a JSON representation. 23 | -- 24 | -- @since 3.1.0 25 | newtype JSONB a = JSONB { unJSONB :: a } 26 | deriving stock 27 | ( Generic 28 | , Eq 29 | , Foldable 30 | , Functor 31 | , Ord 32 | , Read 33 | , Show 34 | , Traversable 35 | ) 36 | deriving newtype 37 | ( FromJSON 38 | , ToJSON 39 | ) 40 | 41 | -- | 'SqlExpr' of a NULL-able 'JSONB' value. Hence the 'Maybe'. 42 | -- 43 | -- Note: NULL here is a PostgreSQL NULL, not a JSON 'null' 44 | type JSONBExpr a = SqlExpr (Value (Maybe (JSONB a))) 45 | 46 | -- | Convenience function to lift a regular value into 47 | -- a 'JSONB' expression. 48 | jsonbVal :: (FromJSON a, ToJSON a) => a -> JSONBExpr a 49 | jsonbVal = just . val . JSONB 50 | 51 | -- | Used with certain JSON operators. 52 | -- 53 | -- This data type has 'Num' and 'IsString' instances 54 | -- for ease of use by using integer and string literals. 55 | -- 56 | -- >>> 3 :: JSONAccessor 57 | -- JSONIndex 3 58 | -- >>> -3 :: JSONAccessor 59 | -- JSONIndex -3 60 | -- 61 | -- >>> "name" :: JSONAccessor 62 | -- JSONKey "name" 63 | -- 64 | -- NOTE: DO NOT USE ANY OF THE 'Num' METHODS ON THIS TYPE! 65 | data JSONAccessor 66 | = JSONIndex Int 67 | | JSONKey Text 68 | deriving (Generic, Eq, Show) 69 | 70 | -- | I repeat, DO NOT use any method other than 'fromInteger'! 71 | instance Num JSONAccessor where 72 | fromInteger = JSONIndex . fromInteger 73 | negate (JSONIndex i) = JSONIndex $ negate i 74 | negate (JSONKey _) = error "Can not negate a JSONKey" 75 | (+) = numErr 76 | (-) = numErr 77 | (*) = numErr 78 | abs = numErr 79 | signum = numErr 80 | 81 | numErr :: a 82 | numErr = error "Do not use 'Num' methods on JSONAccessors" 83 | 84 | instance IsString JSONAccessor where 85 | fromString = JSONKey . T.pack 86 | 87 | -- | @since 3.1.0 88 | instance (FromJSON a, ToJSON a) => PersistField (JSONB a) where 89 | toPersistValue = PersistLiteralEscaped . BSL.toStrict . encode . unJSONB 90 | fromPersistValue pVal = fmap JSONB $ case pVal of 91 | PersistByteString bs -> first (badParse $ TE.decodeUtf8 bs) $ eitherDecodeStrict bs 92 | PersistText t -> first (badParse t) $ eitherDecodeStrict (TE.encodeUtf8 t) 93 | x -> Left $ fromPersistValueError "string or bytea" x 94 | 95 | -- | jsonb 96 | -- 97 | -- @since 3.1.0 98 | instance (FromJSON a, ToJSON a) => PersistFieldSql (JSONB a) where 99 | sqlType _ = SqlOther "JSONB" 100 | 101 | badParse :: Text -> String -> Text 102 | badParse t = fromPersistValueParseError t . T.pack 103 | 104 | fromPersistValueError 105 | :: Text -- ^ Database type(s), should appear different from Haskell name, e.g. "integer" or "INT", not "Int". 106 | -> PersistValue -- ^ Incorrect value 107 | -> Text -- ^ Error message 108 | fromPersistValueError databaseType received = T.concat 109 | [ "Failed to parse Haskell newtype `JSONB a`; " 110 | , "expected ", databaseType 111 | , " from database, but received: ", T.pack (show received) 112 | , ". Potential solution: Check that your database schema matches your Persistent model definitions." 113 | ] 114 | 115 | fromPersistValueParseError 116 | :: Text -- ^ Received value 117 | -> Text -- ^ Additional error 118 | -> Text -- ^ Error message 119 | fromPersistValueParseError received err = T.concat 120 | [ "Failed to parse Haskell type `JSONB a`, " 121 | , "but received ", received 122 | , " | with error: ", err 123 | ] 124 | -------------------------------------------------------------------------------- /src/Database/Esqueleto/SQLite.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | -- | This module contain SQLite-specific functions. 4 | -- 5 | -- @since 2.2.8 6 | module Database.Esqueleto.SQLite 7 | ( random_ 8 | ) where 9 | 10 | import Database.Esqueleto.Internal.Internal hiding (random_) 11 | import Database.Esqueleto.Internal.PersistentImport 12 | 13 | -- | (@random()@) Split out into database specific modules 14 | -- because MySQL uses `rand()`. 15 | -- 16 | -- /Since: 2.6.0/ 17 | random_ :: (PersistField a, Num a) => SqlExpr (Value a) 18 | random_ = unsafeSqlValue "RANDOM()" 19 | -------------------------------------------------------------------------------- /stack-8.10.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-18.28 2 | 3 | packages: 4 | - '.' 5 | - 'examples' 6 | 7 | allow-newer: true 8 | 9 | extra-deps: 10 | - lift-type-0.1.0.1 11 | - persistent-2.14.0.2 12 | 13 | nix: 14 | packages: [zlib, libmysqlclient, pcre, postgresql] 15 | -------------------------------------------------------------------------------- /stack-8.2.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-10.6 2 | 3 | packages: 4 | - '.' 5 | 6 | extra-deps: 7 | - aeson-1.4.1.0 8 | - aeson-compat-0.3.8 9 | - attoparsec-0.13.2.2 10 | - case-insensitive-1.2.0.11 11 | - conduit-1.3.0 12 | - conduit-extra-1.3.0 13 | - hashable-1.2.7.0 14 | - monad-logger-0.3.28.1 15 | - persistent-2.10.0 16 | - persistent-mysql-2.10.0 17 | - persistent-postgresql-2.10.0 18 | - persistent-sqlite-2.10.0 19 | - persistent-template-2.7.0 20 | - postgresql-libpq-0.9.4.2 21 | - postgresql-simple-0.6.1 22 | - resourcet-1.2.0 23 | - scientific-0.3.6.2 24 | - text-1.2.3.0 25 | - unliftio-0.2.0.0 26 | 27 | nix: 28 | packages: [zlib, libmysqlclient, pcre, postgresql] 29 | -------------------------------------------------------------------------------- /stack-8.4.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-12.2 2 | 3 | packages: 4 | - '.' 5 | 6 | extra-deps: 7 | - aeson-1.4.1.0 8 | - persistent-2.10.0 9 | - persistent-postgresql-2.10.0 10 | - persistent-sqlite-2.10.0 11 | - persistent-mysql-2.10.0 12 | - persistent-template-2.7.0 13 | - postgresql-libpq-0.9.4.2 14 | - postgresql-simple-0.6.1 15 | - transformers-0.5.5.2 16 | 17 | nix: 18 | packages: [zlib, libmysqlclient, pcre, postgresql] 19 | -------------------------------------------------------------------------------- /stack-8.6.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-13.6 2 | 3 | packages: 4 | - '.' 5 | - 'examples' 6 | 7 | allow-newer: true 8 | 9 | extra-deps: 10 | - persistent-2.14.0.1 11 | - persistent-postgresql-2.13.5.0 12 | - persistent-mysql-2.13.0.0 13 | - persistent-sqlite-2.13.0.0 14 | - postgresql-simple-0.6.4 15 | - postgresql-libpq-0.9.4.3 16 | - time-compat-1.9.6.1 17 | - base-orphans-0.8.6 18 | - hashable-1.2.7.0 19 | - lift-type-0.1.0.1 20 | - th-lift-instances-0.1.19 21 | - th-lift-0.8.2 22 | 23 | nix: 24 | packages: [zlib, libmysqlclient, pcre, postgresql] 25 | -------------------------------------------------------------------------------- /stack-8.8.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-16.31 2 | 3 | packages: 4 | - '.' 5 | - 'examples' 6 | 7 | extra-deps: 8 | - persistent-2.12.0.1 9 | - persistent-template-2.12.0.0 10 | - persistent-mysql-2.12.0.0 11 | - persistent-postgresql-2.12.0.0 12 | - persistent-sqlite-2.12.0.0 13 | 14 | nix: 15 | packages: [zlib, libmysqlclient, pcre, postgresql] 16 | -------------------------------------------------------------------------------- /stack-8.8.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: 7 | - completed: 8 | subdir: persistent 9 | name: persistent 10 | version: 2.11.0.0 11 | git: https://github.com/yesodweb/persistent 12 | pantry-tree: 13 | size: 2099 14 | sha256: cd4d895557a60b40543c4a6804d32346a1c14c39e28658bb6852d8f4904ef1de 15 | commit: 0b8f9f3305c9b60c947565de882abfbfd8cb5702 16 | original: 17 | subdir: persistent 18 | git: https://github.com/yesodweb/persistent 19 | commit: 0b8f9f3305c9b60c947565de882abfbfd8cb5702 20 | - completed: 21 | subdir: persistent-template 22 | name: persistent-template 23 | version: '2.9' 24 | git: https://github.com/yesodweb/persistent 25 | pantry-tree: 26 | size: 620 27 | sha256: 0602872c9c38ccc6966b4a1fd1d102a345f94ad855077157d588536ee6803343 28 | commit: 0b8f9f3305c9b60c947565de882abfbfd8cb5702 29 | original: 30 | subdir: persistent-template 31 | git: https://github.com/yesodweb/persistent 32 | commit: 0b8f9f3305c9b60c947565de882abfbfd8cb5702 33 | - completed: 34 | subdir: persistent-mysql 35 | name: persistent-mysql 36 | version: 2.10.3 37 | git: https://github.com/yesodweb/persistent 38 | pantry-tree: 39 | size: 577 40 | sha256: a3b9d2ef77af25dca203a4dbe2857b6a1d4e421bbe376f261288e9a8ebfda28f 41 | commit: 0b8f9f3305c9b60c947565de882abfbfd8cb5702 42 | original: 43 | subdir: persistent-mysql 44 | git: https://github.com/yesodweb/persistent 45 | commit: 0b8f9f3305c9b60c947565de882abfbfd8cb5702 46 | - completed: 47 | subdir: persistent-postgresql 48 | name: persistent-postgresql 49 | version: 2.11.0.0 50 | git: https://github.com/yesodweb/persistent 51 | pantry-tree: 52 | size: 907 53 | sha256: 6f1ad1c5b0b22cf455c6b1b4551a749d21bb72042597450c8ef9ff1eb5a74782 54 | commit: 0b8f9f3305c9b60c947565de882abfbfd8cb5702 55 | original: 56 | subdir: persistent-postgresql 57 | git: https://github.com/yesodweb/persistent 58 | commit: 0b8f9f3305c9b60c947565de882abfbfd8cb5702 59 | - completed: 60 | subdir: persistent-sqlite 61 | name: persistent-sqlite 62 | version: 2.11.0.0 63 | git: https://github.com/yesodweb/persistent 64 | pantry-tree: 65 | size: 891 66 | sha256: fc9106077e16b406a5a823c732e3b543822a530f2befc446e49acf68797f6d42 67 | commit: 0b8f9f3305c9b60c947565de882abfbfd8cb5702 68 | original: 69 | subdir: persistent-sqlite 70 | git: https://github.com/yesodweb/persistent 71 | commit: 0b8f9f3305c9b60c947565de882abfbfd8cb5702 72 | snapshots: 73 | - completed: 74 | size: 532382 75 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/14.yaml 76 | sha256: 1ef27e36f38824abafc43224ca612211b3828fa9ffd31ba0fc2867ae2e19ba90 77 | original: lts-16.14 78 | -------------------------------------------------------------------------------- /stack-9.0.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-23.1 2 | 3 | packages: 4 | - '.' 5 | - 'examples' 6 | 7 | allow-newer: true 8 | 9 | extra-deps: 10 | - lift-type-0.1.0.1 11 | 12 | nix: 13 | packages: [zlib, libmysqlclient, pcre, postgresql] 14 | -------------------------------------------------------------------------------- /stack-nightly.yaml: -------------------------------------------------------------------------------- 1 | resolver: nightly-2022-03-29 2 | 3 | packages: 4 | - "." 5 | - 'examples' 6 | 7 | 8 | extra-deps: 9 | - time-1.12.1 10 | - base-compat-0.12.1 11 | - directory-1.3.7.0 12 | - process-1.6.14.0 13 | - Cabal-3.6.3.0 14 | - unix-2.7.2.2 15 | 16 | nix: 17 | packages: [zlib, libmysqlclient, pcre, postgresql] 18 | -------------------------------------------------------------------------------- /stack-nightly.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: 7 | - completed: 8 | hackage: time-1.12.1@sha256:af1fafc1fb66e3d0afb66fb5ab8629f74c038bebd42c234b581aff7abc201089,6295 9 | pantry-tree: 10 | size: 7208 11 | sha256: 96205222b57c39156ee646d710a4100a119dc28f211c57cacaf741f6c1bb35da 12 | original: 13 | hackage: time-1.12.1 14 | - completed: 15 | hackage: base-compat-0.12.1@sha256:20e50848d9dfee1523fafe8950060b04fae43d402c15553da5c7cacd116f7846,6960 16 | pantry-tree: 17 | size: 9038 18 | sha256: 2f2c14615443954f117613d77835234b598718e611fb4cf4522e01980bf1bcbd 19 | original: 20 | hackage: base-compat-0.12.1 21 | - completed: 22 | hackage: directory-1.3.7.0@sha256:d44788eac41268d951679fdcc343adc8a65fcf5b016bdf6c1f996bf78dde798e,2940 23 | pantry-tree: 24 | size: 3433 25 | sha256: 2352834a6424cc8b462706c15e08bb721e120829b147b6d798eade4ebce425f5 26 | original: 27 | hackage: directory-1.3.7.0 28 | - completed: 29 | hackage: process-1.6.14.0@sha256:b6ad76fd3f4bf133cdc2dc9176e23447f2a0a8e9316047d53154cd11f871446d,2845 30 | pantry-tree: 31 | size: 1544 32 | sha256: 72300155a8fd5a91f6b25dfebb77db05aa27a0b866dbfb2d7098c5e4580ca105 33 | original: 34 | hackage: process-1.6.14.0 35 | - completed: 36 | hackage: Cabal-3.6.3.0@sha256:ff97c442b0c679c1c9876acd15f73ac4f602b973c45bde42b43ec28265ee48f4,12459 37 | pantry-tree: 38 | size: 19757 39 | sha256: b250a53bdb56844f047a2927833bb565b936a289abfa85dfc2a63148d776368a 40 | original: 41 | hackage: Cabal-3.6.3.0 42 | - completed: 43 | hackage: unix-2.7.2.2@sha256:15f5365c5995634e45de1772b9504761504a310184e676bc2ef60a14536dbef9,3496 44 | pantry-tree: 45 | size: 3536 46 | sha256: 36434ced74d679622d61b69e8d92e1bd632d9ef3e284c63094653b2e473b0553 47 | original: 48 | hackage: unix-2.7.2.2 49 | snapshots: 50 | - completed: 51 | size: 539378 52 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2022/3/29.yaml 53 | sha256: c959441a05f6fa4d45ae6e258290f04d399245b8436263b4abb525c7f73da6a5 54 | original: nightly-2022-03-29 55 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | stack-9.0.yaml -------------------------------------------------------------------------------- /style-guide.md: -------------------------------------------------------------------------------- 1 | # Style Guide 2 | 3 | - Please use `stylish-haskell` on the project to keep imports consistent and 4 | clean. We have a custom [`.stylish-haskell.yaml`](.stylish-haskell.yaml) file. 5 | You can run `stylish-haskell` from vim with `:%! stylish-haskell`. 6 | - Four space indent. 7 | - Prefer indentation over any other form of alignment. 8 | - If text goes off the screen due to four space indentation, factor out 9 | functions and values into names to reduce indentation. 10 | -------------------------------------------------------------------------------- /test/Common/Test/CTE.hs: -------------------------------------------------------------------------------- 1 | {-# language TypeApplications #-} 2 | 3 | module Common.Test.CTE where 4 | 5 | import Common.Test.Models 6 | import Common.Test.Import 7 | import Database.Persist.TH 8 | 9 | testCTE :: SpecDb 10 | testCTE = describe "CTE" $ do 11 | itDb "can refer to the same CTE twice" $ do 12 | let q :: SqlQuery (SqlExpr (Value Int), SqlExpr (Value Int)) 13 | q = do 14 | bCte <- with $ do 15 | b <- from $ table @B 16 | pure b 17 | 18 | a :& b1 :& b2 <- from $ 19 | table @A 20 | `innerJoin` bCte 21 | `on` do 22 | \(a :& b) -> 23 | a ^. AK ==. b ^. BK 24 | `innerJoin` bCte 25 | `on` do 26 | \(a :& _ :& b2) -> 27 | a ^. AK ==. b2 ^. BK 28 | pure (a ^. AK, a ^. AV +. b1 ^. BV +. b2 ^. BV) 29 | insert_ $ A { aK = 1, aV = 2 } 30 | insert_ $ B { bK = 1, bV = 3 } 31 | ret <- select q 32 | asserting $ do 33 | ret `shouldMatchList` 34 | [ (Value 1, Value (2 + 3 + 3)) 35 | ] 36 | -------------------------------------------------------------------------------- /test/Common/Test/Import.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, AllowAmbiguousTypes #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE DerivingStrategies #-} 6 | {-# LANGUAGE EmptyDataDecls #-} 7 | {-# LANGUAGE FlexibleContexts #-} 8 | {-# LANGUAGE FlexibleInstances #-} 9 | {-# LANGUAGE GADTs #-} 10 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 11 | {-# LANGUAGE MultiParamTypeClasses #-} 12 | {-# LANGUAGE OverloadedStrings #-} 13 | {-# LANGUAGE PartialTypeSignatures #-} 14 | {-# LANGUAGE QuasiQuotes #-} 15 | {-# LANGUAGE ScopedTypeVariables #-} 16 | {-# LANGUAGE StandaloneDeriving #-} 17 | {-# LANGUAGE TemplateHaskell #-} 18 | {-# LANGUAGE TypeApplications #-} 19 | {-# LANGUAGE TypeFamilies #-} 20 | {-# LANGUAGE TypeSynonymInstances #-} 21 | {-# LANGUAGE UndecidableInstances #-} 22 | 23 | module Common.Test.Import 24 | ( module Common.Test.Import 25 | , module X 26 | ) where 27 | 28 | import System.Environment 29 | import Control.Applicative 30 | import Common.Test.Models as X 31 | import Database.Esqueleto.Experimental as X hiding (random_) 32 | import Test.Hspec as X 33 | import UnliftIO as X 34 | import Control.Monad 35 | import Test.QuickCheck 36 | import Data.Text as X (Text) 37 | import Control.Monad.Trans.Reader as X (ReaderT, mapReaderT, ask) 38 | 39 | type SpecDb = SpecWith ConnectionPool 40 | 41 | asserting :: MonadIO f => IO () -> SqlPersistT f () 42 | asserting a = liftIO a 43 | 44 | noExceptions :: Expectation 45 | noExceptions = pure () 46 | 47 | itDb 48 | :: (HasCallStack) 49 | => String 50 | -> SqlPersistT IO x 51 | -> SpecDb 52 | itDb message action = do 53 | it message $ \connection -> do 54 | void $ testDb connection action 55 | 56 | propDb 57 | :: (HasCallStack, Testable a) 58 | => String 59 | -> ((SqlPersistT IO () -> IO ()) -> a ) 60 | -> SpecDb 61 | propDb message action = do 62 | it message $ \connection -> do 63 | property (action (testDb connection)) 64 | 65 | testDb :: ConnectionPool -> SqlPersistT IO a -> IO a 66 | testDb conn action = 67 | liftIO $ flip runSqlPool conn $ do 68 | a <- action 69 | transactionUndo 70 | pure a 71 | 72 | setDatabaseState 73 | :: SqlPersistT IO a 74 | -> SqlPersistT IO () 75 | -> SpecWith ConnectionPool 76 | -> SpecWith ConnectionPool 77 | setDatabaseState create clean test = 78 | beforeWith (\conn -> runSqlPool create conn >> pure conn) $ 79 | after (\conn -> runSqlPool clean conn) $ 80 | test 81 | 82 | isCI :: IO Bool 83 | isCI = do 84 | env <- getEnvironment 85 | return $ case lookup "TRAVIS" env <|> lookup "CI" env of 86 | Just "true" -> True 87 | _ -> False 88 | -------------------------------------------------------------------------------- /test/Common/Test/Models.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE DerivingStrategies #-} 6 | {-# LANGUAGE EmptyDataDecls #-} 7 | {-# LANGUAGE FlexibleContexts #-} 8 | {-# LANGUAGE FlexibleInstances #-} 9 | {-# LANGUAGE GADTs #-} 10 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 11 | {-# LANGUAGE MultiParamTypeClasses #-} 12 | {-# LANGUAGE OverloadedStrings #-} 13 | {-# LANGUAGE PartialTypeSignatures #-} 14 | {-# LANGUAGE QuasiQuotes #-} 15 | {-# LANGUAGE ScopedTypeVariables #-} 16 | {-# LANGUAGE StandaloneDeriving #-} 17 | {-# LANGUAGE TemplateHaskell #-} 18 | {-# LANGUAGE TypeApplications #-} 19 | {-# LANGUAGE TypeFamilies #-} 20 | {-# LANGUAGE TypeSynonymInstances #-} 21 | {-# LANGUAGE UndecidableInstances #-} 22 | 23 | module Common.Test.Models where 24 | 25 | import Data.Time 26 | import Database.Esqueleto.Experimental 27 | import Database.Persist.Sql 28 | import Database.Persist.TH 29 | 30 | share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase| 31 | Foo 32 | name Int 33 | Primary name 34 | deriving Show Eq Ord 35 | Bar 36 | quux FooId 37 | deriving Show Eq Ord 38 | Baz 39 | blargh FooId 40 | deriving Show Eq 41 | Shoop 42 | baz BazId 43 | deriving Show Eq 44 | Asdf 45 | shoop ShoopId 46 | deriving Show Eq 47 | Another 48 | why BazId 49 | YetAnother 50 | argh ShoopId 51 | 52 | Person 53 | name String 54 | age Int Maybe 55 | weight Int Maybe 56 | favNum Int 57 | deriving Eq Show Ord 58 | BlogPost 59 | title String 60 | authorId PersonId 61 | deriving Eq Show 62 | Comment 63 | body String 64 | blog BlogPostId 65 | deriving Eq Show 66 | CommentReply 67 | body String 68 | comment CommentId 69 | Profile 70 | name String 71 | person PersonId 72 | deriving Eq Show 73 | Reply 74 | guy PersonId 75 | body String 76 | deriving Eq Show 77 | 78 | Lord 79 | county String maxlen=100 80 | dogs Int Maybe 81 | Primary county 82 | deriving Eq Show 83 | 84 | Deed 85 | contract String maxlen=100 86 | ownerId LordId maxlen=100 87 | Primary contract 88 | deriving Eq Show 89 | 90 | Follow 91 | follower PersonId 92 | followed PersonId 93 | deriving Eq Show 94 | 95 | CcList 96 | names [String] 97 | 98 | Frontcover 99 | number Int 100 | title String 101 | Primary number 102 | deriving Eq Show 103 | Article 104 | title String 105 | frontcoverNumber Int 106 | Foreign Frontcover fkfrontcover frontcoverNumber 107 | deriving Eq Show 108 | ArticleMetadata 109 | articleId ArticleId 110 | Primary articleId 111 | deriving Eq Show 112 | Tag 113 | name String maxlen=100 114 | Primary name 115 | deriving Eq Show 116 | ArticleTag 117 | articleId ArticleId 118 | tagId TagId maxlen=100 119 | Primary articleId tagId 120 | deriving Eq Show 121 | Article2 122 | title String 123 | frontcoverId FrontcoverId 124 | deriving Eq Show 125 | Point 126 | x Int 127 | y Int 128 | name String 129 | Primary x y 130 | deriving Eq Show 131 | Circle 132 | centerX Int 133 | centerY Int 134 | name String 135 | Foreign Point fkpoint centerX centerY 136 | deriving Eq Show 137 | Numbers 138 | int Int 139 | double Double 140 | deriving Eq Show 141 | 142 | JoinOne 143 | name String 144 | deriving Eq Show 145 | 146 | JoinTwo 147 | joinOne JoinOneId 148 | name String 149 | deriving Eq Show 150 | 151 | JoinThree 152 | joinTwo JoinTwoId 153 | name String 154 | deriving Eq Show 155 | 156 | JoinFour 157 | name String 158 | joinThree JoinThreeId 159 | deriving Eq Show 160 | 161 | JoinOther 162 | name String 163 | deriving Eq Show 164 | 165 | JoinMany 166 | name String 167 | joinOther JoinOtherId 168 | joinOne JoinOneId 169 | deriving Eq Show 170 | 171 | DateTruncTest 172 | created UTCTime 173 | deriving Eq Show 174 | 175 | User 176 | address AddressId Maybe 177 | name String 178 | deriving Show 179 | deriving Eq 180 | 181 | Address 182 | address String 183 | deriving Show 184 | deriving Eq 185 | 186 | A 187 | k Int 188 | v Int 189 | Primary k 190 | 191 | B 192 | k Int 193 | v Int 194 | Primary k 195 | |] 196 | 197 | -- Unique Test schema 198 | share [mkPersist sqlSettings, mkMigrate "migrateUnique"] [persistUpperCase| 199 | OneUnique 200 | name String 201 | value Int 202 | UniqueValue value 203 | deriving Eq Show 204 | |] 205 | 206 | 207 | instance ToBaseId ArticleMetadata where 208 | type BaseEnt ArticleMetadata = Article 209 | toBaseIdWitness articleId = ArticleMetadataKey articleId 210 | -------------------------------------------------------------------------------- /test/Common/Test/Select.hs: -------------------------------------------------------------------------------- 1 | module Common.Test.Select where 2 | 3 | import Common.Test.Import 4 | 5 | testSelect :: SpecDb 6 | testSelect = do 7 | describe "select" $ do 8 | itDb "works for a single value" $ do 9 | ret <- select $ return $ val (3 :: Int) 10 | asserting $ ret `shouldBe` [ Value 3 ] 11 | 12 | itDb "works for a pair of a single value and ()" $ do 13 | ret <- select $ return (val (3 :: Int), ()) 14 | asserting $ ret `shouldBe` [ (Value 3, ()) ] 15 | 16 | itDb "works for a single ()" $ do 17 | ret <- select $ return () 18 | asserting $ ret `shouldBe` [ () ] 19 | 20 | itDb "works for a single NULL value" $ do 21 | ret <- select $ return nothing 22 | asserting $ ret `shouldBe` [ Value (Nothing :: Maybe Int) ] 23 | -------------------------------------------------------------------------------- /test/MySQL/Test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | 7 | module MySQL.Test where 8 | 9 | import Common.Test.Import hiding (from, on) 10 | 11 | import Control.Applicative 12 | import Control.Monad (void) 13 | import Control.Monad.IO.Class (MonadIO(liftIO)) 14 | import Control.Monad.Logger (runNoLoggingT, runStderrLoggingT) 15 | import Control.Monad.Trans.Reader (ReaderT, mapReaderT) 16 | import qualified Control.Monad.Trans.Resource as R 17 | import Database.Esqueleto 18 | import Database.Esqueleto.Experimental hiding (from, on) 19 | import qualified Database.Esqueleto.Experimental as Experimental 20 | import Database.Persist.MySQL 21 | ( connectDatabase 22 | , connectHost 23 | , connectPassword 24 | , connectPort 25 | , connectUser 26 | , createMySQLPool 27 | , defaultConnectInfo 28 | , withMySQLConn 29 | ) 30 | 31 | import Test.Hspec 32 | 33 | import Common.Test 34 | import Data.Maybe (fromMaybe) 35 | import System.Environment (lookupEnv) 36 | 37 | testMysqlSum :: SpecDb 38 | testMysqlSum = do 39 | itDb "works with sum_" $ do 40 | _ <- insert' p1 41 | _ <- insert' p2 42 | _ <- insert' p3 43 | _ <- insert' p4 44 | ret <- select $ 45 | from $ \p-> 46 | return $ joinV $ sum_ (p ^. PersonAge) 47 | liftIO $ ret `shouldBe` [ Value $ Just (36 + 17 + 17 :: Double ) ] 48 | 49 | testMysqlTwoAscFields :: SpecDb 50 | testMysqlTwoAscFields = do 51 | itDb "works with two ASC fields (one call)" $ do 52 | p1e <- insert' p1 53 | p2e <- insert' p2 54 | p3e <- insert' p3 55 | p4e <- insert' p4 56 | ret <- select $ 57 | from $ \p -> do 58 | orderBy [asc (p ^. PersonAge), asc (p ^. PersonName)] 59 | return p 60 | liftIO $ ret `shouldBe` [ p2e, p4e, p3e, p1e ] 61 | 62 | testMysqlOneAscOneDesc :: SpecDb 63 | testMysqlOneAscOneDesc = do 64 | itDb "works with one ASC and one DESC field (two calls)" $ do 65 | p1e <- insert' p1 66 | p2e <- insert' p2 67 | p3e <- insert' p3 68 | p4e <- insert' p4 69 | ret <- select $ 70 | from $ \p -> do 71 | orderBy [desc (p ^. PersonAge)] 72 | orderBy [asc (p ^. PersonName)] 73 | return p 74 | liftIO $ ret `shouldBe` [ p1e, p4e, p3e, p2e ] 75 | 76 | 77 | 78 | 79 | testMysqlCoalesce :: SpecDb 80 | testMysqlCoalesce = do 81 | itDb "works on PostgreSQL and MySQL with <2 arguments" $ do 82 | _ :: [Value (Maybe Int)] <- 83 | select $ 84 | from $ \p -> do 85 | return (coalesce [p ^. PersonAge]) 86 | return () 87 | 88 | 89 | 90 | 91 | testMysqlUpdate :: SpecDb 92 | testMysqlUpdate = do 93 | itDb "works on a simple example" $ do 94 | p1k <- insert p1 95 | p2k <- insert p2 96 | p3k <- insert p3 97 | let anon = "Anonymous" 98 | () <- update $ \p -> do 99 | set p [ PersonName =. val anon 100 | , PersonAge *=. just (val 2) ] 101 | where_ (p ^. PersonName !=. val "Mike") 102 | n <- updateCount $ \p -> do 103 | set p [ PersonAge +=. just (val 1) ] 104 | where_ (p ^. PersonName !=. val "Mike") 105 | ret <- select $ 106 | from $ \p -> do 107 | orderBy [ asc (p ^. PersonName), asc (p ^. PersonAge) ] 108 | return p 109 | -- MySQL: nulls appear first, and update returns actual number 110 | -- of changed rows 111 | liftIO $ n `shouldBe` 1 112 | liftIO $ ret `shouldBe` [ Entity p2k (Person anon Nothing (Just 37) 2) 113 | , Entity p1k (Person anon (Just 73) Nothing 1) 114 | , Entity p3k p3 ] 115 | 116 | nameContains :: (SqlString s) 117 | => (SqlExpr (Value [Char]) 118 | -> SqlExpr (Value s) 119 | -> SqlExpr (Value Bool)) 120 | -> s 121 | -> [Entity Person] 122 | -> SqlPersistT IO () 123 | nameContains f t expected = do 124 | ret <- select $ 125 | from $ \p -> do 126 | where_ (f 127 | (p ^. PersonName) 128 | (concat_ [(%), val t, (%)])) 129 | orderBy [asc (p ^. PersonName)] 130 | return p 131 | liftIO $ ret `shouldBe` expected 132 | 133 | 134 | testMysqlTextFunctions :: SpecDb 135 | testMysqlTextFunctions = do 136 | describe "text functions" $ do 137 | itDb "like, (%) and (++.) work on a simple example" $ do 138 | [p1e, p2e, p3e, p4e] <- mapM insert' [p1, p2, p3, p4] 139 | nameContains like "h" [p1e, p2e] 140 | nameContains like "i" [p4e, p3e] 141 | nameContains like "iv" [p4e] 142 | 143 | 144 | testMysqlUnionWithLimits :: SpecDb 145 | testMysqlUnionWithLimits = do 146 | describe "MySQL Union" $ do 147 | itDb "supports limit/orderBy by parenthesizing" $ do 148 | mapM_ (insert . Foo) [1..6] 149 | 150 | let q1 = do 151 | foo <- Experimental.from $ Table @Foo 152 | where_ $ foo ^. FooName <=. val 3 153 | orderBy [asc $ foo ^. FooName] 154 | limit 2 155 | pure $ foo ^. FooName 156 | 157 | let q2 = do 158 | foo <- Experimental.from $ Table @Foo 159 | where_ $ foo ^. FooName >. val 3 160 | orderBy [asc $ foo ^. FooName] 161 | limit 2 162 | pure $ foo ^. FooName 163 | 164 | 165 | ret <- select $ Experimental.from $ q1 `union_` q2 166 | liftIO $ ret `shouldMatchList` [Value 1, Value 2, Value 4, Value 5] 167 | 168 | spec :: Spec 169 | spec = beforeAll mkConnectionPool $ do 170 | tests 171 | 172 | describe "MySQL specific tests" $ do 173 | -- definitely doesn't work at the moment 174 | -- testMysqlRandom 175 | testMysqlSum 176 | testMysqlTwoAscFields 177 | testMysqlOneAscOneDesc 178 | testMysqlCoalesce 179 | testMysqlUpdate 180 | testMysqlTextFunctions 181 | testMysqlUnionWithLimits 182 | 183 | verbose :: Bool 184 | verbose = False 185 | 186 | migrateIt :: R.MonadUnliftIO m => SqlPersistT m () 187 | migrateIt = do 188 | mapReaderT R.runResourceT $ void $ runMigrationSilent migrateAll 189 | cleanDB 190 | 191 | mkConnectionPool :: IO ConnectionPool 192 | mkConnectionPool = do 193 | ci <- isCI 194 | mysqlHost <- (fromMaybe "localhost" <$> lookupEnv "MYSQL_HOST") 195 | let connInfo 196 | | ci = 197 | defaultConnectInfo 198 | { connectHost = "127.0.0.1" 199 | , connectUser = "travis" 200 | , connectPassword = "esqutest" 201 | , connectDatabase = "esqutest" 202 | , connectPort = 33306 203 | } 204 | | otherwise = 205 | defaultConnectInfo 206 | { connectHost = mysqlHost 207 | , connectUser = "travis" 208 | , connectPassword = "esqutest" 209 | , connectDatabase = "esqutest" 210 | , connectPort = 3306 211 | } 212 | pool <- 213 | if verbose 214 | then 215 | runStderrLoggingT $ 216 | createMySQLPool connInfo 4 217 | else 218 | runNoLoggingT $ 219 | createMySQLPool connInfo 4 220 | 221 | 222 | flip runSqlPool pool $ do 223 | migrateIt 224 | cleanDB 225 | 226 | pure pool 227 | -------------------------------------------------------------------------------- /test/PostgreSQL/MigrateJSON.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DerivingStrategies #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE OverloadedStrings #-} 9 | {-# LANGUAGE QuasiQuotes #-} 10 | {-# LANGUAGE RankNTypes #-} 11 | {-# LANGUAGE ScopedTypeVariables #-} 12 | {-# LANGUAGE StandaloneDeriving #-} 13 | {-# LANGUAGE TemplateHaskell #-} 14 | {-# LANGUAGE TypeFamilies #-} 15 | {-# LANGUAGE UndecidableInstances #-} 16 | 17 | module PostgreSQL.MigrateJSON where 18 | 19 | import Common.Test.Import hiding (Value, from, on) 20 | 21 | import Data.Aeson (Value) 22 | import Database.Esqueleto.Legacy (from) 23 | import Database.Esqueleto.PostgreSQL.JSON (JSONB) 24 | import Database.Persist.TH 25 | 26 | -- JSON Table for PostgreSQL 27 | share [mkPersist sqlSettings, mkMigrate "migrateJSON"] [persistUpperCase| 28 | Json 29 | value (JSONB Value) 30 | deriving Show 31 | |] 32 | 33 | cleanJSON 34 | :: forall m. MonadIO m 35 | => SqlPersistT m () 36 | cleanJSON = delete $ from $ \(_ :: SqlExpr (Entity Json)) -> return () 37 | -------------------------------------------------------------------------------- /test/SQLite/Test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | 7 | module SQLite.Test where 8 | 9 | import Common.Test.Import hiding (from, on) 10 | 11 | import Control.Monad (void) 12 | import Control.Monad.Logger (runNoLoggingT, runStderrLoggingT) 13 | import Database.Esqueleto.Legacy hiding (random_) 14 | import Database.Esqueleto.SQLite (random_) 15 | import Database.Persist.Sqlite (createSqlitePool) 16 | import Database.Sqlite (SqliteException) 17 | 18 | import Common.Test 19 | 20 | testSqliteRandom :: SpecDb 21 | testSqliteRandom = do 22 | itDb "works with random_" $ do 23 | _ <- select $ return (random_ :: SqlExpr (Value Int)) 24 | asserting noExceptions 25 | 26 | testSqliteSum :: SpecDb 27 | testSqliteSum = do 28 | itDb "works with sum_" $ do 29 | _ <- insert' p1 30 | _ <- insert' p2 31 | _ <- insert' p3 32 | _ <- insert' p4 33 | ret <- select $ 34 | from $ \p-> 35 | return $ joinV $ sum_ (p ^. PersonAge) 36 | asserting $ ret `shouldBe` [ Value $ Just (36 + 17 + 17 :: Int) ] 37 | 38 | 39 | 40 | 41 | 42 | testSqliteTwoAscFields :: SpecDb 43 | testSqliteTwoAscFields = do 44 | itDb "works with two ASC fields (one call)" $ do 45 | p1e <- insert' p1 46 | p2e <- insert' p2 47 | p3e <- insert' p3 48 | p4e <- insert' p4 49 | ret <- select $ 50 | from $ \p -> do 51 | orderBy [asc (p ^. PersonAge), asc (p ^. PersonName)] 52 | return p 53 | -- in SQLite and MySQL, its the reverse 54 | asserting $ ret `shouldBe` [ p2e, p4e, p3e, p1e ] 55 | 56 | testSqliteOneAscOneDesc :: SpecDb 57 | testSqliteOneAscOneDesc = do 58 | itDb "works with one ASC and one DESC field (two calls)" $ do 59 | p1e <- insert' p1 60 | p2e <- insert' p2 61 | p3e <- insert' p3 62 | p4e <- insert' p4 63 | ret <- select $ 64 | from $ \p -> do 65 | orderBy [desc (p ^. PersonAge)] 66 | orderBy [asc (p ^. PersonName)] 67 | return p 68 | asserting $ ret `shouldBe` [ p1e, p4e, p3e, p2e ] 69 | 70 | testSqliteCoalesce :: SpecDb 71 | testSqliteCoalesce = do 72 | itDb "throws an exception on SQLite with <2 arguments" $ do 73 | eres <- try $ select $ 74 | from $ \p -> do 75 | return (coalesce [p ^. PersonAge]) :: SqlQuery (SqlExpr (Value (Maybe Int))) 76 | asserting $ case eres of 77 | Left (_ :: SqliteException) -> 78 | pure () 79 | Right _ -> 80 | expectationFailure "Expected SqliteException with <2 args to coalesce" 81 | 82 | testSqliteUpdate :: SpecDb 83 | testSqliteUpdate = do 84 | itDb "works on a simple example" $ do 85 | p1k <- insert p1 86 | p2k <- insert p2 87 | p3k <- insert p3 88 | let anon = "Anonymous" :: String 89 | () <- update $ \p -> do 90 | set p [ PersonName =. val anon 91 | , PersonAge *=. just (val 2) ] 92 | where_ (p ^. PersonName !=. val "Mike") 93 | n <- updateCount $ \p -> do 94 | set p [ PersonAge +=. just (val 1) ] 95 | where_ (p ^. PersonName !=. val "Mike") 96 | ret <- select $ 97 | from $ \p -> do 98 | orderBy [ asc (p ^. PersonName), asc (p ^. PersonAge) ] 99 | return p 100 | -- SQLite: nulls appear first, update returns matched rows. 101 | asserting $ do 102 | n `shouldBe` 2 103 | ret `shouldMatchList` 104 | [ Entity p2k (Person anon Nothing (Just 37) 2) 105 | , Entity p1k (Person anon (Just 73) Nothing 1) 106 | , Entity p3k p3 107 | ] 108 | 109 | testSqliteTextFunctions :: SpecDb 110 | testSqliteTextFunctions = do 111 | describe "text functions" $ do 112 | itDb "like, (%) and (++.) work on a simple example" $ do 113 | let query :: String -> SqlPersistT IO [Entity Person] 114 | query t = 115 | select $ 116 | from $ \p -> do 117 | where_ (like 118 | (p ^. PersonName) 119 | ((%) ++. val t ++. (%))) 120 | orderBy [asc (p ^. PersonName)] 121 | return p 122 | [p1e, p2e, p3e, p4e] <- mapM insert' [p1, p2, p3, p4] 123 | r0 <- query "h" 124 | r1 <- query "i" 125 | r2 <- query "iv" 126 | asserting $ do 127 | r0 `shouldBe` [p1e, p2e] 128 | r1 `shouldBe` [p4e, p3e] 129 | r2 `shouldBe` [p4e] 130 | 131 | spec :: HasCallStack => Spec 132 | spec = beforeAll mkConnectionPool $ do 133 | tests 134 | 135 | describe "SQLite specific tests" $ do 136 | testAscRandom random_ 137 | testSqliteRandom 138 | testSqliteSum 139 | testSqliteTwoAscFields 140 | testSqliteOneAscOneDesc 141 | testSqliteCoalesce 142 | testSqliteUpdate 143 | testSqliteTextFunctions 144 | 145 | mkConnectionPool :: IO ConnectionPool 146 | mkConnectionPool = do 147 | conn <- 148 | if verbose 149 | then runStderrLoggingT $ 150 | createSqlitePool ".esqueleto-test.sqlite" 4 151 | else runNoLoggingT $ 152 | createSqlitePool ".esqueleto-test.sqlite" 4 153 | flip runSqlPool conn $ do 154 | migrateIt 155 | 156 | pure conn 157 | 158 | verbose :: Bool 159 | verbose = False 160 | 161 | migrateIt :: MonadUnliftIO m => SqlPersistT m () 162 | migrateIt = do 163 | void $ runMigrationSilent migrateAll 164 | cleanDB 165 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Test.Hspec 4 | import Test.Hspec.Core.Spec 5 | 6 | import qualified SQLite.Test as SQLite 7 | import qualified MySQL.Test as MySQL 8 | import qualified PostgreSQL.Test as Postgres 9 | 10 | main :: IO () 11 | main = hspec spec 12 | 13 | spec :: Spec 14 | spec = do 15 | parallel $ describe "Esqueleto" $ do 16 | describe "SQLite" $ do 17 | sequential $ SQLite.spec 18 | describe "MySQL" $ do 19 | sequential $ MySQL.spec 20 | describe "Postgresql" $ do 21 | sequential $ Postgres.spec 22 | -------------------------------------------------------------------------------- /test/docker-compose.yml: -------------------------------------------------------------------------------- 1 | # docker-compose file for running postgres and mysql DBMS 2 | 3 | # If using this to run the tests, 4 | # while these containers are running (i.e. after something like) 5 | # (cd test; docker-compose up -d) 6 | # the tests must be told to use the hostname via MYSQL_HOST environment variable 7 | # e.g. something like: 8 | # MYSQL_HOST=127.0.0.1 stack test 9 | 10 | version: '3' 11 | services: 12 | postgres: 13 | image: 'postgres:15.2-alpine' 14 | environment: 15 | POSTGRES_USER: esqutest 16 | POSTGRES_PASSWORD: esqutest 17 | POSTGRES_DB: esqutest 18 | ports: 19 | - 5432:5432 20 | mysql: 21 | image: 'mysql:8.0.32' 22 | environment: 23 | MYSQL_USER: travis 24 | MYSQL_PASSWORD: esqutest 25 | MYSQL_ROOT_PASSWORD: esqutest 26 | MYSQL_DATABASE: esqutest 27 | ports: 28 | - 3306:3306 29 | -------------------------------------------------------------------------------- /test/expected-compile-failures/.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | expected-compile-failures.cabal 3 | *~ -------------------------------------------------------------------------------- /test/expected-compile-failures/README.md: -------------------------------------------------------------------------------- 1 | # expected-compile-failures 2 | 3 | This subdirectory contains a stack project for expected compilation failures. To 4 | add a new "test case", create a new `executable` stanza in the `package.yaml` 5 | file. The Travis CI test script ([`test.sh`](test.sh)) will attempt to compile 6 | the executable and will exit with an error if it successfully compiled. 7 | -------------------------------------------------------------------------------- /test/expected-compile-failures/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /test/expected-compile-failures/package.yaml: -------------------------------------------------------------------------------- 1 | name: expected-compile-failures 2 | version: 0.1.0.0 3 | github: bitemyapp/esqueleto 4 | license: BSD3 5 | author: Matt Parsons 6 | maintainer: parsonsmatt@gmail.com 7 | copyright: 2018 Matt Parsons 8 | 9 | extra-source-files: 10 | - README.md 11 | 12 | description: Please see the README on GitHub at 13 | 14 | dependencies: 15 | - base >= 4.7 && < 5 16 | - esqueleto 17 | - persistent 18 | - persistent-template 19 | 20 | default-extensions: 21 | - FlexibleContexts 22 | - FlexibleInstances 23 | - GADTs 24 | - GeneralizedNewtypeDeriving 25 | - MultiParamTypeClasses 26 | - NoMonomorphismRestriction 27 | - OverloadedStrings 28 | - QuasiQuotes 29 | - ScopedTypeVariables 30 | - StandaloneDeriving 31 | - TemplateHaskell 32 | - TypeFamilies 33 | 34 | library: 35 | source-dirs: src 36 | 37 | executables: 38 | update-with-read-role: 39 | main: Main.hs 40 | source-dirs: update-read-role 41 | ghc-options: 42 | - -threaded 43 | - -rtsopts 44 | - -with-rtsopts=-N 45 | dependencies: 46 | - expected-compile-failures 47 | write-with-read-role: 48 | main: Main.hs 49 | source-dirs: write-read-role 50 | ghc-options: 51 | - -threaded 52 | - -rtsopts 53 | - -with-rtsopts=-N 54 | dependencies: 55 | - expected-compile-failures 56 | -------------------------------------------------------------------------------- /test/expected-compile-failures/src/Lib.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances, DerivingStrategies #-} 2 | module Lib where 3 | 4 | import Control.Monad.IO.Class (MonadIO) 5 | import Database.Persist 6 | import Database.Persist.Sql (SqlReadT) 7 | import Database.Esqueleto (SqlExpr, SqlQuery, from, 8 | val, (<#), insertSelect, (<&>), (^.)) 9 | import Database.Esqueleto.Internal.Language (Insertion) 10 | import Database.Persist.TH (mkDeleteCascade, 11 | mkMigrate, mkPersist, 12 | persistLowerCase, share, 13 | sqlSettings) 14 | 15 | share [ mkPersist sqlSettings 16 | , mkDeleteCascade sqlSettings 17 | , mkMigrate "migrateAll"] [persistLowerCase| 18 | Person 19 | name String 20 | age Int Maybe 21 | born Int Maybe 22 | deriving Eq Show 23 | BlogPost 24 | title String 25 | authorId PersonId 26 | deriving Eq Show 27 | Follow 28 | follower PersonId 29 | followed PersonId 30 | deriving Eq Show 31 | |] 32 | 33 | 34 | -------------------------------------------------------------------------------- /test/expected-compile-failures/stack-8.2.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-10.6 2 | 3 | extra-deps: 4 | - aeson-1.4.1.0 5 | - aeson-compat-0.3.8 6 | - attoparsec-0.13.2.2 7 | - case-insensitive-1.2.0.11 8 | - conduit-1.3.0 9 | - conduit-extra-1.3.0 10 | - hashable-1.2.7.0 11 | - monad-logger-0.3.28.1 12 | - persistent-2.10.0 13 | - persistent-mysql-2.10.0 14 | - persistent-postgresql-2.10.0 15 | - persistent-sqlite-2.10.0 16 | - persistent-template-2.7.0 17 | - postgresql-libpq-0.9.4.2 18 | - postgresql-simple-0.6.1 19 | - resourcet-1.2.0 20 | - scientific-0.3.6.2 21 | - text-1.2.3.0 22 | - unliftio-0.2.0.0 23 | 24 | packages: 25 | - . 26 | - ../../../esqueleto 27 | -------------------------------------------------------------------------------- /test/expected-compile-failures/stack-8.4.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-12.24 2 | 3 | packages: 4 | - . 5 | - ../../../esqueleto 6 | 7 | extra-deps: 8 | - aeson-1.4.1.0 9 | - persistent-2.10.0 10 | - persistent-mysql-2.10.0 11 | - persistent-postgresql-2.10.0 12 | - persistent-sqlite-2.10.0 13 | - persistent-template-2.7.0 14 | - postgresql-libpq-0.9.4.2 15 | - postgresql-simple-0.6.1 16 | - transformers-0.5.5.2 17 | allow-newer: true 18 | -------------------------------------------------------------------------------- /test/expected-compile-failures/stack-8.6.yaml: -------------------------------------------------------------------------------- 1 | resolver: nightly-2018-12-18 2 | 3 | extra-deps: 4 | - persistent-2.10.0 5 | - persistent-mysql-2.10.0 6 | - persistent-postgresql-2.10.0 7 | - persistent-sqlite-2.10.0 8 | - persistent-template-2.7.0 9 | - postgresql-simple-0.6.1 10 | 11 | allow-newer: true 12 | 13 | packages: 14 | - . 15 | - ../../../esqueleto 16 | -------------------------------------------------------------------------------- /test/expected-compile-failures/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-12.24 2 | 3 | packages: 4 | - . 5 | - ../../../esqueleto 6 | 7 | extra-deps: 8 | - aeson-1.4.1.0 9 | - persistent-2.10.0 10 | - persistent-mysql-2.10.0 11 | - persistent-postgresql-2.10.0 12 | - persistent-sqlite-2.10.0 13 | - persistent-template-2.7.0 14 | - postgresql-libpq-0.9.4.2 15 | - postgresql-simple-0.6.1 16 | - transformers-0.5.5.2 17 | -------------------------------------------------------------------------------- /test/expected-compile-failures/stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: 7 | - completed: 8 | hackage: aeson-1.4.1.0@sha256:a72639fbf44d5c2d5270fb6d9484629ed332d3029987fafd7580b5204265fb8b,6372 9 | pantry-tree: 10 | size: 39767 11 | sha256: 3eee6f6a05e563ebdd45e93348240d79eb20c267e70683360758327745d3249d 12 | original: 13 | hackage: aeson-1.4.1.0 14 | - completed: 15 | hackage: persistent-2.10.0@sha256:6e4566c2cf8dda6bf3e00f4f813dd711e7796a1598f46c5c729491f4b643c91d,4708 16 | pantry-tree: 17 | size: 2094 18 | sha256: 5ae7466479cf300e9bf07dc9780a432b4338c4e1e56fc732399260303cdf2f84 19 | original: 20 | hackage: persistent-2.10.0 21 | - completed: 22 | hackage: persistent-mysql-2.10.0@sha256:4bf76721312104b726406d3cac4a30185e9e19898605615ded6cbfe5cdabda6a,2884 23 | pantry-tree: 24 | size: 460 25 | sha256: 15737a7f8af7085fa6f83f1c084ff4de4922f28576633aa9aab4a8e668ccc5c3 26 | original: 27 | hackage: persistent-mysql-2.10.0 28 | - completed: 29 | hackage: persistent-postgresql-2.10.0@sha256:87384a179e44b57af7b12b00ccfdfc4bc03010a438aad207b9f38def0147cda2,2829 30 | pantry-tree: 31 | size: 671 32 | sha256: 5a2b25b40cb440466792b9ae293de95b4fcfcd1410c1c7aed9ffc8001699f5dc 33 | original: 34 | hackage: persistent-postgresql-2.10.0 35 | - completed: 36 | hackage: persistent-sqlite-2.10.0@sha256:d41ad3e2d9b88ab31bfdcd15e76ad41cd495573937921026b3b13f010ff9b8cf,4664 37 | pantry-tree: 38 | size: 681 39 | sha256: 86ad7225024dbe74421b78ab6a6c3e05aeb94d0633cde413f7e91453bee3e7c0 40 | original: 41 | hackage: persistent-sqlite-2.10.0 42 | - completed: 43 | hackage: persistent-template-2.7.0@sha256:1855a36c7dbfa1554c1711c1d61c41e83495bcb1986851cf1b3340f44ed269af,2703 44 | pantry-tree: 45 | size: 560 46 | sha256: 073f355d9425b1553e8e4f8553bb06e63d185c0e113c75512f969eeb92bcb4db 47 | original: 48 | hackage: persistent-template-2.7.0 49 | - completed: 50 | hackage: postgresql-libpq-0.9.4.2@sha256:3a3f372cf72706f349104f73d4ea5dee9c3eeac1ff749301110dadb55e2ac66f,2804 51 | pantry-tree: 52 | size: 549 53 | sha256: b045b567464d6c86ecc23a3915a6aa81c52cfbaa1c51c7fe9649366185c9ce6b 54 | original: 55 | hackage: postgresql-libpq-0.9.4.2 56 | - completed: 57 | hackage: postgresql-simple-0.6.1@sha256:316e6424da50ec863c74dcf2d7c86cfe6ee00cb142c07a422eb118577dc1d3b7,5256 58 | pantry-tree: 59 | size: 4055 60 | sha256: c22e1f054f3be5eaad5eba5abc793504be85e441ff671bf203013ac8f72f9c79 61 | original: 62 | hackage: postgresql-simple-0.6.1 63 | - completed: 64 | hackage: transformers-0.5.5.2@sha256:c6a1dc5261d87de1d7d0876b670ca8782c43ac89e59ec2bafa1e32d25c7d3509,3122 65 | pantry-tree: 66 | size: 2365 67 | sha256: 5c38ca49a4b2468b6c61682a722611c8a54699bb94f8d6e0ee9f2c546477f116 68 | original: 69 | hackage: transformers-0.5.5.2 70 | snapshots: 71 | - completed: 72 | size: 508835 73 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/12/24.yaml 74 | sha256: b0a5564eb448e69b9f6a4f67fe72016d9e7ec24e37de1826e1a9cfd064a1b6a5 75 | original: lts-12.24 76 | -------------------------------------------------------------------------------- /test/expected-compile-failures/test.sh: -------------------------------------------------------------------------------- 1 | #!/bin/env bash 2 | 3 | # This script attempts to build each executable in the package, which should all 4 | # fail with a compiler error. If any executable builds successfully, then we exit 5 | # the script. 6 | 7 | # We have to use 2>&1 because `stack ide targets` outputs to stderr for some 8 | # reason. 9 | for target in $(stack ide targets 2>&1 | grep exe); do 10 | echo "Building target: $target" 11 | if stack build --fast $target; then 12 | exit 1 13 | fi 14 | done 15 | -------------------------------------------------------------------------------- /test/expected-compile-failures/update-read-role/Main.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-unused-top-binds #-} 2 | 3 | module Main where 4 | 5 | import Control.Monad.IO.Class (MonadIO) 6 | import Database.Esqueleto 7 | import Database.Esqueleto.Internal.Language (Insertion) 8 | import Database.Persist.Sql (SqlWriteT) 9 | import Database.Persist.TH (mkDeleteCascade, 10 | mkMigrate, mkPersist, 11 | persistLowerCase, share, 12 | sqlSettings) 13 | 14 | import Lib 15 | 16 | main :: IO () 17 | main = pure () 18 | 19 | updateQuery :: SqlExpr (Entity Person) -> SqlQuery () 20 | updateQuery = \p -> do 21 | set p [ PersonAge =. just (val 123) -. p ^. PersonBorn ] 22 | where_ $ isNothing (p ^. PersonAge) 23 | 24 | shouldFail :: MonadIO m => SqlReadT m () 25 | shouldFail = update updateQuery 26 | -------------------------------------------------------------------------------- /test/expected-compile-failures/write-read-role/Main.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-unused-top-binds #-} 2 | 3 | module Main where 4 | 5 | import Control.Monad.IO.Class (MonadIO) 6 | import Database.Esqueleto (SqlExpr, SqlQuery, from, 7 | insertSelect, val, (<#), 8 | (<&>), (^.)) 9 | import Database.Esqueleto.Internal.Language (Insertion) 10 | import Database.Persist.Sql (SqlReadT) 11 | import Database.Persist.TH (mkDeleteCascade, 12 | mkMigrate, mkPersist, 13 | persistLowerCase, share, 14 | sqlSettings) 15 | 16 | import Lib 17 | 18 | main :: IO () 19 | main = pure () 20 | 21 | insertQuery :: SqlQuery (SqlExpr (Insertion BlogPost)) 22 | insertQuery = 23 | from $ \p -> 24 | return $ BlogPost <# (val "Group Blog Post") <&> (p ^. PersonId) 25 | 26 | shouldFail :: MonadIO m => SqlReadT m () 27 | shouldFail = insertSelect insertQuery 28 | -------------------------------------------------------------------------------- /test/new-join-compiler-errors/README.md: -------------------------------------------------------------------------------- 1 | # expected-compile-failures 2 | 3 | This subdirectory contains a stack project for expected compilation failures. To 4 | add a new "test case", create a new `executable` stanza in the `package.yaml` 5 | file. The Travis CI test script ([`test.sh`](test.sh)) will attempt to compile 6 | the executable and will exit with an error if it successfully compiled. 7 | -------------------------------------------------------------------------------- /test/new-join-compiler-errors/bad-errors/Main.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-unused-top-binds #-} 2 | {-# LANGUAGE TypeApplications #-} 3 | module Main where 4 | 5 | import Control.Monad.IO.Class (MonadIO) 6 | import Database.Esqueleto hiding (from,on) 7 | import Database.Esqueleto.Experimental 8 | import Database.Esqueleto.Internal.Language (Insertion) 9 | import Database.Persist.Sql (SqlWriteT) 10 | import Database.Persist.TH (mkDeleteCascade, 11 | mkMigrate, mkPersist, 12 | persistLowerCase, share, 13 | sqlSettings) 14 | 15 | import Lib 16 | 17 | main :: IO () 18 | main = pure () 19 | 20 | -- Missing on condition leads to an unintelligeable error and points to the wrong spot 21 | missingOnConditionShouldFail :: MonadIO m => SqlPersistT m [(Entity Person, Entity BlogPost)] 22 | missingOnConditionShouldFail = select $ do 23 | (people :& blogPosts) <- 24 | from $ Table @Person 25 | `LeftOuterJoin` Table @BlogPost 26 | pure (people, blogPosts) 27 | 28 | -- Mismatched union when one part is returning a different shape than the other 29 | mismatchedUnion :: MonadIO m => SqlPersistT m [(Value String, Value (Maybe Int))] 30 | mismatchedUnion = select . from $ 31 | (SelectQuery $ do 32 | people <- from $ Table @Person 33 | pure (people ^. PersonName, people ^. PersonAge)) 34 | `Union` 35 | (SelectQuery $ do 36 | people <- from $ Table @Person 37 | pure (people ^. PersonName)) 38 | 39 | incorrectNumberOfOnElements = select . from $ 40 | Table @Person 41 | `LeftOuterJoin` Table @Follow 42 | `on` (\(people :& follows) -> just (people ^. PersonId) ==. follows ?. FollowFollowed) 43 | `LeftOuterJoin` Table @Person 44 | `on` (\(follows :& followers) -> followers ?. PersonId ==. follows ?. FollowFollower) 45 | 46 | -------------------------------------------------------------------------------- /test/new-join-compiler-errors/new-join-compiler-errors.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.31.2. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: 2bf9103f4701fb3c063743dbb88970ee68ecbeaeb87eea96ca21096da1264968 8 | 9 | name: new-join-compiler-errors 10 | version: 0.1.0.0 11 | description: Please see the README on GitHub at 12 | homepage: https://github.com/bitemyapp/esqueleto#readme 13 | bug-reports: https://github.com/bitemyapp/esqueleto/issues 14 | author: Ben Levy 15 | maintainer: benjaminlevy007@gmail.com 16 | copyright: 2020 Ben Levy 17 | license: BSD3 18 | build-type: Simple 19 | extra-source-files: 20 | README.md 21 | 22 | source-repository head 23 | type: git 24 | location: https://github.com/bitemyapp/esqueleto 25 | 26 | library 27 | exposed-modules: 28 | Lib 29 | other-modules: 30 | Paths_new_join_compiler_errors 31 | hs-source-dirs: 32 | src 33 | default-extensions: FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving MultiParamTypeClasses NoMonomorphismRestriction OverloadedStrings QuasiQuotes ScopedTypeVariables StandaloneDeriving TemplateHaskell TypeFamilies 34 | build-depends: 35 | base >=4.7 && <5 36 | , esqueleto 37 | , persistent 38 | , persistent-template 39 | default-language: Haskell2010 40 | 41 | executable bad-errors 42 | main-is: Main.hs 43 | other-modules: 44 | Paths_new_join_compiler_errors 45 | hs-source-dirs: 46 | bad-errors 47 | default-extensions: FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving MultiParamTypeClasses NoMonomorphismRestriction OverloadedStrings QuasiQuotes ScopedTypeVariables StandaloneDeriving TemplateHaskell TypeFamilies 48 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 49 | build-depends: 50 | base >=4.7 && <5 51 | , esqueleto 52 | , new-join-compiler-errors 53 | , persistent 54 | , persistent-template 55 | default-language: Haskell2010 56 | -------------------------------------------------------------------------------- /test/new-join-compiler-errors/package.yaml: -------------------------------------------------------------------------------- 1 | name: new-join-compiler-errors 2 | version: 0.1.0.0 3 | github: bitemyapp/esqueleto 4 | license: BSD3 5 | author: Ben Levy 6 | maintainer: benjaminlevy007@gmail.com 7 | copyright: 2020 Ben Levy 8 | 9 | extra-source-files: 10 | - README.md 11 | 12 | description: Please see the README on GitHub at 13 | 14 | dependencies: 15 | - base >= 4.7 && < 5 16 | - esqueleto 17 | - persistent 18 | - persistent-template 19 | 20 | default-extensions: 21 | - FlexibleContexts 22 | - FlexibleInstances 23 | - GADTs 24 | - GeneralizedNewtypeDeriving 25 | - MultiParamTypeClasses 26 | - NoMonomorphismRestriction 27 | - OverloadedStrings 28 | - QuasiQuotes 29 | - ScopedTypeVariables 30 | - StandaloneDeriving 31 | - TemplateHaskell 32 | - TypeFamilies 33 | 34 | library: 35 | source-dirs: src 36 | 37 | executables: 38 | bad-errors: 39 | main: Main.hs 40 | source-dirs: bad-errors 41 | ghc-options: 42 | - -threaded 43 | - -rtsopts 44 | - -with-rtsopts=-N 45 | dependencies: 46 | - new-join-compiler-errors 47 | -------------------------------------------------------------------------------- /test/new-join-compiler-errors/src/Lib.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances, DerivingStrategies #-} 2 | module Lib where 3 | 4 | import Control.Monad.IO.Class (MonadIO) 5 | import Database.Persist 6 | import Database.Persist.Sql (SqlReadT) 7 | import Database.Esqueleto (SqlExpr, SqlQuery, from, 8 | val, (<#), insertSelect, (<&>), (^.)) 9 | import Database.Esqueleto.Internal.Language (Insertion) 10 | import Database.Persist.TH (mkDeleteCascade, 11 | mkMigrate, mkPersist, 12 | persistLowerCase, share, 13 | sqlSettings) 14 | 15 | share [ mkPersist sqlSettings 16 | , mkDeleteCascade sqlSettings 17 | , mkMigrate "migrateAll"] [persistLowerCase| 18 | Person 19 | name String 20 | age Int Maybe 21 | born Int Maybe 22 | deriving Eq Show 23 | BlogPost 24 | title String 25 | authorId PersonId 26 | deriving Eq Show 27 | Follow 28 | follower PersonId 29 | followed PersonId 30 | deriving Eq Show 31 | |] 32 | 33 | 34 | -------------------------------------------------------------------------------- /test/new-join-compiler-errors/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-13.6 2 | 3 | packages: 4 | - . 5 | - ../../../esqueleto 6 | 7 | extra-deps: 8 | - aeson-1.4.1.0 9 | - persistent-2.10.0 10 | - persistent-mysql-2.10.0 11 | - persistent-postgresql-2.10.0 12 | - persistent-sqlite-2.10.0 13 | - persistent-template-2.7.0 14 | - postgresql-libpq-0.9.4.2 15 | - postgresql-simple-0.6.1 16 | - transformers-0.5.5.2 17 | --------------------------------------------------------------------------------