├── .github └── workflows │ └── ci.yml ├── .gitignore ├── README.md ├── RELEASE NOTES.md ├── cabal.project ├── scrap-your-nils.md ├── squeal-core-concepts-handbook.md ├── squeal-core-concepts-handbook ├── isqualified-alias.png ├── isqualified-can-be-np.png ├── isqualified-intro.png └── isqualified-join-constraint.png ├── squeal-postgresql-ltree ├── LICENSE ├── README.md ├── squeal-postgresql-ltree.cabal └── src │ └── Squeal │ └── PostgreSQL │ └── LTree.hs ├── squeal-postgresql-uuid-ossp ├── LICENSE ├── README.md ├── squeal-postgresql-uuid-ossp.cabal └── src │ └── Squeal │ └── PostgreSQL │ └── UUID │ └── OSSP.hs ├── squeal-postgresql ├── LICENSE ├── README.md ├── Setup.hs ├── bench │ ├── Gauge.hs │ ├── Gauge │ │ ├── DBHelpers.hs │ │ ├── DBSetup.hs │ │ ├── Queries.hs │ │ └── Schema.hs │ └── README.md ├── docs-upload.sh ├── exe │ └── Example.hs ├── squeal-postgresql.cabal ├── src │ └── Squeal │ │ ├── PostgreSQL.hs │ │ └── PostgreSQL │ │ ├── Definition.hs │ │ ├── Definition │ │ ├── Comment.hs │ │ ├── Constraint.hs │ │ ├── Function.hs │ │ ├── Index.hs │ │ ├── Procedure.hs │ │ ├── Schema.hs │ │ ├── Table.hs │ │ ├── Type.hs │ │ └── View.hs │ │ ├── Expression.hs │ │ ├── Expression │ │ ├── Aggregate.hs │ │ ├── Array.hs │ │ ├── Comparison.hs │ │ ├── Composite.hs │ │ ├── Default.hs │ │ ├── Inline.hs │ │ ├── Json.hs │ │ ├── Logic.hs │ │ ├── Math.hs │ │ ├── Null.hs │ │ ├── Parameter.hs │ │ ├── Range.hs │ │ ├── Sort.hs │ │ ├── Subquery.hs │ │ ├── Text.hs │ │ ├── TextSearch.hs │ │ ├── Time.hs │ │ ├── Type.hs │ │ └── Window.hs │ │ ├── Manipulation.hs │ │ ├── Manipulation │ │ ├── Call.hs │ │ ├── Delete.hs │ │ ├── Insert.hs │ │ └── Update.hs │ │ ├── Query.hs │ │ ├── Query │ │ ├── From.hs │ │ ├── From │ │ │ ├── Join.hs │ │ │ └── Set.hs │ │ ├── Select.hs │ │ ├── Table.hs │ │ ├── Values.hs │ │ └── With.hs │ │ ├── Render.hs │ │ ├── Session.hs │ │ ├── Session │ │ ├── Connection.hs │ │ ├── Decode.hs │ │ ├── Encode.hs │ │ ├── Exception.hs │ │ ├── Indexed.hs │ │ ├── Migration.hs │ │ ├── Monad.hs │ │ ├── Oid.hs │ │ ├── Pool.hs │ │ ├── Result.hs │ │ ├── Statement.hs │ │ ├── Transaction.hs │ │ └── Transaction │ │ │ └── Unsafe.hs │ │ ├── Type.hs │ │ └── Type │ │ ├── Alias.hs │ │ ├── List.hs │ │ ├── PG.hs │ │ └── Schema.hs └── test │ ├── Doc.hs │ ├── Property.hs │ └── Spec.hs ├── squeal-presentation-raveline.md ├── squeal-presentation.pdf ├── squeal.gif ├── stack-ghc8_10.yaml ├── stack-ghc8_8.yaml ├── stack-ghc9_0.yaml ├── stack-ghc9_2.yaml ├── stack-ghc9_4.yaml └── stack.yaml /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: 4 | push: 5 | branches: [ dev ] 6 | pull_request: 7 | branches: [ dev ] 8 | 9 | jobs: 10 | ghc_default: 11 | runs-on: ubuntu-latest 12 | 13 | services: 14 | postgres: 15 | image: postgres:11 16 | env: 17 | POSTGRES_USER: postgres 18 | POSTGRES_PASSWORD: postgres 19 | POSTGRES_DB: exampledb 20 | ports: 21 | - 5432:5432 22 | # needed because the postgres container does not provide a healthcheck 23 | options: --health-cmd pg_isready --health-interval 10s --health-timeout 5s --health-retries 5 24 | 25 | steps: 26 | - uses: actions/checkout@v4 27 | - uses: haskell-actions/setup@v2 28 | with: 29 | enable-stack: true 30 | stack-version: 'latest' 31 | stack-no-global: true 32 | stack-setup-ghc: true 33 | 34 | - name: build 35 | run: stack build --fast 36 | 37 | - name: test 38 | run: stack test --fast 39 | env: 40 | PG_USER: postgres 41 | PG_HOST: localhost 42 | PG_DATABASE: exampledb 43 | PG_PASSWORD: postgres 44 | PG_PORT: ${{ job.services.postgres.ports['5432'] }} 45 | 46 | - name: benchmark 47 | run: stack bench --fast 48 | 49 | - name: documentation 50 | run: stack haddock --fast 51 | 52 | - name: cache 53 | uses: actions/cache@v3 54 | with: 55 | path: | 56 | ".stack-work" 57 | "/root/.stack/" 58 | key: ${{ runner.os }}-${{ hashFiles('**/lockfiles') }} 59 | ghc9_4: 60 | runs-on: ubuntu-latest 61 | 62 | services: 63 | postgres: 64 | image: postgres:11 65 | env: 66 | POSTGRES_USER: postgres 67 | POSTGRES_PASSWORD: postgres 68 | POSTGRES_DB: exampledb 69 | ports: 70 | - 5432:5432 71 | # needed because the postgres container does not provide a healthcheck 72 | options: --health-cmd pg_isready --health-interval 10s --health-timeout 5s --health-retries 5 73 | 74 | steps: 75 | - uses: actions/checkout@v2 76 | - uses: haskell-actions/setup@v2 77 | with: 78 | enable-stack: true 79 | stack-version: 'latest' 80 | stack-no-global: true 81 | stack-setup-ghc: true 82 | 83 | - name: build 84 | run: stack build --fast --stack-yaml stack-ghc9_4.yaml 85 | 86 | - name: test 87 | run: stack test --fast --stack-yaml stack-ghc9_4.yaml 88 | env: 89 | PG_USER: postgres 90 | PG_HOST: localhost 91 | PG_DATABASE: exampledb 92 | PG_PASSWORD: postgres 93 | PG_PORT: ${{ job.services.postgres.ports['5432'] }} 94 | 95 | - name: benchmark 96 | run: stack bench --fast --stack-yaml stack-ghc9_4.yaml 97 | 98 | - name: documentation 99 | run: stack haddock --fast --stack-yaml stack-ghc9_4.yaml 100 | 101 | - name: cache 102 | uses: actions/cache@v3 103 | with: 104 | path: | 105 | ".stack-work" 106 | "/root/.stack/" 107 | key: ${{ runner.os }}-${{ hashFiles('**/lockfiles') }} 108 | ghc9_2: 109 | runs-on: ubuntu-latest 110 | 111 | services: 112 | postgres: 113 | image: postgres:11 114 | env: 115 | POSTGRES_USER: postgres 116 | POSTGRES_PASSWORD: postgres 117 | POSTGRES_DB: exampledb 118 | ports: 119 | - 5432:5432 120 | # needed because the postgres container does not provide a healthcheck 121 | options: --health-cmd pg_isready --health-interval 10s --health-timeout 5s --health-retries 5 122 | 123 | steps: 124 | - uses: actions/checkout@v2 125 | - uses: haskell-actions/setup@v2 126 | with: 127 | enable-stack: true 128 | stack-version: 'latest' 129 | stack-no-global: true 130 | stack-setup-ghc: true 131 | 132 | - name: build 133 | run: stack build --fast --stack-yaml stack-ghc9_2.yaml 134 | 135 | - name: test 136 | run: stack test --fast --stack-yaml stack-ghc9_2.yaml 137 | env: 138 | PG_USER: postgres 139 | PG_HOST: localhost 140 | PG_DATABASE: exampledb 141 | PG_PASSWORD: postgres 142 | PG_PORT: ${{ job.services.postgres.ports['5432'] }} 143 | 144 | - name: benchmark 145 | run: stack bench --fast --stack-yaml stack-ghc9_2.yaml 146 | 147 | - name: documentation 148 | run: stack haddock --fast --stack-yaml stack-ghc9_2.yaml 149 | 150 | - name: cache 151 | uses: actions/cache@v3 152 | with: 153 | path: | 154 | ".stack-work" 155 | "/root/.stack/" 156 | key: ${{ runner.os }}-${{ hashFiles('**/lockfiles') }} 157 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.eventlog 18 | .stack-work/ 19 | cabal.project.local 20 | .DS_Store 21 | stack.yaml.lock 22 | *.yaml.lock 23 | tags 24 | .*.swp 25 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: 2 | squeal-postgresql 3 | , squeal-postgresql-ltree 4 | , squeal-postgresql-uuid-ossp 5 | -------------------------------------------------------------------------------- /scrap-your-nils.md: -------------------------------------------------------------------------------- 1 | ## Scrap your Nils 2 | 3 | One of the most useful types I've come across in Haskell is the type of 4 | "heterogeneous lists". This is the same as the [Rec](http://hackage.haskell.org/package/vinyl-0.8.1.1/docs/Data-Vinyl-Core.html) 5 | datatype from the [vinyl](http://hackage.haskell.org/package/vinyl) library. 6 | It's also the same as the [NP](http://hackage.haskell.org/package/generics-sop-0.3.2.0/docs/Generics-SOP-NP.html) 7 | datatype from the [generics-sop](http://hackage.haskell.org/package/generics-sop) library. 8 | Squeal makes heavy use of this type. 9 | 10 | ```Haskell 11 | >>> import Generics.SOP (NP(..)) 12 | >>> :i NP 13 | type role NP representational nominal 14 | data NP (a :: k -> *) (b :: [k]) where 15 | Nil :: forall k (a :: k -> *). NP a '[] 16 | (:*) :: forall k (a :: k -> *) (x :: k) (xs :: [k]). 17 | (a x) -> (NP a xs) -> NP a (x : xs) 18 | -- Defined in ‘Generics.SOP.NP’ 19 | ``` 20 | 21 | This type allows us to construct "product" types, where the types of the individual 22 | "terms" are hosted at the type level. 23 | 24 | ```Haskell 25 | >>> :set -XDataKinds 26 | >>> import Generics.SOP (I(..)) 27 | >>> let example = I "foo" :* I pi :* Nil :: NP I '[String, Double] 28 | >>> example 29 | I "foo" :* I 3.141592653589793 :* Nil 30 | ``` 31 | 32 | One thing Squeal uses `NP` for is to form lists of aliases, 33 | using GHC's `OverloadedLabels` extension, hosting the names 34 | of the aliases themselves at the type level. 35 | 36 | ```Haskell 37 | >>> :set -XKindSignatures -XOverloadedLabels -XFlexibleInstances -XMultiParamTypeClasses 38 | >>> import GHC.TypeLits 39 | >>> import GHC.OverloadedLabels 40 | >>> data Alias (alias :: Symbol) = Alias deriving (Eq,Ord,Show) 41 | >>> instance IsLabel label (Alias label) where fromLabel = Alias 42 | >>> let aliases = #foo :* #bar :* Nil :: NP Alias '["foo", "bar"] 43 | ``` 44 | 45 | However, it's very ugly to have to end every list with `:* Nil`. 46 | When I announced the release of Squeal, people rightly [complained](https://www.reddit.com/r/haskell/comments/6yr5v6/announcing_squeal_a_deep_embedding_of_sql_in/dmq8vvn) 47 | about the syntactic noise. Luckily, there's a neat trick we can use to get rid of it. 48 | Making an `IsLabel` instance not only for elements of our list 49 | but also for lists of length 1, we can ask GHC to interpret 50 | the last label as a list. 51 | 52 | ```Haskell 53 | >>> instance IsLabel label (NP Alias '[label]) where fromLabel = Alias :* Nil 54 | >>> let aliases' = #foo :* #bar :: NP Alias '["foo", "bar"] 55 | ``` 56 | 57 | Version 0.3.1 of Squeal enables the "Scrap your Nils" trick for 58 | heterogeneous lists of `Alias`es, `Aliased` expressions, `PGlabel`s and `By`s 59 | with the typeclasses `IsLabel`, `IsQualified`, `IsPGlabel`, 60 | and the new `Aliasable` typeclass, to eliminate all need of using `Nil` in a list. 61 | -------------------------------------------------------------------------------- /squeal-core-concepts-handbook/isqualified-alias.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/morphismtech/squeal/533cab7bbc4ccd8da2872af511c79acf9896cd8c/squeal-core-concepts-handbook/isqualified-alias.png -------------------------------------------------------------------------------- /squeal-core-concepts-handbook/isqualified-can-be-np.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/morphismtech/squeal/533cab7bbc4ccd8da2872af511c79acf9896cd8c/squeal-core-concepts-handbook/isqualified-can-be-np.png -------------------------------------------------------------------------------- /squeal-core-concepts-handbook/isqualified-intro.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/morphismtech/squeal/533cab7bbc4ccd8da2872af511c79acf9896cd8c/squeal-core-concepts-handbook/isqualified-intro.png -------------------------------------------------------------------------------- /squeal-core-concepts-handbook/isqualified-join-constraint.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/morphismtech/squeal/533cab7bbc4ccd8da2872af511c79acf9896cd8c/squeal-core-concepts-handbook/isqualified-join-constraint.png -------------------------------------------------------------------------------- /squeal-postgresql-ltree/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2020 Morphism, LLC 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 7 | met: 8 | 9 | * Redistributions of source code must retain the above copyright 10 | notice, this list of conditions and the following disclaimer. 11 | 12 | * Redistributions in binary form must reproduce the above 13 | copyright notice, this list of conditions and the following 14 | disclaimer in the documentation and/or other materials provided 15 | with the distribution. 16 | 17 | * Neither the names of the copyright holders nor the names of the 18 | contributors may be used to endorse or promote products derived 19 | from this software without specific prior written permission. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 24 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 25 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 26 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 27 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 28 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 29 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 30 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 31 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /squeal-postgresql-ltree/README.md: -------------------------------------------------------------------------------- 1 | # squeal-postgresql-ltree 2 | -------------------------------------------------------------------------------- /squeal-postgresql-ltree/squeal-postgresql-ltree.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | name: squeal-postgresql-ltree 3 | version: 0.1.0.2 4 | synopsis: LTree extension for Squeal 5 | description: LTree extension for Squeal 6 | homepage: https://github.com/morphismtech/squeal/ltree 7 | bug-reports: https://github.com/morphismtech/squeal/issues 8 | license: BSD-3-Clause 9 | license-file: LICENSE 10 | author: Eitan Chatav 11 | maintainer: eitan.chatav@gmail.com 12 | copyright: Copyright (c) 2022 Morphism, LLC 13 | category: Database 14 | build-type: Simple 15 | extra-doc-files: README.md 16 | 17 | source-repository head 18 | type: git 19 | location: https://github.com/morphismtech/squeal.git 20 | 21 | library 22 | hs-source-dirs: src 23 | exposed-modules: 24 | Squeal.PostgreSQL.LTree 25 | default-language: Haskell2010 26 | ghc-options: -Wall 27 | build-depends: 28 | base >= 4.12.0.0 && < 5.0 29 | , bytestring >= 0.10.10.0 30 | , generics-sop >= 0.5.1.0 31 | , mtl >= 2.2.2 32 | , postgresql-binary >= 0.12.2 33 | , postgresql-libpq >= 0.9.4.2 34 | , squeal-postgresql >= 0.7.0.1 35 | , text >= 1.2.3.2 36 | -------------------------------------------------------------------------------- /squeal-postgresql-uuid-ossp/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2020 Morphism, LLC 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 7 | met: 8 | 9 | * Redistributions of source code must retain the above copyright 10 | notice, this list of conditions and the following disclaimer. 11 | 12 | * Redistributions in binary form must reproduce the above 13 | copyright notice, this list of conditions and the following 14 | disclaimer in the documentation and/or other materials provided 15 | with the distribution. 16 | 17 | * Neither the names of the copyright holders nor the names of the 18 | contributors may be used to endorse or promote products derived 19 | from this software without specific prior written permission. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 24 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 25 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 26 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 27 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 28 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 29 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 30 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 31 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /squeal-postgresql-uuid-ossp/README.md: -------------------------------------------------------------------------------- 1 | # squeal-postgresql-uuid-ossp 2 | -------------------------------------------------------------------------------- /squeal-postgresql-uuid-ossp/squeal-postgresql-uuid-ossp.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | name: squeal-postgresql-uuid-ossp 3 | version: 0.1.0.1 4 | synopsis: UUID OSSP extension for Squeal 5 | description: UUID OSSP extension for Squeal 6 | homepage: https://github.com/morphismtech/squeal/uuid-ossp 7 | bug-reports: https://github.com/morphismtech/squeal/issues 8 | license: BSD-3-Clause 9 | license-file: LICENSE 10 | author: Eitan Chatav 11 | maintainer: eitan.chatav@gmail.com 12 | copyright: Copyright (c) 2022 Morphism, LLC 13 | category: Database 14 | build-type: Simple 15 | extra-doc-files: README.md 16 | 17 | source-repository head 18 | type: git 19 | location: https://github.com/morphismtech/squeal.git 20 | 21 | library 22 | hs-source-dirs: src 23 | exposed-modules: 24 | Squeal.PostgreSQL.UUID.OSSP 25 | default-language: Haskell2010 26 | ghc-options: -Wall 27 | build-depends: 28 | base >= 4.12.0.0 && < 5.0 29 | , squeal-postgresql >= 0.7.0.1 30 | -------------------------------------------------------------------------------- /squeal-postgresql-uuid-ossp/src/Squeal/PostgreSQL/UUID/OSSP.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module: Squeal.PostgreSQL.UUID.OSSP 3 | Description: uuid-ossp 4 | Copyright: (c) Eitan Chatav, 2020 5 | Maintainer: eitan@morphism.tech 6 | Stability: experimental 7 | 8 | This module provides functions to generate universally 9 | unique identifiers (UUIDs) using one of several standard algorithms. 10 | There are also functions to produce certain special UUID constants. 11 | -} 12 | 13 | {-# LANGUAGE 14 | DataKinds 15 | , OverloadedStrings 16 | , TypeOperators 17 | #-} 18 | 19 | module Squeal.PostgreSQL.UUID.OSSP 20 | ( -- * Definition 21 | createUuidOssp 22 | -- * Generation 23 | , uuidGenerateV1 24 | , uuidGenerateV1mc 25 | , uuidGenerateV3 26 | , uuidGenerateV4 27 | , uuidGenerateV5 28 | -- * Constants 29 | , uuidNil 30 | , uuidNSUrl 31 | , uuidNSDns 32 | , uuidNSOid 33 | , uuidNSX500 34 | ) where 35 | 36 | import Squeal.PostgreSQL 37 | 38 | -- | Loads ltree extension into the current database. 39 | createUuidOssp :: Definition db db 40 | createUuidOssp = UnsafeDefinition "CREATE EXTENSION \"uuid-ossp\";" 41 | 42 | -- | This function generates a version 1 UUID. 43 | -- This involves the MAC address of the computer and a time stamp. 44 | -- Note that UUIDs of this kind reveal the identity of the computer 45 | -- that created the identifier and the time at which it did so, 46 | -- which might make it unsuitable for certain security-sensitive applications. 47 | uuidGenerateV1 :: Expr (null 'PGuuid) 48 | uuidGenerateV1 = UnsafeExpression "uuid_generate_v1()" 49 | 50 | -- | This function generates a version 1 UUID but uses a random multicast 51 | -- MAC address instead of the real MAC address of the computer. 52 | uuidGenerateV1mc :: Expr (null 'PGuuid) 53 | uuidGenerateV1mc = UnsafeExpression "uuid_generate_v1mc()" 54 | 55 | {- | This function generates a version 3 UUID in the given namespace 56 | using the specified input name. The namespace should be one of the 57 | special constants produced by the uuidNS* functions. 58 | (It could be any UUID in theory.) 59 | The name is an identifier in the selected namespace. 60 | For example: 61 | @ 62 | uuidGenerateV3 (uuidNSUrl *: "http://www.postgresql.org") 63 | @ 64 | 65 | The name parameter will be MD5-hashed, 66 | so the cleartext cannot be derived from the generated UUID. 67 | The generation of UUIDs by this method has no random or 68 | environment-dependent element and is therefore reproducible. 69 | -} 70 | uuidGenerateV3 :: '[null 'PGuuid, null 'PGtext] ---> null 'PGuuid 71 | uuidGenerateV3 = unsafeFunctionN "uuid_generate_v3" 72 | 73 | {- | This function generates a version 4 UUID, 74 | which is derived entirely from random numbers. 75 | -} 76 | uuidGenerateV4 :: Expr (null 'PGuuid) 77 | uuidGenerateV4 = UnsafeExpression "uuid_generate_v4()" 78 | 79 | {- | This function generates a version 5 UUID, 80 | which works like a version 3 UUID except that 81 | SHA-1 is used as a hashing method. 82 | Version 5 should be preferred over version 3 because 83 | SHA-1 is thought to be more secure than MD5. 84 | -} 85 | uuidGenerateV5 :: '[null 'PGuuid, null 'PGtext] ---> null 'PGuuid 86 | uuidGenerateV5 = unsafeFunctionN "uuid_generate_v5" 87 | 88 | -- | A "nil" UUID constant, which does not occur as a real UUID. 89 | uuidNil :: Expr (null 'PGuuid) 90 | uuidNil = UnsafeExpression "uuid_nil()" 91 | 92 | -- | Constant designating the DNS namespace for UUIDs. 93 | uuidNSDns :: Expr (null 'PGuuid) 94 | uuidNSDns = UnsafeExpression "uuid_ns_dns()" 95 | 96 | -- | Constant designating the URL namespace for UUIDs. 97 | uuidNSUrl :: Expr (null 'PGuuid) 98 | uuidNSUrl = UnsafeExpression "uuid_ns_url()" 99 | 100 | -- | Constant designating the ISO object identifier (OID) namespace for UUIDs. 101 | -- (This pertains to ASN.1 OIDs, 102 | -- which are unrelated to the OIDs used in PostgreSQL.) 103 | uuidNSOid :: Expr (null 'PGuuid) 104 | uuidNSOid = UnsafeExpression "uuid_ns_oid()" 105 | 106 | -- | Constant designating the X.500 distinguished 107 | -- name (DN) namespace for UUIDs. 108 | uuidNSX500 :: Expr (null 'PGuuid) 109 | uuidNSX500 = UnsafeExpression "uuid_ns_x500()" 110 | -------------------------------------------------------------------------------- /squeal-postgresql/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017 Morphism, LLC 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 7 | met: 8 | 9 | * Redistributions of source code must retain the above copyright 10 | notice, this list of conditions and the following disclaimer. 11 | 12 | * Redistributions in binary form must reproduce the above 13 | copyright notice, this list of conditions and the following 14 | disclaimer in the documentation and/or other materials provided 15 | with the distribution. 16 | 17 | * Neither the names of the copyright holders nor the names of the 18 | contributors may be used to endorse or promote products derived 19 | from this software without specific prior written permission. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 24 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 25 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 26 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 27 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 28 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 29 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 30 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 31 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /squeal-postgresql/README.md: -------------------------------------------------------------------------------- 1 | # squeal-postgresql 2 | 3 | ![squeal-icon](https://raw.githubusercontent.com/morphismtech/squeal/dev/squeal.gif) 4 | 5 | [![GithubWorkflowCI](https://github.com/morphismtech/squeal/actions/workflows/ci.yml/badge.svg)](https://github.com/morphismtech/squeal/actions/workflows/ci.yml) 6 | 7 | [Github](https://github.com/morphismtech/squeal) 8 | 9 | [Hackage](https://hackage.haskell.org/package/squeal-postgresql) 10 | 11 | [Stackage](https://www.stackage.org/package/squeal-postgresql) 12 | -------------------------------------------------------------------------------- /squeal-postgresql/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /squeal-postgresql/bench/Gauge.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE OverloadedLabels #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE TypeApplications #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | {-# LANGUAGE GADTs #-} 9 | {-# LANGUAGE DeriveGeneric #-} 10 | {-# LANGUAGE ScopedTypeVariables #-} 11 | 12 | module Main where 13 | 14 | import Squeal.PostgreSQL hiding ( defaultMain ) 15 | import Gauge.Main 16 | import Gauge.Main.Options ( defaultConfig 17 | , Config(..) 18 | , Verbosity(..) 19 | , DisplayMode(..) 20 | , Mode(..) 21 | ) 22 | import GHC.Generics 23 | import qualified Generics.SOP as SOP 24 | import Test.QuickCheck 25 | -- For CI 26 | import Main.Utf8 ( withUtf8 ) 27 | -- For keeping a track of which question ID to query 28 | import Data.Int ( Int64 ) 29 | import Data.IORef 30 | -- Project imports 31 | import Gauge.Schema 32 | import Gauge.Queries 33 | import Gauge.DBSetup ( teardownDB ) 34 | import Gauge.DBHelpers ( initDBWithPool 35 | , getRandomUser 36 | , runDbWithPool 37 | , SquealPool 38 | ) 39 | 40 | main :: IO () 41 | main = do 42 | -- A mutable hack here to keep track of 43 | -- pulling a new user by ID from the db instead of the same id 44 | currentId <- newIORef (1 :: UserId) 45 | 46 | -- Define benchmarks 47 | let 48 | queryRenderGroup :: Benchmark 49 | queryRenderGroup = bgroup 50 | "Render Queries" 51 | [ bench "createUser: weak head normal form" $ whnf renderSQL createUser 52 | , bench "createUser: normal form" $ nf renderSQL createUser 53 | , bench "userDetails: weak head normal form" $ whnf renderSQL userDetails 54 | , bench "userDetails: normal form" $ nf renderSQL userDetails 55 | , bench "insertDeviceDetails: weak head normal form" 56 | $ whnf renderSQL insertDeviceDetails 57 | , bench "insertDeviceDetails: normal form" 58 | $ nf renderSQL insertDeviceDetails 59 | ] 60 | 61 | -- Queries against an actual DB 62 | 63 | -- 1. Initialize Schema to DB 64 | -- 2. Make connection pool and pass it to tests 65 | -- 3. Generate users on the fly and add them to DB 66 | -- 4. Tear the Schema down from the DB 67 | 68 | dbInsertsGroup :: Benchmark 69 | dbInsertsGroup = 70 | envWithCleanup initDBWithPool (const teardownDB) $ \pool -> bgroup 71 | "Run individual INSERTs against DB using a connection pool" 72 | [ bgroup 73 | "INSERT: add users to the table users" 74 | [ bench "Run individual INSERT statement" $ makeRunOnce $ perRunEnv 75 | getRandomUser 76 | -- The actual action to benchmark 77 | (\(user :: InsertUser) -> 78 | runDbWithPool pool $ createUserSession user 79 | ) 80 | ] 81 | ] 82 | 83 | dbSelectsGroup :: Benchmark 84 | dbSelectsGroup = 85 | envWithCleanup initDBWithPool (const teardownDB) $ \pool -> bgroup 86 | "Run individual SELECTs against DB using a connection pool" 87 | [ bgroup 88 | "SELECT: fetch users from the table users individually" 89 | [ bench "Fetch a single user" $ makeRunOnce $ perRunEnv 90 | (insertAndIncrement pool currentId) 91 | (\(id_ :: UserId) -> runDbWithPool pool $ userDetailsSession id_ 92 | ) 93 | ] 94 | ] 95 | 96 | withUtf8 $ defaultMain [queryRenderGroup, dbInsertsGroup, dbSelectsGroup] 97 | 98 | 99 | -- | Configure the benchmark to run only once (per IO action) 100 | makeRunOnce :: Benchmarkable -> Benchmarkable 101 | makeRunOnce current = current { perRun = True } 102 | 103 | getAndIncrementId :: (IORef UserId) -> IO UserId 104 | getAndIncrementId currentId = do 105 | current <- readIORef currentId 106 | writeIORef currentId (current + 1) 107 | return current 108 | 109 | -- | This INSERTs a row in the db so that there's always a row to query. 110 | -- Otherwise 'getRow 0' throws an exception. 111 | -- NOTE: will make benchmark time slower but does not affect results. 112 | insertAndIncrement :: SquealPool -> (IORef UserId) -> IO UserId 113 | insertAndIncrement pool currentId = do 114 | user <- getRandomUser 115 | _ <- runDbWithPool pool $ createUserSession user 116 | getAndIncrementId currentId 117 | -------------------------------------------------------------------------------- /squeal-postgresql/bench/Gauge/DBHelpers.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE OverloadedLabels #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE TypeApplications #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | {-# LANGUAGE GADTs #-} 9 | {-# LANGUAGE DeriveGeneric #-} 10 | {-# LANGUAGE DeriveAnyClass #-} 11 | {-# LANGUAGE DerivingStrategies #-} 12 | {-# LANGUAGE ScopedTypeVariables #-} 13 | {-# LANGUAGE StandaloneDeriving #-} 14 | 15 | module Gauge.DBHelpers where 16 | 17 | import qualified Data.ByteString.Char8 as C 18 | import qualified Data.Text as T 19 | import Control.Monad ( void ) 20 | import Control.Monad.IO.Class ( liftIO ) 21 | import Control.Monad.Loops ( iterateWhile ) 22 | import GHC.Generics ( Generic ) 23 | import Test.QuickCheck 24 | import Squeal.PostgreSQL 25 | import qualified Squeal.PostgreSQL.Session.Transaction.Unsafe as Unsafe 26 | import Control.DeepSeq 27 | -- Project imports 28 | import Gauge.Schema ( Schemas ) 29 | import Gauge.Queries ( InsertUser(..) ) 30 | import Gauge.DBSetup 31 | 32 | newtype SquealPool = SquealPool {getSquealPool :: Pool (K Connection Schemas)} deriving (Generic) 33 | -- Below may be wrong - it may screw up the whole connection pool using in tests 34 | instance NFData SquealPool where 35 | rnf = rwhnf 36 | 37 | runDbErr 38 | :: SquealPool -> PQ Schemas Schemas IO b -> IO (Either SquealException b) 39 | runDbErr pool session = do 40 | liftIO . runUsingConnPool pool $ trySqueal (Unsafe.transactionally_ session) 41 | 42 | runDbWithPool :: SquealPool -> PQ Schemas Schemas IO b -> IO b 43 | runDbWithPool pool session = do 44 | errOrResult <- runDbErr pool session 45 | case errOrResult of 46 | Left err -> throwSqueal err 47 | Right result -> return result 48 | 49 | -- | Helper 50 | runUsingConnPool :: SquealPool -> PQ Schemas Schemas IO x -> IO x 51 | runUsingConnPool (SquealPool pool) = usingConnectionPool pool 52 | 53 | makePool :: C.ByteString -> IO SquealPool 54 | makePool connStr = do 55 | pool <- createConnectionPool connStr 1 0.5 10 56 | return $ SquealPool pool 57 | 58 | initDBWithPool :: IO SquealPool 59 | initDBWithPool = do 60 | void initDB 61 | pool <- makePool connectionString 62 | return pool 63 | 64 | getRandomUser :: IO InsertUser 65 | getRandomUser = iterateWhile noEmptyEmail $ generate arbitrary 66 | where 67 | noEmptyEmail InsertUser { userEmail = userEmail } = T.length userEmail < 5 68 | -------------------------------------------------------------------------------- /squeal-postgresql/bench/Gauge/DBSetup.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE OverloadedLabels #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE TypeApplications #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | {-# LANGUAGE GADTs #-} 9 | {-# LANGUAGE DeriveGeneric #-} 10 | {-# LANGUAGE DeriveAnyClass #-} 11 | {-# LANGUAGE DerivingStrategies #-} 12 | {-# LANGUAGE ScopedTypeVariables #-} 13 | 14 | module Gauge.DBSetup where 15 | 16 | import Data.ByteString ( ByteString ) 17 | import qualified Data.ByteString.Char8 as C 18 | import Control.Monad ( void ) 19 | import GHC.Generics 20 | import Squeal.PostgreSQL 21 | -- Project imports 22 | import Gauge.Schema ( Schemas 23 | , DeviceOS 24 | , IPLocation 25 | ) 26 | 27 | 28 | -- First create enums as they're needed in the Schema 29 | setup :: Definition (Public '[]) Schemas 30 | setup = 31 | createTypeEnumFrom @DeviceOS #device_os 32 | >>> createTypeCompositeFrom @IPLocation #ip_location 33 | >>> createTable 34 | #users 35 | ( serial8 36 | `as` #id 37 | :* (text & notNullable) 38 | `as` #email 39 | :* (text & notNullable) 40 | `as` #password 41 | :* (text & nullable) 42 | `as` #first_name 43 | :* (int2 & nullable) 44 | `as` #birthyear 45 | ) 46 | (primaryKey #id `as` #pk_users :* unique #email `as` #email) 47 | >>> createTable 48 | #user_devices 49 | ( serial8 50 | `as` #id 51 | :* notNullable int8 52 | `as` #user_id 53 | :* (text & notNullable) 54 | `as` #token 55 | :* (typedef #device_os & notNullable) 56 | `as` #os 57 | ) 58 | ( primaryKey #id 59 | `as` #pk_user_devices 60 | :* foreignKey #user_id #users #id (OnDelete Cascade) (OnUpdate Cascade) 61 | `as` #fk_user_id 62 | :* unique #token 63 | `as` #token 64 | ) 65 | 66 | -- Drop types last because tables depend on them 67 | teardown :: Definition Schemas (Public '[]) 68 | teardown = 69 | dropTableCascade #user_devices 70 | >>> dropTableCascade #users 71 | >>> dropType #ip_location 72 | >>> dropType #device_os 73 | 74 | -- With env vars, we could use the commented keys 75 | data PGConfig = PGConfig 76 | { pgHost :: String -- "PG_HOST" 77 | , pgPort :: Int -- "PG_PORT" 78 | , pgDbname :: String -- "PG_DBNAME" 79 | , pgUser :: String -- "PG_USER" 80 | , pgPassword :: String -- "PG_PASSWORD" 81 | } 82 | deriving (Generic, Show) 83 | 84 | -- | Helper: unused now, but primarily for testing locally 85 | makeConnStr :: PGConfig -> ByteString 86 | makeConnStr PGConfig { pgHost = host, pgPort = portNumber, pgDbname = dbName, pgUser = user, pgPassword = pw } 87 | = C.pack 88 | $ "host=" 89 | <> host 90 | <> " dbname=" 91 | <> dbName 92 | <> " user=" 93 | <> user 94 | <> " password=" 95 | <> pw 96 | <> " port=" 97 | <> show portNumber 98 | 99 | connectionString :: ByteString 100 | connectionString = "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" 101 | 102 | performDBAction :: Definition a b -> String -> IO () 103 | performDBAction action message = do 104 | void 105 | $ withConnection connectionString 106 | $ manipulate_ (UnsafeManipulation "SET client_min_messages TO WARNING;") 107 | & pqThen (define action) 108 | putStrLn message 109 | 110 | initDB :: IO () 111 | initDB = 112 | performDBAction setup "Initialized Schema & corresponding tables for Database" 113 | 114 | teardownDB :: IO () 115 | teardownDB = performDBAction teardown "Dropped all database tables" 116 | 117 | dbSchema :: Definition '["public" ::: '[]] (Drop "public" '["public" ::: '[]]) 118 | dbSchema = dropSchemaCascade #public 119 | 120 | dropDBSchema :: IO () 121 | dropDBSchema = performDBAction dbSchema "Dropped Public schema from database" 122 | 123 | -- | Concatenate two `ByteString`s with a space between. 124 | (<+>) :: ByteString -> ByteString -> ByteString 125 | infixr 7 <+> 126 | str1 <+> str2 = str1 <> " " <> str2 127 | 128 | -- | Drop table custom SQL statement with 'cascade' 129 | dropTableCascade 130 | :: (Has sch schemas schema, Has tab schema ( 'Table table)) 131 | => QualifiedAlias sch tab -- ^ table to remove 132 | -> Definition schemas (Alter sch (Drop tab schema) schemas) 133 | dropTableCascade tab = 134 | UnsafeDefinition $ "DROP TABLE" <+> renderSQL tab <> " cascade;" 135 | -------------------------------------------------------------------------------- /squeal-postgresql/bench/Gauge/Queries.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE OverloadedLabels #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE TypeApplications #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | {-# LANGUAGE GADTs #-} 9 | {-# LANGUAGE DeriveGeneric #-} 10 | {-# LANGUAGE DeriveAnyClass #-} 11 | {-# LANGUAGE DerivingStrategies #-} 12 | 13 | module Gauge.Queries where 14 | 15 | import Squeal.PostgreSQL 16 | import GHC.Generics ( Generic ) 17 | import qualified Generics.SOP as SOP 18 | -- Need below for deriving instances 19 | import Control.DeepSeq 20 | import Data.Text ( Text ) 21 | import Data.Int ( Int16 22 | , Int64 23 | ) 24 | import Test.QuickCheck ( Arbitrary(..) ) 25 | import Generic.Random ( genericArbitrarySingle ) 26 | -- Import Orphan instances 27 | import Test.QuickCheck.Instances ( ) 28 | -- Project imports 29 | import Gauge.Schema 30 | 31 | -- Types 32 | 33 | type UserId = Int64 34 | -- Insert user 35 | data InsertUser = InsertUser 36 | { userEmail :: Text 37 | , userPassword :: Text 38 | , userFirstName :: Maybe Text 39 | , userBirthyear :: Maybe Int16 40 | } 41 | deriving (Show, Eq, Generic, NFData) 42 | instance SOP.Generic InsertUser 43 | instance SOP.HasDatatypeInfo InsertUser 44 | -- Arbitrary instances for producing values with quickcheck 45 | instance Arbitrary InsertUser where 46 | arbitrary = genericArbitrarySingle 47 | 48 | sampleInsertUser :: InsertUser 49 | sampleInsertUser = InsertUser { userEmail = "mark@gmail.com" 50 | , userPassword = "MySecretPassword" 51 | , userFirstName = Just "Mark" 52 | , userBirthyear = Just 1980 53 | } 54 | 55 | data APIDBUser_ = APIDBUser_ 56 | { userId :: UserId 57 | , email :: Text 58 | , first_name :: Maybe Text 59 | , birthyear :: Maybe Int16 60 | } 61 | deriving (Show, Eq, Generic, NFData) 62 | instance SOP.Generic APIDBUser_ 63 | instance SOP.HasDatatypeInfo APIDBUser_ 64 | -- Arbitrary instances for producing values with quickcheck 65 | instance Arbitrary APIDBUser_ where 66 | arbitrary = genericArbitrarySingle 67 | 68 | data Row3 a b c = Row4 69 | { col1 :: a 70 | , col2 :: b 71 | , col3 :: c 72 | } 73 | deriving stock Generic 74 | deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) 75 | 76 | -- (UserId, Token, OS) 77 | type DeviceDetailsRow = Row3 UserId Text (Enumerated DeviceOS) 78 | 79 | -- -- Queries 80 | 81 | createUserSession :: InsertUser -> PQ Schemas Schemas IO APIDBUser_ 82 | createUserSession insertUser = 83 | getRow 0 =<< manipulateParams createUser insertUser 84 | 85 | createUser :: Manipulation_ Schemas InsertUser APIDBUser_ 86 | createUser = insertInto 87 | #users 88 | (Values_ 89 | ( Default 90 | `as` #id 91 | :* Set (param @1) 92 | `as` #email 93 | :* Set (param @2) 94 | `as` #password 95 | :* Set (param @3) 96 | `as` #first_name 97 | :* Set (param @4 & cast int2) 98 | `as` #birthyear 99 | ) 100 | ) 101 | OnConflictDoRaise 102 | (Returning_ 103 | ( #id 104 | `as` #userId 105 | :* #email 106 | `as` #email 107 | :* #first_name 108 | `as` #first_name 109 | :* #birthyear 110 | `as` #birthyear 111 | ) 112 | ) 113 | 114 | userDetailsSession :: UserId -> PQ Schemas Schemas IO APIDBUser_ 115 | userDetailsSession uID = getRow 0 =<< runQueryParams userDetails (Only uID) 116 | 117 | userDetails :: Query_ Schemas (Only UserId) APIDBUser_ 118 | userDetails = select_ 119 | ( #id 120 | `as` #userId 121 | :* #email 122 | `as` #email 123 | :* #first_name 124 | `as` #first_name 125 | :* #birthyear 126 | `as` #birthyear 127 | ) 128 | (from (table #users) & where_ (#id .== (param @1 & cast int8))) 129 | 130 | insertDeviceDetails :: Manipulation_ Schemas DeviceDetailsRow () 131 | insertDeviceDetails = insertInto 132 | #user_devices 133 | (Values_ 134 | ( Default 135 | `as` #id 136 | :* Set (param @1) 137 | `as` #user_id 138 | :* Set (param @2) 139 | `as` #token 140 | :* Set (parameter @3 (typedef #device_os)) 141 | `as` #os 142 | ) 143 | ) 144 | OnConflictDoRaise 145 | (Returning_ Nil) 146 | -------------------------------------------------------------------------------- /squeal-postgresql/bench/Gauge/Schema.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE OverloadedLabels #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE TypeApplications #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | {-# LANGUAGE GADTs #-} 9 | {-# LANGUAGE DeriveGeneric #-} 10 | 11 | module Gauge.Schema where 12 | 13 | import Squeal.PostgreSQL 14 | import GHC.Generics 15 | import qualified Generics.SOP as SOP 16 | 17 | 18 | -- Type 19 | 20 | data DeviceOS = Android | IOS 21 | deriving (Show, Read, Eq, Generic) 22 | -- DeviceOS is converted to PG Enum type 23 | instance SOP.Generic DeviceOS 24 | instance SOP.HasDatatypeInfo DeviceOS 25 | 26 | -- Defined extra types for the database 27 | -- Operating system enum 28 | type PGDeviceOS = PG (Enumerated DeviceOS) 29 | type DeviceOSType = 'Typedef PGDeviceOS 30 | 31 | -- For composite type 32 | data IPLocation = IPLocation 33 | { countryShort :: String 34 | , region :: String 35 | , city :: String 36 | } 37 | deriving (Show, Read, Eq, Generic) 38 | 39 | instance SOP.Generic IPLocation 40 | instance SOP.HasDatatypeInfo IPLocation 41 | 42 | -- IPLocation Composite type 43 | type PGIPLocation = PG (Composite IPLocation) 44 | type IPLocationType = 'Typedef PGIPLocation 45 | 46 | -- SCHEMA 47 | 48 | -- Users 49 | 50 | type UsersColumns = '[ 51 | "id" ::: 'Def :=> 'NotNull 'PGint8 52 | , "email" ::: 'NoDef :=> 'NotNull 'PGtext 53 | , "password" ::: 'NoDef :=> 'NotNull 'PGtext 54 | , "first_name" ::: 'NoDef :=> 'Null 'PGtext 55 | , "birthyear" ::: 'NoDef :=> 'Null 'PGint2 56 | ] 57 | 58 | type UsersConstraints = '[ 59 | "pk_users" ::: 'PrimaryKey '["id"] 60 | , "email" ::: 'Unique '["email"] 61 | ] 62 | 63 | type UsersTable = 'Table (UsersConstraints :=> UsersColumns) 64 | 65 | -- User devices 66 | type UserDevicesColumns = '[ 67 | "id" ::: 'Def :=> 'NotNull 'PGint8 -- ID as PK because user might have many same OS devices 68 | , "user_id" ::: 'NoDef :=> 'NotNull 'PGint8 69 | , "token" ::: 'NoDef :=> 'NotNull 'PGtext 70 | , "os" ::: 'NoDef :=> 'NotNull PGDeviceOS 71 | ] 72 | 73 | type UserDevicesConstraints = '[ 74 | "pk_user_devices" ::: 'PrimaryKey '["id"] 75 | , "fk_user_id" ::: 'ForeignKey '["user_id"] "public" "users" '["id"] 76 | , "token" ::: 'Unique '["token"] 77 | ] 78 | 79 | type UserDevicesTable = 'Table (UserDevicesConstraints :=> UserDevicesColumns) 80 | 81 | -- Schema 82 | -- Make sure to put types before tables, otherwise won't compile 83 | type Schema = '[ 84 | -- Enum types: 85 | "device_os" ::: DeviceOSType 86 | -- Composite types: 87 | , "ip_location" ::: IPLocationType 88 | -- Tables: 89 | , "users" ::: UsersTable 90 | , "user_devices" ::: UserDevicesTable 91 | ] 92 | 93 | type Schemas = '["public" ::: Schema] 94 | -------------------------------------------------------------------------------- /squeal-postgresql/bench/README.md: -------------------------------------------------------------------------------- 1 | # Microbenchark suite for Squeal 2 | > Benchmarking & profiling query rendering performance 3 | 4 | ## Running 5 | 6 | Run benchmark suite with: 7 | ``` 8 | stack bench 9 | ``` 10 | -------------------------------------------------------------------------------- /squeal-postgresql/docs-upload.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | # Run this script in the top-level of your package directory 4 | # (where the .cabal file is) to compile documentation and 5 | # upload it to hackage. 6 | 7 | # Requirements: 8 | # cabal-install-1.24 (for --for-hackage) 9 | # haddock 2.17 (for the hyperlinked source) 10 | 11 | set -e 12 | 13 | dir=$(mktemp -d dist-docs.XXXXXX) 14 | trap 'rm -r "$dir"' EXIT 15 | 16 | cabal configure --builddir="$dir" 17 | cabal haddock --builddir="$dir" --for-hackage --haddock-option=--hyperlinked-source 18 | cabal upload -d $dir/*-docs.tar.gz 19 | -------------------------------------------------------------------------------- /squeal-postgresql/squeal-postgresql.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | name: squeal-postgresql 3 | version: 0.9.2.0 4 | synopsis: Squeal PostgreSQL Library 5 | description: Squeal is a type-safe embedding of PostgreSQL in Haskell 6 | homepage: https://github.com/morphismtech/squeal 7 | bug-reports: https://github.com/morphismtech/squeal/issues 8 | license: BSD-3-Clause 9 | license-file: LICENSE 10 | author: Eitan Chatav 11 | maintainer: eitan.chatav@gmail.com 12 | copyright: Copyright (c) 2022 Morphism, LLC 13 | category: Database 14 | build-type: Simple 15 | extra-doc-files: README.md 16 | 17 | source-repository head 18 | type: git 19 | location: https://github.com/morphismtech/squeal.git 20 | 21 | library 22 | hs-source-dirs: src 23 | exposed-modules: 24 | Squeal.PostgreSQL 25 | Squeal.PostgreSQL.Definition 26 | Squeal.PostgreSQL.Definition.Comment 27 | Squeal.PostgreSQL.Definition.Constraint 28 | Squeal.PostgreSQL.Definition.Function 29 | Squeal.PostgreSQL.Definition.Index 30 | Squeal.PostgreSQL.Definition.Table 31 | Squeal.PostgreSQL.Definition.Type 32 | Squeal.PostgreSQL.Definition.Procedure 33 | Squeal.PostgreSQL.Definition.Schema 34 | Squeal.PostgreSQL.Definition.View 35 | Squeal.PostgreSQL.Expression 36 | Squeal.PostgreSQL.Expression.Aggregate 37 | Squeal.PostgreSQL.Expression.Array 38 | Squeal.PostgreSQL.Expression.Comparison 39 | Squeal.PostgreSQL.Expression.Composite 40 | Squeal.PostgreSQL.Expression.Default 41 | Squeal.PostgreSQL.Expression.Json 42 | Squeal.PostgreSQL.Expression.Inline 43 | Squeal.PostgreSQL.Expression.Logic 44 | Squeal.PostgreSQL.Expression.Math 45 | Squeal.PostgreSQL.Expression.Null 46 | Squeal.PostgreSQL.Expression.Parameter 47 | Squeal.PostgreSQL.Expression.Range 48 | Squeal.PostgreSQL.Expression.Sort 49 | Squeal.PostgreSQL.Expression.Subquery 50 | Squeal.PostgreSQL.Expression.Text 51 | Squeal.PostgreSQL.Expression.TextSearch 52 | Squeal.PostgreSQL.Expression.Time 53 | Squeal.PostgreSQL.Expression.Type 54 | Squeal.PostgreSQL.Expression.Window 55 | Squeal.PostgreSQL.Manipulation 56 | Squeal.PostgreSQL.Manipulation.Call 57 | Squeal.PostgreSQL.Manipulation.Delete 58 | Squeal.PostgreSQL.Manipulation.Insert 59 | Squeal.PostgreSQL.Manipulation.Update 60 | Squeal.PostgreSQL.Render 61 | Squeal.PostgreSQL.Query 62 | Squeal.PostgreSQL.Query.From 63 | Squeal.PostgreSQL.Query.From.Join 64 | Squeal.PostgreSQL.Query.From.Set 65 | Squeal.PostgreSQL.Query.Select 66 | Squeal.PostgreSQL.Query.Table 67 | Squeal.PostgreSQL.Query.Values 68 | Squeal.PostgreSQL.Query.With 69 | Squeal.PostgreSQL.Session 70 | Squeal.PostgreSQL.Session.Connection 71 | Squeal.PostgreSQL.Session.Decode 72 | Squeal.PostgreSQL.Session.Encode 73 | Squeal.PostgreSQL.Session.Exception 74 | Squeal.PostgreSQL.Session.Indexed 75 | Squeal.PostgreSQL.Session.Migration 76 | Squeal.PostgreSQL.Session.Monad 77 | Squeal.PostgreSQL.Session.Oid 78 | Squeal.PostgreSQL.Session.Pool 79 | Squeal.PostgreSQL.Session.Result 80 | Squeal.PostgreSQL.Session.Statement 81 | Squeal.PostgreSQL.Session.Transaction 82 | Squeal.PostgreSQL.Session.Transaction.Unsafe 83 | Squeal.PostgreSQL.Type 84 | Squeal.PostgreSQL.Type.Alias 85 | Squeal.PostgreSQL.Type.List 86 | Squeal.PostgreSQL.Type.PG 87 | Squeal.PostgreSQL.Type.Schema 88 | default-language: Haskell2010 89 | ghc-options: -Wall 90 | build-depends: 91 | aeson >= 1.4.7.1 92 | , base >= 4.12.0.0 && < 5.0 93 | , binary >= 0.8.7.0 94 | , binary-parser >= 0.5.5 95 | , bytestring >= 0.10.10.0 96 | , bytestring-strict-builder >= 0.4.5.3 97 | , deepseq >= 1.4.4.0 98 | , exceptions >= 0.10.3 99 | , free-categories >= 0.2.0.0 100 | , generics-sop >= 0.5.1.0 101 | , hashable >= 1.3.0.0 102 | , iproute >= 1.7.0 103 | , mmorph >= 1.1.3 104 | , monad-control >= 1.0.2.3 105 | , mtl >= 2.2.2 106 | , network-ip >= 0.3.0.3 107 | , postgresql-binary >= 0.12.2 108 | , postgresql-libpq >= 0.9.4.2 109 | , profunctors >= 5.5.2 110 | , records-sop >= 0.1.0.3 111 | , resource-pool >= 0.2.3.2 112 | , scientific >= 0.3.6.2 113 | , text >= 1.2.3.2 114 | , time >= 1.9.3 115 | , transformers >= 0.5.6.2 116 | , transformers-base >= 0.4.5.2 117 | , unliftio >= 0.2.12.1 118 | , uuid-types >= 1.0.3 119 | , vector >= 0.12.1.2 120 | 121 | test-suite doctest 122 | default-language: Haskell2010 123 | type: exitcode-stdio-1.0 124 | hs-source-dirs: test 125 | ghc-options: -Wall 126 | main-is: Doc.hs 127 | build-depends: 128 | base >= 4.12.0.0 && < 5.0 129 | , doctest >= 0.16.3 130 | if impl(ghc >= 9.0.0) 131 | buildable: False 132 | 133 | test-suite properties 134 | default-language: Haskell2010 135 | type: exitcode-stdio-1.0 136 | hs-source-dirs: test 137 | ghc-options: -Wall 138 | main-is: Property.hs 139 | build-depends: 140 | base >= 4.12.0.0 && < 5.0 141 | , bytestring >= 0.10.10.0 142 | , hedgehog >= 1.0.2 143 | , generics-sop >= 0.5.1.0 144 | , mtl >= 2.2.2 145 | , scientific >= 0.3.6.2 146 | , squeal-postgresql 147 | , time >= 1.9.3 148 | , with-utf8 >= 1.0 149 | 150 | test-suite spec 151 | default-language: Haskell2010 152 | type: exitcode-stdio-1.0 153 | hs-source-dirs: test 154 | ghc-options: -Wall 155 | main-is: Spec.hs 156 | build-depends: 157 | async >= 2.2.2 158 | , base >= 4.12.0.0 && < 5.0 159 | , bytestring >= 0.10.10.0 160 | , generics-sop >= 0.5.1.0 161 | , hspec >= 2.7.1 162 | , mtl >= 2.2.2 163 | , squeal-postgresql 164 | , text >= 1.2.3.2 165 | , vector >= 0.12.1.2 166 | 167 | benchmark gauge 168 | type: exitcode-stdio-1.0 169 | hs-source-dirs: bench 170 | main-is: Gauge.hs 171 | other-modules: 172 | Gauge.DBHelpers 173 | , Gauge.DBSetup 174 | , Gauge.Queries 175 | , Gauge.Schema 176 | default-language: Haskell2010 177 | ghc-options: 178 | -O2 179 | -threaded 180 | "-with-rtsopts=-N" 181 | -rtsopts 182 | -funbox-strict-fields 183 | build-depends: 184 | base >= 4.12.0.0 && < 5.0 185 | , bytestring >= 0.10.10.0 186 | , deepseq >= 1.4.4.0 187 | , gauge >= 0.2.5 188 | , generic-random >= 1.3.0.1 189 | , generics-sop >= 0.5.1.0 190 | , monad-loops >= 0.4.3 191 | , mtl >= 2.2.2 192 | , QuickCheck >= 2.13.2 193 | , quickcheck-instances >= 0.3.22 194 | , scientific >= 0.3.6.2 195 | , squeal-postgresql 196 | , text >= 1.2.3.2 197 | , with-utf8 >= 1.0 198 | 199 | executable example 200 | default-language: Haskell2010 201 | hs-source-dirs: exe 202 | ghc-options: -Wall 203 | main-is: Example.hs 204 | build-depends: 205 | base >= 4.10.0.0 && < 5.0 206 | , bytestring >= 0.10.10.0 207 | , generics-sop >= 0.5.1.0 208 | , mtl >= 2.2.2 209 | , squeal-postgresql 210 | , text >= 1.2.3.2 211 | , transformers >= 0.5.6.2 212 | , vector >= 0.12.1.2 213 | -------------------------------------------------------------------------------- /squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module: Squeal.PostgreSQL.Definition 3 | Description: data definition language 4 | Copyright: (c) Eitan Chatav, 2019 5 | Maintainer: eitan@morphism.tech 6 | Stability: experimental 7 | 8 | data definition language 9 | -} 10 | 11 | {-# LANGUAGE 12 | AllowAmbiguousTypes 13 | , ConstraintKinds 14 | , DeriveAnyClass 15 | , DeriveGeneric 16 | , DerivingStrategies 17 | , FlexibleContexts 18 | , FlexibleInstances 19 | , GADTs 20 | , LambdaCase 21 | , MultiParamTypeClasses 22 | , OverloadedLabels 23 | , OverloadedStrings 24 | , RankNTypes 25 | , ScopedTypeVariables 26 | , TypeApplications 27 | , DataKinds 28 | , PolyKinds 29 | , TypeOperators 30 | , UndecidableSuperClasses 31 | , UndecidableInstances 32 | #-} 33 | 34 | module Squeal.PostgreSQL.Definition 35 | ( -- * Definition 36 | Definition (..) 37 | , (>>>) 38 | , manipulation_ 39 | ) where 40 | 41 | import Control.Category 42 | import Control.DeepSeq 43 | import Data.ByteString 44 | import Data.Monoid 45 | import Prelude hiding ((.), id) 46 | 47 | import qualified GHC.Generics as GHC 48 | 49 | import Squeal.PostgreSQL.Manipulation 50 | import Squeal.PostgreSQL.Render 51 | import Squeal.PostgreSQL.Type.Schema 52 | 53 | -- $setup 54 | -- >>> import Squeal.PostgreSQL 55 | 56 | {----------------------------------------- 57 | statements 58 | -----------------------------------------} 59 | 60 | -- | A `Definition` is a statement that changes the schemas of the 61 | -- database, like a `Squeal.PostgreSQL.Definition.Table.createTable`, 62 | -- `Squeal.PostgreSQL.Definition.Table.dropTable`, 63 | -- or `Squeal.PostgreSQL.Definition.Table.alterTable` command. 64 | -- `Definition`s may be composed using the `>>>` operator. 65 | newtype Definition 66 | (db0 :: SchemasType) 67 | (db1 :: SchemasType) 68 | = UnsafeDefinition { renderDefinition :: ByteString } 69 | deriving (GHC.Generic,Show,Eq,Ord,NFData) 70 | 71 | instance RenderSQL (Definition db0 db1) where 72 | renderSQL = renderDefinition 73 | 74 | instance Category Definition where 75 | id = UnsafeDefinition ";" 76 | ddl1 . ddl0 = UnsafeDefinition $ 77 | renderSQL ddl0 <> "\n" <> renderSQL ddl1 78 | 79 | instance db0 ~ db1 => Semigroup (Definition db0 db1) where (<>) = (>>>) 80 | instance db0 ~ db1 => Monoid (Definition db0 db1) where mempty = id 81 | 82 | -- | A `Manipulation` without input or output can be run as a statement 83 | -- along with other `Definition`s, by embedding it using `manipulation_`. 84 | manipulation_ 85 | :: Manipulation '[] db '[] '[] 86 | -- ^ no input or output 87 | -> Definition db db 88 | manipulation_ = UnsafeDefinition . (<> ";") . renderSQL 89 | -------------------------------------------------------------------------------- /squeal-postgresql/src/Squeal/PostgreSQL/Definition/Comment.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Module: Squeal.PostgreSQL.Definition.Constraint 3 | Description: comments 4 | Copyright: (c) Eitan Chatav, 2020 5 | Maintainer: eitan@morphism.tech 6 | Stability: experimental 7 | 8 | comments 9 | -} 10 | 11 | {-# LANGUAGE 12 | AllowAmbiguousTypes 13 | , ConstraintKinds 14 | , DeriveAnyClass 15 | , DeriveGeneric 16 | , DerivingStrategies 17 | , FlexibleContexts 18 | , FlexibleInstances 19 | , GADTs 20 | , LambdaCase 21 | , MultiParamTypeClasses 22 | , OverloadedLabels 23 | , OverloadedStrings 24 | , RankNTypes 25 | , ScopedTypeVariables 26 | , TypeApplications 27 | , DataKinds 28 | , PolyKinds 29 | , TypeOperators 30 | , UndecidableSuperClasses 31 | #-} 32 | 33 | module Squeal.PostgreSQL.Definition.Comment 34 | ( commentOnTable 35 | , commentOnType 36 | , commentOnView 37 | , commentOnFunction 38 | , commentOnIndex 39 | , commentOnColumn 40 | , commentOnSchema 41 | ) where 42 | 43 | import Squeal.PostgreSQL.Definition 44 | import Squeal.PostgreSQL.Type.Alias 45 | import Squeal.PostgreSQL.Render 46 | import Squeal.PostgreSQL.Type.Schema 47 | import GHC.TypeLits (KnownSymbol) 48 | import Data.Text (Text) 49 | 50 | {----------------------------------------- 51 | COMMENT statements 52 | -----------------------------------------} 53 | 54 | {- | 55 | When a user views a table in the database (i.e. with \d+ ), it is useful 56 | to be able to read a description of the table. 57 | -} 58 | commentOnTable 59 | :: ( KnownSymbol sch 60 | , KnownSymbol tab 61 | , Has sch db schema 62 | , Has tab schema ('Table table) 63 | ) 64 | => QualifiedAlias sch tab -- ^ table 65 | -> Text -- ^ comment 66 | -> Definition db db 67 | commentOnTable alias comm = UnsafeDefinition $ 68 | "COMMENT ON TABLE" <+> renderSQL alias <+> "IS" <+> singleQuotedText comm <> ";" 69 | 70 | {- | 71 | When a user views a type in the database (i.e with \dT ), it is useful to 72 | be able to read a description of the type. 73 | -} 74 | commentOnType 75 | :: ( KnownSymbol sch 76 | , KnownSymbol typ 77 | , Has sch db schema 78 | , Has typ schema ('Typedef type_) 79 | ) 80 | => QualifiedAlias sch typ -- ^ type 81 | -> Text -- ^ comment 82 | -> Definition db db 83 | commentOnType alias comm = UnsafeDefinition $ 84 | "COMMENT ON TYPE" <+> renderSQL alias <+> "IS" <+> singleQuotedText comm <> ";" 85 | 86 | {- | 87 | When a user views a view in the database (i.e. with \dv ), it is useful 88 | to be able to read a description of the view. 89 | -} 90 | commentOnView 91 | :: ( KnownSymbol sch 92 | , KnownSymbol vie 93 | , Has sch db schema 94 | , Has vie schema ('View view) 95 | ) 96 | => QualifiedAlias sch vie -- ^ view 97 | -> Text -- ^ comment 98 | -> Definition db db 99 | commentOnView alias comm = UnsafeDefinition $ 100 | "COMMENT ON VIEW" <+> renderSQL alias <+> "IS" <+> singleQuotedText comm <> ";" 101 | 102 | {- | 103 | When a user views an index in the database (i.e. with \di+ ), it is 104 | useful to be able to read a description of the index. 105 | -} 106 | commentOnIndex 107 | :: ( KnownSymbol sch 108 | , KnownSymbol ind 109 | , Has sch db schema 110 | , Has ind schema ('Index index) 111 | ) 112 | => QualifiedAlias sch ind -- ^ index 113 | -> Text -- ^ comment 114 | -> Definition db db 115 | commentOnIndex alias comm = UnsafeDefinition $ 116 | "COMMENT ON INDEX" <+> renderSQL alias <+> "IS" <+> singleQuotedText comm <> ";" 117 | 118 | {- | 119 | When a user views a function in the database (i.e. with \df+ ), it is 120 | useful to be able to read a description of the function. 121 | -} 122 | commentOnFunction 123 | :: ( KnownSymbol sch 124 | , KnownSymbol fun 125 | , Has sch db schema 126 | , Has fun schema ('Function function) 127 | ) 128 | => QualifiedAlias sch fun -- ^ function 129 | -> Text -- ^ comment 130 | -> Definition db db 131 | commentOnFunction alias comm = UnsafeDefinition $ 132 | "COMMENT ON FUNCTION" <+> renderSQL alias <+> "IS" <+> singleQuotedText comm <> ";" 133 | 134 | {- | 135 | When a user views a table in the database (i.e. with \d+
), it is useful 136 | to be able to view descriptions of the columns in that table. 137 | -} 138 | commentOnColumn 139 | :: ( KnownSymbol sch 140 | , KnownSymbol tab 141 | , KnownSymbol col 142 | , Has sch db schema 143 | , Has tab schema ('Table '(cons, cols)) 144 | , Has col cols '(def, nulltyp) 145 | ) 146 | => QualifiedAlias sch tab -- ^ table 147 | -> Alias col -- ^ column 148 | -> Text -- ^ comment 149 | -> Definition db db 150 | commentOnColumn table col comm = UnsafeDefinition $ 151 | "COMMENT ON COLUMN" <+> renderSQL table <> "." <> renderSQL col <+> "IS" 152 | <+> singleQuotedText comm <> ";" 153 | 154 | {- | 155 | When a user views a schema in the database (i.e. with \dn+ ), it is 156 | useful to be able to read a description. 157 | -} 158 | commentOnSchema 159 | :: ( KnownSymbol sch 160 | , Has sch db schema 161 | ) 162 | => Alias sch -- ^ schema 163 | -> Text -- ^ comment 164 | -> Definition db db 165 | commentOnSchema schema comm = UnsafeDefinition $ 166 | "COMMENT ON SCHEMA" <+> renderSQL schema <> "IS" <+> singleQuotedText comm <> ";" 167 | -------------------------------------------------------------------------------- /squeal-postgresql/src/Squeal/PostgreSQL/Definition/Index.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module: Squeal.PostgreSQL.Definition.Index 3 | Description: create and drop indexes 4 | Copyright: (c) Eitan Chatav, 2019 5 | Maintainer: eitan@morphism.tech 6 | Stability: experimental 7 | 8 | create and drop indexes 9 | -} 10 | 11 | {-# LANGUAGE 12 | AllowAmbiguousTypes 13 | , ConstraintKinds 14 | , DeriveAnyClass 15 | , DeriveGeneric 16 | , DerivingStrategies 17 | , FlexibleContexts 18 | , FlexibleInstances 19 | , GADTs 20 | , LambdaCase 21 | , MultiParamTypeClasses 22 | , OverloadedLabels 23 | , OverloadedStrings 24 | , RankNTypes 25 | , ScopedTypeVariables 26 | , TypeApplications 27 | , DataKinds 28 | , PolyKinds 29 | , TypeOperators 30 | , UndecidableSuperClasses 31 | #-} 32 | 33 | module Squeal.PostgreSQL.Definition.Index 34 | ( -- * Create 35 | createIndex 36 | , createIndexIfNotExists 37 | -- * Drop 38 | , dropIndex 39 | , dropIndexIfExists 40 | -- * Index Method 41 | , IndexMethod (..) 42 | , btree 43 | , hash 44 | , gist 45 | , spgist 46 | , gin 47 | , brin 48 | ) where 49 | 50 | import Data.ByteString 51 | import GHC.TypeLits 52 | 53 | import qualified GHC.Generics as GHC 54 | 55 | import Squeal.PostgreSQL.Type.Alias 56 | import Squeal.PostgreSQL.Definition 57 | import Squeal.PostgreSQL.Expression.Sort 58 | import Squeal.PostgreSQL.Render 59 | import Squeal.PostgreSQL.Type.Schema 60 | 61 | -- $setup 62 | -- >>> import Squeal.PostgreSQL 63 | -- >>> :set -XPolyKinds 64 | 65 | {- | Create an index. 66 | 67 | >>> :{ 68 | type Table = '[] :=> 69 | '[ "a" ::: 'NoDef :=> 'Null 'PGint4 70 | , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ] 71 | :} 72 | 73 | >>> :{ 74 | let 75 | setup :: Definition (Public '[]) (Public '["tab" ::: 'Table Table, "ix" ::: 'Index 'Btree]) 76 | setup = 77 | createTable #tab (nullable int `as` #a :* nullable real `as` #b) Nil >>> 78 | createIndex #ix #tab btree [#a & AscNullsFirst, #b & AscNullsLast] 79 | in printSQL setup 80 | :} 81 | CREATE TABLE "tab" ("a" int NULL, "b" real NULL); 82 | CREATE INDEX "ix" ON "tab" USING btree (("a") ASC NULLS FIRST, ("b") ASC NULLS LAST); 83 | -} 84 | createIndex 85 | :: (Has sch db schema, Has tab schema ('Table table), KnownSymbol ix) 86 | => Alias ix -- ^ index alias 87 | -> QualifiedAlias sch tab -- ^ table alias 88 | -> IndexMethod method -- ^ index method 89 | -> [SortExpression 'Ungrouped '[] '[] db '[] '[tab ::: TableToRow table]] 90 | -- ^ sorted columns 91 | -> Definition db (Alter sch (Create ix ('Index method) schema) db) 92 | createIndex ix tab method cols = UnsafeDefinition $ 93 | "CREATE" <+> "INDEX" <+> renderSQL ix <+> "ON" <+> renderSQL tab 94 | <+> "USING" <+> renderSQL method 95 | <+> parenthesized (commaSeparated (renderIndex <$> cols)) 96 | <> ";" 97 | where 98 | renderIndex = \case 99 | Asc expression -> parenthesized (renderSQL expression) <+> "ASC" 100 | Desc expression -> parenthesized (renderSQL expression) <+> "DESC" 101 | AscNullsFirst expression -> parenthesized (renderSQL expression) 102 | <+> "ASC NULLS FIRST" 103 | DescNullsFirst expression -> parenthesized (renderSQL expression) 104 | <+> "DESC NULLS FIRST" 105 | AscNullsLast expression -> parenthesized (renderSQL expression) 106 | <+> "ASC NULLS LAST" 107 | DescNullsLast expression -> parenthesized (renderSQL expression) 108 | <+> "DESC NULLS LAST" 109 | 110 | -- | Create an index if it doesn't exist. 111 | createIndexIfNotExists 112 | :: (Has sch db schema, Has tab schema ('Table table), KnownSymbol ix) 113 | => Alias ix -- ^ index alias 114 | -> QualifiedAlias sch tab -- ^ table alias 115 | -> IndexMethod method -- ^ index method 116 | -> [SortExpression 'Ungrouped '[] '[] db '[] '[tab ::: TableToRow table]] 117 | -- ^ sorted columns 118 | -> Definition db (Alter sch (CreateIfNotExists ix ('Index method) schema) db) 119 | createIndexIfNotExists ix tab method cols = UnsafeDefinition $ 120 | "CREATE INDEX IF NOT EXISTS" <+> renderSQL ix <+> "ON" <+> renderSQL tab 121 | <+> "USING" <+> renderSQL method 122 | <+> parenthesized (commaSeparated (renderIndex <$> cols)) 123 | <> ";" 124 | where 125 | renderIndex = \case 126 | Asc expression -> parenthesized (renderSQL expression) <+> "ASC" 127 | Desc expression -> parenthesized (renderSQL expression) <+> "DESC" 128 | AscNullsFirst expression -> parenthesized (renderSQL expression) 129 | <+> "ASC NULLS FIRST" 130 | DescNullsFirst expression -> parenthesized (renderSQL expression) 131 | <+> "DESC NULLS FIRST" 132 | AscNullsLast expression -> parenthesized (renderSQL expression) 133 | <+> "ASC NULLS LAST" 134 | DescNullsLast expression -> parenthesized (renderSQL expression) 135 | <+> "DESC NULLS LAST" 136 | 137 | {- | 138 | PostgreSQL provides several index types: 139 | B-tree, Hash, GiST, SP-GiST, GIN and BRIN. 140 | Each index type uses a different algorithm 141 | that is best suited to different types of queries. 142 | -} 143 | newtype IndexMethod ty = UnsafeIndexMethod {renderIndexMethod :: ByteString} 144 | deriving stock (Eq, Ord, Show, GHC.Generic) 145 | instance RenderSQL (IndexMethod ty) where renderSQL = renderIndexMethod 146 | -- | B-trees can handle equality and range queries on data 147 | -- that can be sorted into some ordering. 148 | btree :: IndexMethod 'Btree 149 | btree = UnsafeIndexMethod "btree" 150 | -- | Hash indexes can only handle simple equality comparisons. 151 | hash :: IndexMethod 'Hash 152 | hash = UnsafeIndexMethod "hash" 153 | -- | GiST indexes are not a single kind of index, 154 | -- but rather an infrastructure within which many different 155 | -- indexing strategies can be implemented. 156 | gist :: IndexMethod 'Gist 157 | gist = UnsafeIndexMethod "gist" 158 | -- | SP-GiST indexes, like GiST indexes, 159 | -- offer an infrastructure that supports various kinds of searches. 160 | spgist :: IndexMethod 'Spgist 161 | spgist = UnsafeIndexMethod "spgist" 162 | -- | GIN indexes are “inverted indexes” which are appropriate for 163 | -- data values that contain multiple component values, such as arrays. 164 | gin :: IndexMethod 'Gin 165 | gin = UnsafeIndexMethod "gin" 166 | -- | BRIN indexes (a shorthand for Block Range INdexes) store summaries 167 | -- about the values stored in consecutive physical block ranges of a table. 168 | brin :: IndexMethod 'Brin 169 | brin = UnsafeIndexMethod "brin" 170 | 171 | -- | Drop an index. 172 | -- 173 | -- >>> printSQL (dropIndex #ix :: Definition (Public '["ix" ::: 'Index 'Btree]) (Public '[])) 174 | -- DROP INDEX "ix"; 175 | dropIndex 176 | :: (Has sch db schema, KnownSymbol ix) 177 | => QualifiedAlias sch ix -- ^ index alias 178 | -> Definition db (Alter sch (DropSchemum ix 'Index schema) db) 179 | dropIndex ix = UnsafeDefinition $ "DROP INDEX" <+> renderSQL ix <> ";" 180 | 181 | -- | Drop an index if it exists. 182 | dropIndexIfExists 183 | :: (Has sch db schema, KnownSymbol ix) 184 | => QualifiedAlias sch ix -- ^ index alias 185 | -> Definition db (Alter sch (DropSchemumIfExists ix 'Index schema) db) 186 | dropIndexIfExists ix = UnsafeDefinition $ 187 | "DROP INDEX IF EXISTS" <+> renderSQL ix <> ";" 188 | -------------------------------------------------------------------------------- /squeal-postgresql/src/Squeal/PostgreSQL/Definition/Procedure.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module: Squeal.PostgreSQL.Definition.Procedure 3 | Description: create and drop procedures 4 | Copyright: (c) Eitan Chatav, 2019 5 | Maintainer: eitan@morphism.tech 6 | Stability: experimental 7 | 8 | create and drop procedures 9 | -} 10 | 11 | {-# LANGUAGE 12 | AllowAmbiguousTypes 13 | , ConstraintKinds 14 | , DeriveAnyClass 15 | , DeriveGeneric 16 | , DerivingStrategies 17 | , FlexibleContexts 18 | , FlexibleInstances 19 | , GADTs 20 | , LambdaCase 21 | , MultiParamTypeClasses 22 | , OverloadedLabels 23 | , OverloadedStrings 24 | , RankNTypes 25 | , ScopedTypeVariables 26 | , TypeApplications 27 | , DataKinds 28 | , PolyKinds 29 | , TypeOperators 30 | , UndecidableSuperClasses 31 | #-} 32 | 33 | module Squeal.PostgreSQL.Definition.Procedure 34 | ( -- * Create 35 | createProcedure 36 | , createOrReplaceProcedure 37 | -- * Drop 38 | , dropProcedure 39 | , dropProcedureIfExists 40 | -- * Procedure Definition 41 | , ProcedureDefinition(..) 42 | , languageSqlManipulation 43 | ) where 44 | 45 | import Control.DeepSeq 46 | import Data.ByteString 47 | import GHC.TypeLits 48 | 49 | import qualified Generics.SOP as SOP 50 | import qualified GHC.Generics as GHC 51 | 52 | import Squeal.PostgreSQL.Type.Alias 53 | import Squeal.PostgreSQL.Definition 54 | import Squeal.PostgreSQL.Expression.Type 55 | import Squeal.PostgreSQL.Type.List 56 | import Squeal.PostgreSQL.Manipulation 57 | import Squeal.PostgreSQL.Render 58 | import Squeal.PostgreSQL.Type.Schema 59 | 60 | -- $setup 61 | -- >>> import Squeal.PostgreSQL 62 | 63 | {- | Create a procedure. 64 | 65 | >>> type Proc = 'Procedure '[ 'NotNull 'PGint4 ] 66 | >>> type Thing = 'Table ('[] :=> '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4 ]) 67 | >>> :{ 68 | let 69 | definition :: Definition (Public '["things" ::: Thing ]) (Public '["things" ::: Thing, "proc" ::: Proc]) 70 | definition = createProcedure #proc (one int4) 71 | . languageSqlManipulation 72 | $ [deleteFrom_ #things (#id .== param @1)] 73 | in printSQL definition 74 | :} 75 | CREATE PROCEDURE "proc" (int4) language sql as $$ DELETE FROM "things" AS "things" WHERE ("id" = ($1 :: int4)); $$; 76 | -} 77 | createProcedure 78 | :: ( Has sch db schema 79 | , KnownSymbol pro 80 | , SOP.SListI args ) 81 | => QualifiedAlias sch pro -- ^ procedure alias 82 | -> NP (TypeExpression db) args -- ^ arguments 83 | -> ProcedureDefinition db args -- ^ procedure definition 84 | -> Definition db (Alter sch (Create pro ('Procedure args) schema) db) 85 | createProcedure pro args prodef = UnsafeDefinition $ 86 | "CREATE" <+> "PROCEDURE" <+> renderSQL pro 87 | <+> parenthesized (renderCommaSeparated renderSQL args) 88 | <+> renderSQL prodef <> ";" 89 | 90 | {- | Create or replace a procedure. 91 | It is not possible to change the name or argument types 92 | of a procedure this way. 93 | 94 | >>> type Proc = 'Procedure '[ 'NotNull 'PGint4 ] 95 | >>> type Thing = 'Table ('[] :=> '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4 ]) 96 | >>> :{ 97 | let 98 | definition :: Definition (Public '["things" ::: Thing ]) (Public '["things" ::: Thing, "proc" ::: Proc]) 99 | definition = createOrReplaceProcedure #proc (one int4) 100 | . languageSqlManipulation 101 | $ [deleteFrom_ #things (#id .== param @1)] 102 | in printSQL definition 103 | :} 104 | CREATE OR REPLACE PROCEDURE "proc" (int4) language sql as $$ DELETE FROM "things" AS "things" WHERE ("id" = ($1 :: int4)); $$; 105 | -} 106 | createOrReplaceProcedure 107 | :: ( Has sch db schema 108 | , KnownSymbol pro 109 | , SOP.SListI args ) 110 | => QualifiedAlias sch pro -- ^ procedure alias 111 | -> NP (TypeExpression db) args -- ^ arguments 112 | -> ProcedureDefinition db args -- ^ procedure definition 113 | -> Definition db (Alter sch (CreateOrReplace pro ('Procedure args) schema) db) 114 | createOrReplaceProcedure pro args prodef = UnsafeDefinition $ 115 | "CREATE" <+> "OR" <+> "REPLACE" <+> "PROCEDURE" <+> renderSQL pro 116 | <+> parenthesized (renderCommaSeparated renderSQL args) 117 | <+> renderSQL prodef <> ";" 118 | 119 | -- | Use a parameterized `Manipulation` as a procedure body 120 | languageSqlManipulation 121 | :: [Manipulation '[] db args '[]] 122 | -- ^ procedure body 123 | -> ProcedureDefinition db args 124 | languageSqlManipulation mnps = UnsafeProcedureDefinition $ 125 | "language sql as" <+> "$$" <+> Prelude.foldr (<+>) "" (Prelude.map ((<> ";") . renderSQL) mnps) <> "$$" 126 | 127 | -- | 128 | 129 | {- | Drop a procedure. 130 | 131 | >>> type Proc = 'Procedure '[ 'Null 'PGint4, 'Null 'PGint4] 132 | >>> :{ 133 | let 134 | definition :: Definition (Public '["proc" ::: Proc]) (Public '[]) 135 | definition = dropProcedure #proc 136 | in printSQL definition 137 | :} 138 | DROP PROCEDURE "proc"; 139 | -} 140 | dropProcedure 141 | :: (Has sch db schema, KnownSymbol pro) 142 | => QualifiedAlias sch pro 143 | -- ^ procedure alias 144 | -> Definition db (Alter sch (DropSchemum pro 'Procedure schema) db) 145 | dropProcedure pro = UnsafeDefinition $ 146 | "DROP PROCEDURE" <+> renderSQL pro <> ";" 147 | 148 | {- | Drop a procedure. 149 | 150 | >>> type Proc = 'Procedure '[ 'Null 'PGint4, 'Null 'PGint4 ] 151 | >>> :{ 152 | let 153 | definition :: Definition (Public '[]) (Public '[]) 154 | definition = dropProcedureIfExists #proc 155 | in printSQL definition 156 | :} 157 | DROP PROCEDURE IF EXISTS "proc"; 158 | -} 159 | dropProcedureIfExists 160 | :: (Has sch db schema, KnownSymbol pro) 161 | => QualifiedAlias sch pro 162 | -- ^ procedure alias 163 | -> Definition db (Alter sch (DropSchemumIfExists pro 'Procedure schema) db) 164 | dropProcedureIfExists pro = UnsafeDefinition $ 165 | "DROP PROCEDURE IF EXISTS" <+> renderSQL pro <> ";" 166 | 167 | {- | Body of a user defined procedure-} 168 | newtype ProcedureDefinition db args = UnsafeProcedureDefinition 169 | { renderProcedureDefinition :: ByteString } 170 | deriving (Eq,Show,GHC.Generic,NFData) 171 | instance RenderSQL (ProcedureDefinition db args) where 172 | renderSQL = renderProcedureDefinition 173 | -------------------------------------------------------------------------------- /squeal-postgresql/src/Squeal/PostgreSQL/Definition/Schema.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module: Squeal.PostgreSQL.Definition.Schema 3 | Description: create and drop schemas 4 | Copyright: (c) Eitan Chatav, 2019 5 | Maintainer: eitan@morphism.tech 6 | Stability: experimental 7 | 8 | create and drop schemas 9 | -} 10 | 11 | {-# LANGUAGE 12 | AllowAmbiguousTypes 13 | , ConstraintKinds 14 | , DeriveAnyClass 15 | , DeriveGeneric 16 | , DerivingStrategies 17 | , FlexibleContexts 18 | , FlexibleInstances 19 | , GADTs 20 | , LambdaCase 21 | , MultiParamTypeClasses 22 | , OverloadedLabels 23 | , OverloadedStrings 24 | , RankNTypes 25 | , ScopedTypeVariables 26 | , TypeApplications 27 | , DataKinds 28 | , PolyKinds 29 | , TypeOperators 30 | , UndecidableSuperClasses 31 | #-} 32 | 33 | module Squeal.PostgreSQL.Definition.Schema 34 | ( -- * Create 35 | createSchema 36 | , createSchemaIfNotExists 37 | -- * Drop 38 | , dropSchemaCascade 39 | , dropSchemaCascadeIfExists 40 | ) where 41 | 42 | import GHC.TypeLits 43 | 44 | import Squeal.PostgreSQL.Type.Alias 45 | import Squeal.PostgreSQL.Definition 46 | import Squeal.PostgreSQL.Render 47 | import Squeal.PostgreSQL.Type.Schema 48 | 49 | -- $setup 50 | -- >>> import Squeal.PostgreSQL 51 | 52 | {- | 53 | `createSchema` enters a new schema into the current database. 54 | The schema name must be distinct from the name of any existing schema 55 | in the current database. 56 | 57 | A schema is essentially a namespace: it contains named objects 58 | (tables, data types, functions, and operators) whose names 59 | can duplicate those of other objects existing in other schemas. 60 | Named objects are accessed by `QualifiedAlias`es with the schema 61 | name as a prefix. 62 | 63 | >>> :{ 64 | let 65 | definition :: Definition '["public" ::: '[]] '["public" ::: '[], "my_schema" ::: '[]] 66 | definition = createSchema #my_schema 67 | in printSQL definition 68 | :} 69 | CREATE SCHEMA "my_schema"; 70 | -} 71 | createSchema 72 | :: KnownSymbol sch 73 | => Alias sch -- ^ schema alias 74 | -> Definition db (Create sch '[] db) 75 | createSchema sch = UnsafeDefinition $ 76 | "CREATE" <+> "SCHEMA" <+> renderSQL sch <> ";" 77 | 78 | {- | Create a schema if it does not yet exist.-} 79 | createSchemaIfNotExists 80 | :: (KnownSymbol sch, Has sch db schema) 81 | => Alias sch -- ^ schema alias 82 | -> Definition db (CreateIfNotExists sch '[] db) 83 | createSchemaIfNotExists sch = UnsafeDefinition $ 84 | "CREATE" <+> "SCHEMA" <+> "IF" <+> "NOT" <+> "EXISTS" 85 | <+> renderSQL sch <> ";" 86 | 87 | -- | Drop a schema. 88 | -- Automatically drop objects (tables, functions, etc.) 89 | -- that are contained in the schema. 90 | -- 91 | -- >>> :{ 92 | -- let 93 | -- definition :: Definition '["muh_schema" ::: schema, "public" ::: public] '["public" ::: public] 94 | -- definition = dropSchemaCascade #muh_schema 95 | -- :} 96 | -- 97 | -- >>> printSQL definition 98 | -- DROP SCHEMA "muh_schema" CASCADE; 99 | dropSchemaCascade 100 | :: KnownSymbol sch 101 | => Alias sch -- ^ schema alias 102 | -> Definition db (Drop sch db) 103 | dropSchemaCascade sch = UnsafeDefinition $ 104 | "DROP SCHEMA" <+> renderSQL sch <+> "CASCADE;" 105 | 106 | -- | Drop a schema if it exists. 107 | -- Automatically drop objects (tables, functions, etc.) 108 | -- that are contained in the schema. 109 | dropSchemaCascadeIfExists 110 | :: KnownSymbol sch 111 | => Alias sch -- ^ schema alias 112 | -> Definition db (DropIfExists sch db) 113 | dropSchemaCascadeIfExists sch = UnsafeDefinition $ 114 | "DROP SCHEMA IF EXISTS" <+> renderSQL sch <+> "CASCADE;" 115 | -------------------------------------------------------------------------------- /squeal-postgresql/src/Squeal/PostgreSQL/Definition/View.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module: Squeal.PostgreSQL.Definition.View 3 | Description: create and drop views 4 | Copyright: (c) Eitan Chatav, 2019 5 | Maintainer: eitan@morphism.tech 6 | Stability: experimental 7 | 8 | create and drop views 9 | -} 10 | 11 | {-# LANGUAGE 12 | AllowAmbiguousTypes 13 | , ConstraintKinds 14 | , DeriveAnyClass 15 | , DeriveGeneric 16 | , DerivingStrategies 17 | , FlexibleContexts 18 | , FlexibleInstances 19 | , GADTs 20 | , LambdaCase 21 | , MultiParamTypeClasses 22 | , OverloadedLabels 23 | , OverloadedStrings 24 | , RankNTypes 25 | , ScopedTypeVariables 26 | , TypeApplications 27 | , DataKinds 28 | , PolyKinds 29 | , TypeOperators 30 | , UndecidableSuperClasses 31 | #-} 32 | 33 | module Squeal.PostgreSQL.Definition.View 34 | ( -- * Create 35 | createView 36 | , createOrReplaceView 37 | -- * Drop 38 | , dropView 39 | , dropViewIfExists 40 | -- * Alter 41 | , alterViewRename 42 | , alterViewSetSchema 43 | ) where 44 | 45 | import GHC.TypeLits 46 | 47 | import Squeal.PostgreSQL.Type.Alias 48 | import Squeal.PostgreSQL.Definition 49 | import Squeal.PostgreSQL.Query 50 | import Squeal.PostgreSQL.Render 51 | import Squeal.PostgreSQL.Type.Schema 52 | 53 | -- $setup 54 | -- >>> import Squeal.PostgreSQL 55 | 56 | {- | Create a view. 57 | 58 | >>> type ABC = '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4] 59 | >>> type BC = '["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4] 60 | >>> :{ 61 | let 62 | definition :: Definition 63 | '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC)]] 64 | '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC), "bc" ::: 'View BC]] 65 | definition = 66 | createView #bc (select_ (#b :* #c) (from (table #abc))) 67 | in printSQL definition 68 | :} 69 | CREATE VIEW "bc" AS SELECT "b" AS "b", "c" AS "c" FROM "abc" AS "abc"; 70 | -} 71 | createView 72 | :: (Has sch db schema, KnownSymbol vw) 73 | => QualifiedAlias sch vw -- ^ the name of the view to add 74 | -> Query '[] '[] db '[] view -- ^ query 75 | -> Definition db (Alter sch (Create vw ('View view) schema) db) 76 | createView alias query = UnsafeDefinition $ 77 | "CREATE" <+> "VIEW" <+> renderSQL alias <+> "AS" 78 | <+> renderQuery query <> ";" 79 | 80 | {- | Create or replace a view. 81 | 82 | >>> type ABC = '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4] 83 | >>> type BC = '["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4] 84 | >>> :{ 85 | let 86 | definition :: Definition 87 | '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC)]] 88 | '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC), "bc" ::: 'View BC]] 89 | definition = 90 | createOrReplaceView #bc (select_ (#b :* #c) (from (table #abc))) 91 | in printSQL definition 92 | :} 93 | CREATE OR REPLACE VIEW "bc" AS SELECT "b" AS "b", "c" AS "c" FROM "abc" AS "abc"; 94 | -} 95 | createOrReplaceView 96 | :: (Has sch db schema, KnownSymbol vw) 97 | => QualifiedAlias sch vw -- ^ the name of the view to add 98 | -> Query '[] '[] db '[] view -- ^ query 99 | -> Definition db (Alter sch (CreateOrReplace vw ('View view) schema) db) 100 | createOrReplaceView alias query = UnsafeDefinition $ 101 | "CREATE OR REPLACE VIEW" <+> renderSQL alias <+> "AS" 102 | <+> renderQuery query <> ";" 103 | 104 | -- | Drop a view. 105 | -- 106 | -- >>> :{ 107 | -- let 108 | -- definition :: Definition 109 | -- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4]) 110 | -- , "bc" ::: 'View ('["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4])]] 111 | -- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])]] 112 | -- definition = dropView #bc 113 | -- in printSQL definition 114 | -- :} 115 | -- DROP VIEW "bc"; 116 | dropView 117 | :: (Has sch db schema, KnownSymbol vw) 118 | => QualifiedAlias sch vw -- ^ view to remove 119 | -> Definition db (Alter sch (DropSchemum vw 'View schema) db) 120 | dropView vw = UnsafeDefinition $ "DROP VIEW" <+> renderSQL vw <> ";" 121 | 122 | -- | Drop a view if it exists. 123 | -- 124 | -- >>> :{ 125 | -- let 126 | -- definition :: Definition 127 | -- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4]) 128 | -- , "bc" ::: 'View ('["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4])]] 129 | -- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])]] 130 | -- definition = dropViewIfExists #bc 131 | -- in printSQL definition 132 | -- :} 133 | -- DROP VIEW IF EXISTS "bc"; 134 | dropViewIfExists 135 | :: (Has sch db schema, KnownSymbol vw) 136 | => QualifiedAlias sch vw -- ^ view to remove 137 | -> Definition db (Alter sch (DropIfExists vw schema) db) 138 | dropViewIfExists vw = UnsafeDefinition $ 139 | "DROP VIEW IF EXISTS" <+> renderSQL vw <> ";" 140 | 141 | -- | `alterViewRename` changes the name of a view from the schema. 142 | -- 143 | -- >>> type DB = '[ "public" ::: '[ "foo" ::: 'View '[] ] ] 144 | -- >>> :{ 145 | -- let def :: Definition DB '["public" ::: '["bar" ::: 'View '[] ] ] 146 | -- def = alterViewRename #foo #bar 147 | -- in printSQL def 148 | -- :} 149 | -- ALTER VIEW "foo" RENAME TO "bar"; 150 | alterViewRename 151 | :: ( Has sch db schema 152 | , KnownSymbol ty1 153 | , Has ty0 schema ('View vw)) 154 | => QualifiedAlias sch ty0 -- ^ view to rename 155 | -> Alias ty1 -- ^ what to rename it 156 | -> Definition db (Alter sch (Rename ty0 ty1 schema) db ) 157 | alterViewRename vw0 vw1 = UnsafeDefinition $ 158 | "ALTER VIEW" <+> renderSQL vw0 159 | <+> "RENAME TO" <+> renderSQL vw1 <> ";" 160 | 161 | {- | This form moves the view into another schema. 162 | 163 | >>> type DB0 = '[ "sch0" ::: '[ "vw" ::: 'View '[] ], "sch1" ::: '[] ] 164 | >>> type DB1 = '[ "sch0" ::: '[], "sch1" ::: '[ "vw" ::: 'View '[] ] ] 165 | >>> :{ 166 | let def :: Definition DB0 DB1 167 | def = alterViewSetSchema (#sch0 ! #vw) #sch1 168 | in printSQL def 169 | :} 170 | ALTER VIEW "sch0"."vw" SET SCHEMA "sch1"; 171 | -} 172 | alterViewSetSchema 173 | :: ( Has sch0 db schema0 174 | , Has vw schema0 ('View view) 175 | , Has sch1 db schema1 ) 176 | => QualifiedAlias sch0 vw -- ^ view to move 177 | -> Alias sch1 -- ^ where to move it 178 | -> Definition db (SetSchema sch0 sch1 schema0 schema1 vw 'View view db) 179 | alterViewSetSchema ty sch = UnsafeDefinition $ 180 | "ALTER VIEW" <+> renderSQL ty <+> "SET SCHEMA" <+> renderSQL sch <> ";" 181 | -------------------------------------------------------------------------------- /squeal-postgresql/src/Squeal/PostgreSQL/Expression/Comparison.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module: Squeal.PostgreSQL.Expression.Comparison 3 | Description: comparison functions and operators 4 | Copyright: (c) Eitan Chatav, 2019 5 | Maintainer: eitan@morphism.tech 6 | Stability: experimental 7 | 8 | comparison functions and operators 9 | -} 10 | 11 | {-# LANGUAGE 12 | OverloadedStrings 13 | , RankNTypes 14 | , DataKinds 15 | , PolyKinds 16 | , TypeOperators 17 | #-} 18 | 19 | module Squeal.PostgreSQL.Expression.Comparison 20 | ( -- * Comparison Operators 21 | (.==) 22 | , (./=) 23 | , (.>=) 24 | , (.<) 25 | , (.<=) 26 | , (.>) 27 | -- * Comparison Functions 28 | , greatest 29 | , least 30 | -- * Between 31 | , BetweenExpr 32 | , between 33 | , notBetween 34 | , betweenSymmetric 35 | , notBetweenSymmetric 36 | -- * Null Comparison 37 | , isDistinctFrom 38 | , isNotDistinctFrom 39 | , isTrue 40 | , isNotTrue 41 | , isFalse 42 | , isNotFalse 43 | , isUnknown 44 | , isNotUnknown 45 | ) where 46 | 47 | import Data.ByteString 48 | 49 | import Squeal.PostgreSQL.Expression 50 | import Squeal.PostgreSQL.Expression.Logic 51 | import Squeal.PostgreSQL.Render 52 | import Squeal.PostgreSQL.Type.Schema 53 | 54 | -- $setup 55 | -- >>> import Squeal.PostgreSQL 56 | 57 | -- | Comparison operations like `.==`, `./=`, `.>`, `.>=`, `.<` and `.<=` 58 | -- will produce @NULL@s if one of their arguments is @NULL@. 59 | -- 60 | -- >>> printSQL $ true .== null_ 61 | -- (TRUE = NULL) 62 | (.==) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool) 63 | (.==) = unsafeBinaryOp "=" 64 | infix 4 .== 65 | 66 | -- | >>> printSQL $ true ./= null_ 67 | -- (TRUE <> NULL) 68 | (./=) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool) 69 | (./=) = unsafeBinaryOp "<>" 70 | infix 4 ./= 71 | 72 | -- | >>> printSQL $ true .>= null_ 73 | -- (TRUE >= NULL) 74 | (.>=) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool) 75 | (.>=) = unsafeBinaryOp ">=" 76 | infix 4 .>= 77 | 78 | -- | >>> printSQL $ true .< null_ 79 | -- (TRUE < NULL) 80 | (.<) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool) 81 | (.<) = unsafeBinaryOp "<" 82 | infix 4 .< 83 | 84 | -- | >>> printSQL $ true .<= null_ 85 | -- (TRUE <= NULL) 86 | (.<=) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool) 87 | (.<=) = unsafeBinaryOp "<=" 88 | infix 4 .<= 89 | 90 | -- | >>> printSQL $ true .> null_ 91 | -- (TRUE > NULL) 92 | (.>) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool) 93 | (.>) = unsafeBinaryOp ">" 94 | infix 4 .> 95 | 96 | -- | >>> let expr = greatest [param @1] currentTimestamp 97 | -- >>> printSQL expr 98 | -- GREATEST(($1 :: timestamp with time zone), CURRENT_TIMESTAMP) 99 | greatest :: FunctionVar ty ty ty 100 | greatest = unsafeFunctionVar "GREATEST" 101 | 102 | -- | >>> printSQL $ least [null_] currentTimestamp 103 | -- LEAST(NULL, CURRENT_TIMESTAMP) 104 | least :: FunctionVar ty ty ty 105 | least = unsafeFunctionVar "LEAST" 106 | 107 | {- | 108 | A @RankNType@ for comparison expressions like `between`. 109 | -} 110 | type BetweenExpr 111 | = forall grp lat with db params from ty 112 | . Expression grp lat with db params from ty 113 | -> ( Expression grp lat with db params from ty 114 | , Expression grp lat with db params from ty ) -- ^ bounds 115 | -> Condition grp lat with db params from 116 | 117 | unsafeBetweenExpr :: ByteString -> BetweenExpr 118 | unsafeBetweenExpr fun a (x,y) = UnsafeExpression $ 119 | renderSQL a <+> fun <+> renderSQL x <+> "AND" <+> renderSQL y 120 | 121 | {- | >>> printSQL $ true `between` (null_, false) 122 | TRUE BETWEEN NULL AND FALSE 123 | -} 124 | between :: BetweenExpr 125 | between = unsafeBetweenExpr "BETWEEN" 126 | 127 | {- | >>> printSQL $ true `notBetween` (null_, false) 128 | TRUE NOT BETWEEN NULL AND FALSE 129 | -} 130 | notBetween :: BetweenExpr 131 | notBetween = unsafeBetweenExpr "NOT BETWEEN" 132 | 133 | {- | between, after sorting the comparison values 134 | 135 | >>> printSQL $ true `betweenSymmetric` (null_, false) 136 | TRUE BETWEEN SYMMETRIC NULL AND FALSE 137 | -} 138 | betweenSymmetric :: BetweenExpr 139 | betweenSymmetric = unsafeBetweenExpr "BETWEEN SYMMETRIC" 140 | 141 | {- | not between, after sorting the comparison values 142 | 143 | >>> printSQL $ true `notBetweenSymmetric` (null_, false) 144 | TRUE NOT BETWEEN SYMMETRIC NULL AND FALSE 145 | -} 146 | notBetweenSymmetric :: BetweenExpr 147 | notBetweenSymmetric = unsafeBetweenExpr "NOT BETWEEN SYMMETRIC" 148 | 149 | {- | not equal, treating null like an ordinary value 150 | 151 | >>> printSQL $ true `isDistinctFrom` null_ 152 | (TRUE IS DISTINCT FROM NULL) 153 | -} 154 | isDistinctFrom :: Operator (null0 ty) (null1 ty) (null 'PGbool) 155 | isDistinctFrom = unsafeBinaryOp "IS DISTINCT FROM" 156 | 157 | {- | equal, treating null like an ordinary value 158 | 159 | >>> printSQL $ true `isNotDistinctFrom` null_ 160 | (TRUE IS NOT DISTINCT FROM NULL) 161 | -} 162 | isNotDistinctFrom :: Operator (null0 ty) (null1 ty) (null 'PGbool) 163 | isNotDistinctFrom = unsafeBinaryOp "IS NOT DISTINCT FROM" 164 | 165 | {- | is true 166 | 167 | >>> printSQL $ true & isTrue 168 | (TRUE IS TRUE) 169 | -} 170 | isTrue :: null0 'PGbool --> null1 'PGbool 171 | isTrue = unsafeRightOp "IS TRUE" 172 | 173 | {- | is false or unknown 174 | 175 | >>> printSQL $ true & isNotTrue 176 | (TRUE IS NOT TRUE) 177 | -} 178 | isNotTrue :: null0 'PGbool --> null1 'PGbool 179 | isNotTrue = unsafeRightOp "IS NOT TRUE" 180 | 181 | {- | is false 182 | 183 | >>> printSQL $ true & isFalse 184 | (TRUE IS FALSE) 185 | -} 186 | isFalse :: null0 'PGbool --> null1 'PGbool 187 | isFalse = unsafeRightOp "IS FALSE" 188 | 189 | {- | is true or unknown 190 | 191 | >>> printSQL $ true & isNotFalse 192 | (TRUE IS NOT FALSE) 193 | -} 194 | isNotFalse :: null0 'PGbool --> null1 'PGbool 195 | isNotFalse = unsafeRightOp "IS NOT FALSE" 196 | 197 | {- | is unknown 198 | 199 | >>> printSQL $ true & isUnknown 200 | (TRUE IS UNKNOWN) 201 | -} 202 | isUnknown :: null0 'PGbool --> null1 'PGbool 203 | isUnknown = unsafeRightOp "IS UNKNOWN" 204 | 205 | {- | is true or false 206 | 207 | >>> printSQL $ true & isNotUnknown 208 | (TRUE IS NOT UNKNOWN) 209 | -} 210 | isNotUnknown :: null0 'PGbool --> null1 'PGbool 211 | isNotUnknown = unsafeRightOp "IS NOT UNKNOWN" 212 | -------------------------------------------------------------------------------- /squeal-postgresql/src/Squeal/PostgreSQL/Expression/Composite.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module: Squeal.PostgreSQL.Expression.Composite 3 | Description: composite functions 4 | Copyright: (c) Eitan Chatav, 2019 5 | Maintainer: eitan@morphism.tech 6 | Stability: experimental 7 | 8 | composite functions 9 | -} 10 | 11 | {-# LANGUAGE 12 | AllowAmbiguousTypes 13 | , DataKinds 14 | , FlexibleContexts 15 | , FlexibleInstances 16 | , MultiParamTypeClasses 17 | , OverloadedLabels 18 | , OverloadedStrings 19 | , RankNTypes 20 | , ScopedTypeVariables 21 | , TypeApplications 22 | , TypeFamilies 23 | , TypeOperators 24 | , UndecidableInstances 25 | #-} 26 | 27 | module Squeal.PostgreSQL.Expression.Composite 28 | ( -- * Composite Functions 29 | row 30 | , rowStar 31 | , field 32 | ) where 33 | 34 | import qualified Generics.SOP as SOP 35 | 36 | import Squeal.PostgreSQL.Type.Alias 37 | import Squeal.PostgreSQL.Expression 38 | import Squeal.PostgreSQL.Type.List 39 | import Squeal.PostgreSQL.Render 40 | import Squeal.PostgreSQL.Type.Schema 41 | 42 | -- $setup 43 | -- >>> import Squeal.PostgreSQL 44 | 45 | -- | A row constructor is an expression that builds a row value 46 | -- (also called a composite value) using values for its member fields. 47 | -- 48 | -- >>> :{ 49 | -- type Complex = 'PGcomposite 50 | -- '[ "real" ::: 'NotNull 'PGfloat8 51 | -- , "imaginary" ::: 'NotNull 'PGfloat8 ] 52 | -- :} 53 | -- 54 | -- >>> let i = row (0 `as` #real :* 1 `as` #imaginary) :: Expression grp lat with db params from ('NotNull Complex) 55 | -- >>> printSQL i 56 | -- ROW((0.0 :: float8), (1.0 :: float8)) 57 | row 58 | :: SOP.SListI row 59 | => NP (Aliased (Expression grp lat with db params from)) row 60 | -- ^ zero or more expressions for the row field values 61 | -> Expression grp lat with db params from (null ('PGcomposite row)) 62 | row exprs = UnsafeExpression $ "ROW" <> parenthesized 63 | (renderCommaSeparated (\ (expr `As` _) -> renderSQL expr) exprs) 64 | 65 | -- | A row constructor on all columns in a table expression. 66 | rowStar 67 | :: Has tab from row 68 | => Alias tab -- ^ intermediate table 69 | -> Expression grp lat with db params from (null ('PGcomposite row)) 70 | rowStar tab = UnsafeExpression $ "ROW" <> 71 | parenthesized (renderSQL tab <> ".*") 72 | 73 | -- | >>> :{ 74 | -- type Complex = 'PGcomposite 75 | -- '[ "real" ::: 'NotNull 'PGfloat8 76 | -- , "imaginary" ::: 'NotNull 'PGfloat8 ] 77 | -- type Schema = '["complex" ::: 'Typedef Complex] 78 | -- :} 79 | -- 80 | -- >>> let i = row (0 `as` #real :* 1 `as` #imaginary) :: Expression lat '[] grp (Public Schema) from params ('NotNull Complex) 81 | -- >>> printSQL $ i & field #complex #imaginary 82 | -- (ROW((0.0 :: float8), (1.0 :: float8))::"complex")."imaginary" 83 | field 84 | :: ( relss ~ DbRelations db 85 | , Has sch relss rels 86 | , Has rel rels row 87 | , Has field row ty 88 | ) 89 | => QualifiedAlias sch rel -- ^ row type 90 | -> Alias field -- ^ field name 91 | -> Expression grp lat with db params from ('NotNull ('PGcomposite row)) 92 | -> Expression grp lat with db params from ty 93 | field rel fld expr = UnsafeExpression $ 94 | parenthesized (renderSQL expr <> "::" <> renderSQL rel) 95 | <> "." <> renderSQL fld 96 | -------------------------------------------------------------------------------- /squeal-postgresql/src/Squeal/PostgreSQL/Expression/Default.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module: Squeal.PostgreSQL.Expression.Default 3 | Description: optional expressions 4 | Copyright: (c) Eitan Chatav, 2019 5 | Maintainer: eitan@morphism.tech 6 | Stability: experimental 7 | 8 | optional expressions 9 | -} 10 | 11 | {-# LANGUAGE 12 | DataKinds 13 | , GADTs 14 | , LambdaCase 15 | , OverloadedStrings 16 | , PatternSynonyms 17 | , PolyKinds 18 | , QuantifiedConstraints 19 | , RankNTypes 20 | , TypeOperators 21 | #-} 22 | 23 | module Squeal.PostgreSQL.Expression.Default 24 | ( -- * Default 25 | Optional (..) 26 | , mapOptional 27 | , pattern NotDefault 28 | ) where 29 | 30 | import Data.Kind 31 | import Generics.SOP 32 | 33 | import Squeal.PostgreSQL.Render 34 | import Squeal.PostgreSQL.Type.Schema 35 | 36 | -- | `Optional` is either `Default` or `Set`ting of a value, 37 | -- parameterized by an appropriate `Optionality`. 38 | data Optional (expr :: k -> Type) (ty :: (Optionality, k)) where 39 | -- | Use the `Default` value for a column. 40 | Default :: Optional expr ('Def :=> ty) 41 | -- | `Set` a value for a column. 42 | Set :: expr ty -> Optional expr (def :=> ty) 43 | 44 | instance (forall x. RenderSQL (expr x)) => RenderSQL (Optional expr ty) where 45 | renderSQL = \case 46 | Default -> "DEFAULT" 47 | Set x -> renderSQL x 48 | 49 | -- | Map a function over an `Optional` expression. 50 | mapOptional 51 | :: (expr x -> expr y) 52 | -> Optional expr (def :=> x) 53 | -> Optional expr (def :=> y) 54 | mapOptional f = \case 55 | Default -> Default 56 | Set x -> Set (f x) 57 | 58 | -- | `NotDefault` pattern analagous to `Just`. 59 | pattern NotDefault :: ty -> Optional I ('Def :=> ty) 60 | pattern NotDefault x = Set (I x) 61 | -------------------------------------------------------------------------------- /squeal-postgresql/src/Squeal/PostgreSQL/Expression/Logic.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module: Squeal.PostgreSQL.Expression.Logic 3 | Description: logical expressions and operators 4 | Copyright: (c) Eitan Chatav, 2019 5 | Maintainer: eitan@morphism.tech 6 | Stability: experimental 7 | 8 | logical expressions and operators 9 | -} 10 | 11 | {-# LANGUAGE 12 | DataKinds 13 | , OverloadedStrings 14 | , TypeOperators 15 | #-} 16 | 17 | module Squeal.PostgreSQL.Expression.Logic 18 | ( -- * Condition 19 | Condition 20 | , true 21 | , false 22 | -- * Logic 23 | , not_ 24 | , (.&&) 25 | , (.||) 26 | -- * Conditional 27 | , caseWhenThenElse 28 | , ifThenElse 29 | ) where 30 | 31 | import Squeal.PostgreSQL.Expression 32 | import Squeal.PostgreSQL.Render 33 | import Squeal.PostgreSQL.Type.Schema 34 | 35 | -- | A `Condition` is an `Expression`, which can evaluate 36 | -- to `true`, `false` or `Squeal.PostgreSQL.Null.null_`. This is because SQL uses 37 | -- a three valued logic. 38 | type Condition grp lat with db params from = 39 | Expression grp lat with db params from ('Null 'PGbool) 40 | 41 | -- | >>> printSQL true 42 | -- TRUE 43 | true :: Expr (null 'PGbool) 44 | true = UnsafeExpression "TRUE" 45 | 46 | -- | >>> printSQL false 47 | -- FALSE 48 | false :: Expr (null 'PGbool) 49 | false = UnsafeExpression "FALSE" 50 | 51 | -- | >>> printSQL $ not_ true 52 | -- (NOT TRUE) 53 | not_ :: null 'PGbool --> null 'PGbool 54 | not_ = unsafeLeftOp "NOT" 55 | 56 | -- | >>> printSQL $ true .&& false 57 | -- (TRUE AND FALSE) 58 | (.&&) :: Operator (null 'PGbool) (null 'PGbool) (null 'PGbool) 59 | infixr 3 .&& 60 | (.&&) = unsafeBinaryOp "AND" 61 | 62 | -- | >>> printSQL $ true .|| false 63 | -- (TRUE OR FALSE) 64 | (.||) :: Operator (null 'PGbool) (null 'PGbool) (null 'PGbool) 65 | infixr 2 .|| 66 | (.||) = unsafeBinaryOp "OR" 67 | 68 | -- | >>> :{ 69 | -- let 70 | -- expression :: Expression grp lat with db params from (null 'PGint2) 71 | -- expression = caseWhenThenElse [(true, 1), (false, 2)] 3 72 | -- in printSQL expression 73 | -- :} 74 | -- CASE WHEN TRUE THEN (1 :: int2) WHEN FALSE THEN (2 :: int2) ELSE (3 :: int2) END 75 | caseWhenThenElse 76 | :: [ ( Condition grp lat with db params from 77 | , Expression grp lat with db params from ty 78 | ) ] 79 | -- ^ whens and thens 80 | -> Expression grp lat with db params from ty 81 | -- ^ else 82 | -> Expression grp lat with db params from ty 83 | caseWhenThenElse whenThens else_ = UnsafeExpression $ mconcat 84 | [ "CASE" 85 | , mconcat 86 | [ mconcat 87 | [ " WHEN ", renderSQL when_ 88 | , " THEN ", renderSQL then_ 89 | ] 90 | | (when_,then_) <- whenThens 91 | ] 92 | , " ELSE ", renderSQL else_ 93 | , " END" 94 | ] 95 | 96 | -- | >>> :{ 97 | -- let 98 | -- expression :: Expression grp lat with db params from (null 'PGint2) 99 | -- expression = ifThenElse true 1 0 100 | -- in printSQL expression 101 | -- :} 102 | -- CASE WHEN TRUE THEN (1 :: int2) ELSE (0 :: int2) END 103 | ifThenElse 104 | :: Condition grp lat with db params from 105 | -> Expression grp lat with db params from ty -- ^ then 106 | -> Expression grp lat with db params from ty -- ^ else 107 | -> Expression grp lat with db params from ty 108 | ifThenElse if_ then_ else_ = caseWhenThenElse [(if_,then_)] else_ 109 | -------------------------------------------------------------------------------- /squeal-postgresql/src/Squeal/PostgreSQL/Expression/Math.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module: Squeal.PostgreSQL.Expression.Math 3 | Description: math functions 4 | Copyright: (c) Eitan Chatav, 2019 5 | Maintainer: eitan@morphism.tech 6 | Stability: experimental 7 | 8 | math functions 9 | -} 10 | 11 | {-# LANGUAGE 12 | DataKinds 13 | , OverloadedStrings 14 | , TypeOperators 15 | #-} 16 | 17 | module Squeal.PostgreSQL.Expression.Math 18 | ( -- * Math Function 19 | atan2_ 20 | , quot_ 21 | , rem_ 22 | , trunc 23 | , round_ 24 | , ceiling_ 25 | ) where 26 | 27 | import Squeal.PostgreSQL.Expression 28 | import Squeal.PostgreSQL.Type.List 29 | import Squeal.PostgreSQL.Type.Schema 30 | 31 | -- $setup 32 | -- >>> import Squeal.PostgreSQL 33 | 34 | -- | >>> :{ 35 | -- let 36 | -- expression :: Expr (null 'PGfloat4) 37 | -- expression = atan2_ (pi *: 2) 38 | -- in printSQL expression 39 | -- :} 40 | -- atan2(pi(), (2.0 :: float4)) 41 | atan2_ :: float `In` PGFloating => '[ null float, null float] ---> null float 42 | atan2_ = unsafeFunctionN "atan2" 43 | 44 | 45 | -- | integer division, truncates the result 46 | -- 47 | -- >>> :{ 48 | -- let 49 | -- expression :: Expression grp lat with db params from (null 'PGint2) 50 | -- expression = 5 `quot_` 2 51 | -- in printSQL expression 52 | -- :} 53 | -- ((5 :: int2) / (2 :: int2)) 54 | quot_ 55 | :: int `In` PGIntegral 56 | => Operator (null int) (null int) (null int) 57 | quot_ = unsafeBinaryOp "/" 58 | 59 | -- | remainder upon integer division 60 | -- 61 | -- >>> :{ 62 | -- let 63 | -- expression :: Expression grp lat with db params from (null 'PGint2) 64 | -- expression = 5 `rem_` 2 65 | -- in printSQL expression 66 | -- :} 67 | -- ((5 :: int2) % (2 :: int2)) 68 | rem_ 69 | :: int `In` PGIntegral 70 | => Operator (null int) (null int) (null int) 71 | rem_ = unsafeBinaryOp "%" 72 | 73 | -- | >>> :{ 74 | -- let 75 | -- expression :: Expression grp lat with db params from (null 'PGfloat4) 76 | -- expression = trunc pi 77 | -- in printSQL expression 78 | -- :} 79 | -- trunc(pi()) 80 | trunc :: frac `In` PGFloating => null frac --> null frac 81 | trunc = unsafeFunction "trunc" 82 | 83 | -- | >>> :{ 84 | -- let 85 | -- expression :: Expression grp lat with db params from (null 'PGfloat4) 86 | -- expression = round_ pi 87 | -- in printSQL expression 88 | -- :} 89 | -- round(pi()) 90 | round_ :: frac `In` PGFloating => null frac --> null frac 91 | round_ = unsafeFunction "round" 92 | 93 | -- | >>> :{ 94 | -- let 95 | -- expression :: Expression grp lat with db params from (null 'PGfloat4) 96 | -- expression = ceiling_ pi 97 | -- in printSQL expression 98 | -- :} 99 | -- ceiling(pi()) 100 | ceiling_ :: frac `In` PGFloating => null frac --> null frac 101 | ceiling_ = unsafeFunction "ceiling" 102 | -------------------------------------------------------------------------------- /squeal-postgresql/src/Squeal/PostgreSQL/Expression/Null.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module: Squeal.PostgreSQL.Expression.Null 3 | Description: null expressions and handlers 4 | Copyright: (c) Eitan Chatav, 2019 5 | Maintainer: eitan@morphism.tech 6 | Stability: experimental 7 | 8 | null expressions and handlers 9 | -} 10 | 11 | {-# LANGUAGE 12 | DataKinds 13 | , KindSignatures 14 | , OverloadedStrings 15 | , RankNTypes 16 | , TypeFamilies 17 | , TypeOperators 18 | #-} 19 | 20 | module Squeal.PostgreSQL.Expression.Null 21 | ( -- * Null 22 | null_ 23 | , just_ 24 | , unsafeNotNull 25 | , monoNotNull 26 | , coalesce 27 | , fromNull 28 | , isNull 29 | , isNotNull 30 | , matchNull 31 | , nullIf 32 | , CombineNullity 33 | -- deprecated 34 | , notNull 35 | ) where 36 | 37 | import Squeal.PostgreSQL.Expression 38 | import Squeal.PostgreSQL.Expression.Logic 39 | import Squeal.PostgreSQL.Render 40 | import Squeal.PostgreSQL.Type.Schema 41 | 42 | -- $setup 43 | -- >>> import Squeal.PostgreSQL 44 | 45 | -- | analagous to `Nothing` 46 | -- 47 | -- >>> printSQL null_ 48 | -- NULL 49 | null_ :: Expr ('Null ty) 50 | null_ = UnsafeExpression "NULL" 51 | 52 | -- | analagous to `Just` 53 | -- 54 | -- >>> printSQL $ just_ true 55 | -- TRUE 56 | just_ :: 'NotNull ty --> 'Null ty 57 | just_ = UnsafeExpression . renderSQL 58 | 59 | -- | analagous to `Just` 60 | {-# DEPRECATED notNull "use just_ instead" #-} 61 | notNull :: 'NotNull ty --> 'Null ty 62 | notNull = UnsafeExpression . renderSQL 63 | 64 | -- | Analagous to `Data.Maybe.fromJust` inverse to `notNull`, 65 | -- useful when you know an `Expression` is `NotNull`, 66 | -- because, for instance, you've filtered out @NULL@ 67 | -- values in a column. 68 | unsafeNotNull :: 'Null ty --> 'NotNull ty 69 | unsafeNotNull = UnsafeExpression . renderSQL 70 | 71 | -- | Some expressions are null polymorphic which may raise 72 | -- inference issues. Use `monoNotNull` to fix their 73 | -- nullity as `NotNull`. 74 | monoNotNull 75 | :: (forall null. Expression grp lat with db params from (null ty)) 76 | -- ^ null polymorphic 77 | -> Expression grp lat with db params from ('NotNull ty) 78 | monoNotNull x = x 79 | 80 | -- | return the leftmost value which is not NULL 81 | -- 82 | -- >>> printSQL $ coalesce [null_, true] false 83 | -- COALESCE(NULL, TRUE, FALSE) 84 | coalesce :: FunctionVar ('Null ty) (null ty) (null ty) 85 | coalesce nullxs notNullx = UnsafeExpression $ 86 | "COALESCE" <> parenthesized (commaSeparated 87 | ((renderSQL <$> nullxs) <> [renderSQL notNullx])) 88 | 89 | -- | analagous to `Data.Maybe.fromMaybe` using @COALESCE@ 90 | -- 91 | -- >>> printSQL $ fromNull true null_ 92 | -- COALESCE(NULL, TRUE) 93 | fromNull 94 | :: Expression grp lat with db params from ('NotNull ty) 95 | -- ^ what to convert @NULL@ to 96 | -> Expression grp lat with db params from ('Null ty) 97 | -> Expression grp lat with db params from ('NotNull ty) 98 | fromNull notNullx nullx = coalesce [nullx] notNullx 99 | 100 | -- | >>> printSQL $ null_ & isNull 101 | -- NULL IS NULL 102 | isNull :: 'Null ty --> null 'PGbool 103 | isNull x = UnsafeExpression $ renderSQL x <+> "IS NULL" 104 | 105 | -- | >>> printSQL $ null_ & isNotNull 106 | -- NULL IS NOT NULL 107 | isNotNull :: 'Null ty --> null 'PGbool 108 | isNotNull x = UnsafeExpression $ renderSQL x <+> "IS NOT NULL" 109 | 110 | -- | analagous to `maybe` using @IS NULL@ 111 | -- 112 | -- >>> printSQL $ matchNull true not_ null_ 113 | -- CASE WHEN NULL IS NULL THEN TRUE ELSE (NOT NULL) END 114 | matchNull 115 | :: Expression grp lat with db params from (nullty) 116 | -- ^ what to convert @NULL@ to 117 | -> ( Expression grp lat with db params from ('NotNull ty) 118 | -> Expression grp lat with db params from (nullty) ) 119 | -- ^ function to perform when @NULL@ is absent 120 | -> Expression grp lat with db params from ('Null ty) 121 | -> Expression grp lat with db params from (nullty) 122 | matchNull y f x = ifThenElse (isNull x) y 123 | (f (UnsafeExpression (renderSQL x))) 124 | 125 | {-| right inverse to `fromNull`, if its arguments are equal then 126 | `nullIf` gives @NULL@. 127 | 128 | >>> :set -XTypeApplications 129 | >>> printSQL (nullIf (false *: param @1)) 130 | NULLIF(FALSE, ($1 :: bool)) 131 | -} 132 | nullIf :: '[ 'NotNull ty, 'NotNull ty] ---> 'Null ty 133 | nullIf = unsafeFunctionN "NULLIF" 134 | 135 | {-| Make the return type of the type family `NotNull` if both arguments are, 136 | or `Null` otherwise. 137 | -} 138 | type family CombineNullity 139 | (lhs :: PGType -> NullType) (rhs :: PGType -> NullType) :: PGType -> NullType where 140 | CombineNullity 'NotNull 'NotNull = 'NotNull 141 | CombineNullity _ _ = 'Null 142 | -------------------------------------------------------------------------------- /squeal-postgresql/src/Squeal/PostgreSQL/Expression/Parameter.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module: Squeal.PostgreSQL.Expression.Parameter 3 | Description: out-of-line parameters 4 | Copyright: (c) Eitan Chatav, 2019 5 | Maintainer: eitan@morphism.tech 6 | Stability: experimental 7 | 8 | out-of-line parameters 9 | -} 10 | 11 | {-# LANGUAGE 12 | AllowAmbiguousTypes 13 | , DataKinds 14 | , FlexibleContexts 15 | , FlexibleInstances 16 | , FunctionalDependencies 17 | , GADTs 18 | , KindSignatures 19 | , MultiParamTypeClasses 20 | , OverloadedStrings 21 | , RankNTypes 22 | , ScopedTypeVariables 23 | , TypeApplications 24 | , TypeFamilies 25 | , TypeOperators 26 | , UndecidableInstances 27 | #-} 28 | 29 | module Squeal.PostgreSQL.Expression.Parameter 30 | ( -- * Parameter 31 | HasParameter (parameter) 32 | , param 33 | -- * Parameter Internals 34 | , HasParameter' 35 | , ParamOutOfBoundsError 36 | , ParamTypeMismatchError 37 | ) where 38 | 39 | import Data.Kind (Constraint) 40 | import GHC.Exts (Any) 41 | import GHC.TypeLits 42 | 43 | import Squeal.PostgreSQL.Expression 44 | import Squeal.PostgreSQL.Expression.Type 45 | import Squeal.PostgreSQL.Render 46 | import Squeal.PostgreSQL.Type.Schema 47 | 48 | -- $setup 49 | -- >>> import Squeal.PostgreSQL 50 | 51 | {- | A `HasParameter` constraint is used to indicate a value that is 52 | supplied externally to a SQL statement. 53 | `Squeal.PostgreSQL.Session.manipulateParams`, 54 | `Squeal.PostgreSQL.Session.queryParams` and 55 | `Squeal.PostgreSQL.Session.traversePrepared` support specifying data values 56 | separately from the SQL command string, in which case `param`s are used to 57 | refer to the out-of-line data values. 58 | -} 59 | class KnownNat ix => HasParameter 60 | (ix :: Nat) 61 | (params :: [NullType]) 62 | (ty :: NullType) 63 | | ix params -> ty where 64 | -- | `parameter` takes a `Nat` using type application and a `TypeExpression`. 65 | -- 66 | -- >>> printSQL (parameter @1 int4) 67 | -- ($1 :: int4) 68 | parameter 69 | :: TypeExpression db ty 70 | -> Expression grp lat with db params from ty 71 | parameter ty = UnsafeExpression $ parenthesized $ 72 | "$" <> renderNat @ix <+> "::" 73 | <+> renderSQL ty 74 | 75 | -- we could do the check for 0 in @HasParameter'@, but this way forces checking 'ix' before delegating, 76 | -- which has the nice effect of ambiguous 'ix' errors mentioning 'HasParameter' instead of @HasParameter'@ 77 | instance {-# OVERLAPS #-} (TypeError ('Text "Tried to get the param at index 0, but params are 1-indexed"), x ~ Any) => HasParameter 0 params x 78 | instance {-# OVERLAPS #-} (KnownNat ix, HasParameter' ix params ix params x) => HasParameter ix params x 79 | 80 | -- | @HasParameter'@ is an implementation detail of 'HasParameter' allowing us to 81 | -- include the full parameter list in our errors. 82 | class KnownNat ix => HasParameter' 83 | (originalIx :: Nat) 84 | (allParams :: [NullType]) 85 | (ix :: Nat) 86 | (params :: [NullType]) 87 | (ty :: NullType) 88 | | ix params -> ty where 89 | instance {-# OVERLAPS #-} 90 | ( params ~ (y ': xs) 91 | , y ~ x -- having a separate 'y' type variable is required for 'ParamTypeMismatchError' 92 | , ParamOutOfBoundsError originalIx allParams params 93 | , ParamTypeMismatchError originalIx allParams x y 94 | ) => HasParameter' originalIx allParams 1 params x 95 | instance {-# OVERLAPS #-} 96 | ( KnownNat ix 97 | , HasParameter' originalIx allParams (ix-1) xs x 98 | , params ~ (y ': xs) 99 | , ParamOutOfBoundsError originalIx allParams params 100 | ) 101 | => HasParameter' originalIx allParams ix params x 102 | 103 | -- | @ParamOutOfBoundsError@ reports a nicer error with more context when we try to do an out-of-bounds lookup successfully do a lookup but 104 | -- find a different field than we expected, or when we find ourself out of bounds 105 | type family ParamOutOfBoundsError (originalIx :: Nat) (allParams :: [NullType]) (params :: [NullType]) :: Constraint where 106 | ParamOutOfBoundsError originalIx allParams '[] = TypeError 107 | ('Text "Index " ':<>: 'ShowType originalIx ':<>: 'Text " is out of bounds in 1-indexed parameter list:" ':$$: 'ShowType allParams) 108 | ParamOutOfBoundsError _ _ _ = () 109 | 110 | -- | @ParamTypeMismatchError@ reports a nicer error with more context when we successfully do a lookup but 111 | -- find a different field than we expected, or when we find ourself out of bounds 112 | type family ParamTypeMismatchError (originalIx :: Nat) (allParams :: [NullType]) (found :: NullType) (expected :: NullType) :: Constraint where 113 | ParamTypeMismatchError _ _ found found = () 114 | ParamTypeMismatchError originalIx allParams found expected = TypeError 115 | ( 'Text "Type mismatch when looking up param at index " ':<>: 'ShowType originalIx 116 | ':$$: 'Text "in 1-indexed parameter list:" 117 | ':$$: 'Text " " ':<>: 'ShowType allParams 118 | ':$$: 'Text "" 119 | ':$$: 'Text "Expected: " ':<>: 'ShowType expected 120 | ':$$: 'Text "But found: " ':<>: 'ShowType found 121 | ':$$: 'Text "" 122 | ) 123 | 124 | -- | `param` takes a `Nat` using type application and for basic types, 125 | -- infers a `TypeExpression`. 126 | -- 127 | -- >>> printSQL (param @1 @('Null 'PGint4)) 128 | -- ($1 :: int4) 129 | param 130 | :: forall n ty lat with db params from grp 131 | . (NullTyped db ty, HasParameter n params ty) 132 | => Expression grp lat with db params from ty -- ^ param 133 | param = parameter @n (nulltype @db) 134 | -------------------------------------------------------------------------------- /squeal-postgresql/src/Squeal/PostgreSQL/Expression/Range.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module: Squeal.PostgreSQL.Expression.Range 3 | Description: range types and functions 4 | Copyright: (c) Eitan Chatav, 2019 5 | Maintainer: eitan@morphism.tech 6 | Stability: experimental 7 | 8 | range types and functions 9 | -} 10 | 11 | {-# LANGUAGE 12 | AllowAmbiguousTypes 13 | , DataKinds 14 | , DeriveAnyClass 15 | , DeriveGeneric 16 | , DeriveFoldable 17 | , DerivingStrategies 18 | , DeriveTraversable 19 | , FlexibleContexts 20 | , FlexibleInstances 21 | , LambdaCase 22 | , MultiParamTypeClasses 23 | , OverloadedLabels 24 | , OverloadedStrings 25 | , PatternSynonyms 26 | , RankNTypes 27 | , ScopedTypeVariables 28 | , TypeApplications 29 | , TypeFamilies 30 | , TypeOperators 31 | , UndecidableInstances 32 | #-} 33 | 34 | module Squeal.PostgreSQL.Expression.Range 35 | ( -- * Range 36 | Range (..) 37 | , (<=..<=), (<..<), (<=..<), (<..<=) 38 | , moreThan, atLeast, lessThan, atMost 39 | , singleton, whole 40 | , Bound (..) 41 | -- * Range Function 42 | -- ** Range Construction 43 | , range 44 | -- ** Range Operator 45 | , (.<@) 46 | , (@>.) 47 | , (<<@) 48 | , (@>>) 49 | , (&<) 50 | , (&>) 51 | , (-|-) 52 | , (@+) 53 | , (@*) 54 | , (@-) 55 | -- ** Range Function 56 | , lowerBound 57 | , upperBound 58 | , isEmpty 59 | , lowerInc 60 | , lowerInf 61 | , upperInc 62 | , upperInf 63 | , rangeMerge 64 | ) where 65 | 66 | import qualified GHC.Generics as GHC 67 | import qualified Generics.SOP as SOP 68 | 69 | import Squeal.PostgreSQL.Expression 70 | import Squeal.PostgreSQL.Expression.Type hiding (bool) 71 | import Squeal.PostgreSQL.Type.PG 72 | import Squeal.PostgreSQL.Render 73 | import Squeal.PostgreSQL.Type.Schema 74 | 75 | -- $setup 76 | -- >>> import Squeal.PostgreSQL (tstzrange, numrange, int4range, now, printSQL) 77 | 78 | -- | Construct a `range` 79 | -- 80 | -- >>> printSQL $ range tstzrange (atLeast now) 81 | -- tstzrange(now(), NULL, '[)') 82 | -- >>> printSQL $ range numrange (0 <=..< 2*pi) 83 | -- numrange((0.0 :: numeric), ((2.0 :: numeric) * pi()), '[)') 84 | -- >>> printSQL $ range int4range Empty 85 | -- ('empty' :: int4range) 86 | range 87 | :: TypeExpression db (null ('PGrange ty)) 88 | -- ^ range type 89 | -> Range (Expression grp lat with db params from ('NotNull ty)) 90 | -- ^ range of values 91 | -> Expression grp lat with db params from (null ('PGrange ty)) 92 | range ty = \case 93 | Empty -> UnsafeExpression $ parenthesized 94 | (emp <+> "::" <+> renderSQL ty) 95 | NonEmpty l u -> UnsafeExpression $ renderSQL ty <> parenthesized 96 | (commaSeparated (args l u)) 97 | where 98 | emp = singleQuote <> "empty" <> singleQuote 99 | args l u = [arg l, arg u, singleQuote <> bra l <> ket u <> singleQuote] 100 | singleQuote = "\'" 101 | arg = \case 102 | Infinite -> "NULL"; Closed x -> renderSQL x; Open x -> renderSQL x 103 | bra = \case Infinite -> "("; Closed _ -> "["; Open _ -> "(" 104 | ket = \case Infinite -> ")"; Closed _ -> "]"; Open _ -> ")" 105 | 106 | -- | The type of `Bound` for a `Range`. 107 | data Bound x 108 | = Infinite -- ^ unbounded 109 | | Closed x -- ^ inclusive 110 | | Open x -- ^ exclusive 111 | deriving 112 | ( Eq, Ord, Show, Read, GHC.Generic 113 | , Functor, Foldable, Traversable ) 114 | 115 | -- | A `Range` datatype that comprises connected subsets of 116 | -- the real line. 117 | data Range x = Empty | NonEmpty (Bound x) (Bound x) 118 | deriving 119 | ( Eq, Ord, Show, Read, GHC.Generic 120 | , Functor, Foldable, Traversable ) 121 | deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) 122 | -- | `PGrange` @(@`PG` @hask)@ 123 | instance IsPG hask => IsPG (Range hask) where 124 | type PG (Range hask) = 'PGrange (PG hask) 125 | 126 | -- | Finite `Range` constructor 127 | (<=..<=), (<..<), (<=..<), (<..<=) :: x -> x -> Range x 128 | infix 4 <=..<=, <..<, <=..<, <..<= 129 | x <=..<= y = NonEmpty (Closed x) (Closed y) 130 | x <..< y = NonEmpty (Open x) (Open y) 131 | x <=..< y = NonEmpty (Closed x) (Open y) 132 | x <..<= y = NonEmpty (Open x) (Closed y) 133 | 134 | -- | Half-infinite `Range` constructor 135 | moreThan, atLeast, lessThan, atMost :: x -> Range x 136 | moreThan x = NonEmpty (Open x) Infinite 137 | atLeast x = NonEmpty (Closed x) Infinite 138 | lessThan x = NonEmpty Infinite (Open x) 139 | atMost x = NonEmpty Infinite (Closed x) 140 | 141 | -- | A point on the line 142 | singleton :: x -> Range x 143 | singleton x = x <=..<= x 144 | 145 | -- | The `whole` line 146 | whole :: Range x 147 | whole = NonEmpty Infinite Infinite 148 | 149 | -- | range is contained by 150 | (.<@) :: Operator (null0 ty) (null1 ('PGrange ty)) ('Null 'PGbool) 151 | (.<@) = unsafeBinaryOp "<@" 152 | 153 | -- | contains range 154 | (@>.) :: Operator (null0 ('PGrange ty)) (null1 ty) ('Null 'PGbool) 155 | (@>.) = unsafeBinaryOp "@>" 156 | 157 | -- | strictly left of, 158 | -- return false when an empty range is involved 159 | (<<@) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool) 160 | (<<@) = unsafeBinaryOp "<<" 161 | 162 | -- | strictly right of, 163 | -- return false when an empty range is involved 164 | (@>>) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool) 165 | (@>>) = unsafeBinaryOp ">>" 166 | 167 | -- | does not extend to the right of, 168 | -- return false when an empty range is involved 169 | (&<) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool) 170 | (&<) = unsafeBinaryOp "&<" 171 | 172 | -- | does not extend to the left of, 173 | -- return false when an empty range is involved 174 | (&>) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool) 175 | (&>) = unsafeBinaryOp "&>" 176 | 177 | -- | is adjacent to, return false when an empty range is involved 178 | (-|-) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool) 179 | (-|-) = unsafeBinaryOp "-|-" 180 | 181 | -- | union, will fail if the resulting range would 182 | -- need to contain two disjoint sub-ranges 183 | (@+) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) (null ('PGrange ty)) 184 | (@+) = unsafeBinaryOp "+" 185 | 186 | -- | intersection 187 | (@*) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) (null ('PGrange ty)) 188 | (@*) = unsafeBinaryOp "*" 189 | 190 | -- | difference, will fail if the resulting range would 191 | -- need to contain two disjoint sub-ranges 192 | (@-) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) (null ('PGrange ty)) 193 | (@-) = unsafeBinaryOp "-" 194 | 195 | -- | lower bound of range 196 | lowerBound :: null ('PGrange ty) --> 'Null ty 197 | lowerBound = unsafeFunction "lower" 198 | 199 | -- | upper bound of range 200 | upperBound :: null ('PGrange ty) --> 'Null ty 201 | upperBound = unsafeFunction "upper" 202 | 203 | -- | is the range empty? 204 | isEmpty :: null ('PGrange ty) --> 'Null 'PGbool 205 | isEmpty = unsafeFunction "isempty" 206 | 207 | -- | is the lower bound inclusive? 208 | lowerInc :: null ('PGrange ty) --> 'Null 'PGbool 209 | lowerInc = unsafeFunction "lower_inc" 210 | 211 | -- | is the lower bound infinite? 212 | lowerInf :: null ('PGrange ty) --> 'Null 'PGbool 213 | lowerInf = unsafeFunction "lower_inf" 214 | 215 | -- | is the upper bound inclusive? 216 | upperInc :: null ('PGrange ty) --> 'Null 'PGbool 217 | upperInc = unsafeFunction "upper_inc" 218 | 219 | -- | is the upper bound infinite? 220 | upperInf :: null ('PGrange ty) --> 'Null 'PGbool 221 | upperInf = unsafeFunction "upper_inf" 222 | 223 | -- | the smallest range which includes both of the given ranges 224 | rangeMerge :: 225 | '[null ('PGrange ty), null ('PGrange ty)] 226 | ---> null ('PGrange ty) 227 | rangeMerge = unsafeFunctionN "range_merge" 228 | -------------------------------------------------------------------------------- /squeal-postgresql/src/Squeal/PostgreSQL/Expression/Sort.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module: Squeal.PostgreSQL.Expression.Sort 3 | Description: sort expressions 4 | Copyright: (c) Eitan Chatav, 2019 5 | Maintainer: eitan@morphism.tech 6 | Stability: experimental 7 | 8 | sort expressions 9 | -} 10 | 11 | {-# LANGUAGE 12 | DataKinds 13 | , FlexibleInstances 14 | , FunctionalDependencies 15 | , GADTs 16 | , LambdaCase 17 | , MultiParamTypeClasses 18 | , OverloadedStrings 19 | , StandaloneDeriving 20 | #-} 21 | 22 | module Squeal.PostgreSQL.Expression.Sort 23 | ( -- * Sort 24 | SortExpression (..) 25 | , OrderBy (..) 26 | ) where 27 | 28 | import Squeal.PostgreSQL.Expression 29 | import Squeal.PostgreSQL.Render 30 | import Squeal.PostgreSQL.Type.Schema 31 | 32 | -- | `SortExpression`s are used by `orderBy` to optionally sort the results 33 | -- of a `Squeal.PostgreSQL.Query.Query`. `Asc` or `Desc` 34 | -- set the sort direction of a `NotNull` result 35 | -- column to ascending or descending. Ascending order puts smaller values 36 | -- first, where "smaller" is defined in terms of the 37 | -- `Squeal.PostgreSQL.Expression.Comparison..<` operator. Similarly, 38 | -- descending order is determined with the 39 | -- `Squeal.PostgreSQL.Expression.Comparison..>` operator. `AscNullsFirst`, 40 | -- `AscNullsLast`, `DescNullsFirst` and `DescNullsLast` options are used to 41 | -- determine whether nulls appear before or after non-null values in the sort 42 | -- ordering of a `Null` result column. 43 | data SortExpression grp lat with db params from where 44 | Asc 45 | :: Expression grp lat with db params from ('NotNull ty) 46 | -- ^ sort by 47 | -> SortExpression grp lat with db params from 48 | Desc 49 | :: Expression grp lat with db params from ('NotNull ty) 50 | -- ^ sort by 51 | -> SortExpression grp lat with db params from 52 | AscNullsFirst 53 | :: Expression grp lat with db params from ('Null ty) 54 | -- ^ sort by 55 | -> SortExpression grp lat with db params from 56 | AscNullsLast 57 | :: Expression grp lat with db params from ('Null ty) 58 | -- ^ sort by 59 | -> SortExpression grp lat with db params from 60 | DescNullsFirst 61 | :: Expression grp lat with db params from ('Null ty) 62 | -- ^ sort by 63 | -> SortExpression grp lat with db params from 64 | DescNullsLast 65 | :: Expression grp lat with db params from ('Null ty) 66 | -- ^ sort by 67 | -> SortExpression grp lat with db params from 68 | deriving instance Show (SortExpression grp lat with db params from) 69 | instance RenderSQL (SortExpression grp lat with db params from) where 70 | renderSQL = \case 71 | Asc expression -> renderSQL expression <+> "ASC" 72 | Desc expression -> renderSQL expression <+> "DESC" 73 | AscNullsFirst expression -> renderSQL expression 74 | <+> "ASC NULLS FIRST" 75 | DescNullsFirst expression -> renderSQL expression 76 | <+> "DESC NULLS FIRST" 77 | AscNullsLast expression -> renderSQL expression <+> "ASC NULLS LAST" 78 | DescNullsLast expression -> renderSQL expression <+> "DESC NULLS LAST" 79 | instance RenderSQL [SortExpression grp lat with db params from] where 80 | renderSQL = \case 81 | [] -> "" 82 | srts -> " ORDER BY" 83 | <+> commaSeparated (renderSQL <$> srts) 84 | 85 | {- | 86 | The `orderBy` clause causes the result rows of a `Squeal.PostgreSQL.Query.TableExpression` 87 | to be sorted according to the specified `SortExpression`(s). 88 | If two rows are equal according to the leftmost expression, 89 | they are compared according to the next expression and so on. 90 | If they are equal according to all specified expressions, 91 | they are returned in an implementation-dependent order. 92 | 93 | You can also control the order in which rows are processed by window functions 94 | using `orderBy` within `Squeal.PostgreSQL.Query.Over`. 95 | -} 96 | class OrderBy expr grp | expr -> grp where 97 | orderBy 98 | :: [SortExpression grp lat with db params from] 99 | -- ^ sorts 100 | -> expr lat with db params from 101 | -> expr lat with db params from 102 | -------------------------------------------------------------------------------- /squeal-postgresql/src/Squeal/PostgreSQL/Expression/Subquery.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module: Squeal.PostgreSQL.Expression.Subquery 3 | Description: subquery expressions 4 | Copyright: (c) Eitan Chatav, 2019 5 | Maintainer: eitan@morphism.tech 6 | Stability: experimental 7 | 8 | subquery expressions 9 | -} 10 | 11 | {-# LANGUAGE 12 | DataKinds 13 | , OverloadedStrings 14 | , RankNTypes 15 | , TypeOperators 16 | #-} 17 | 18 | module Squeal.PostgreSQL.Expression.Subquery 19 | ( -- * Subquery 20 | exists 21 | , in_ 22 | , notIn 23 | , subAll 24 | , subAny 25 | ) where 26 | 27 | import Squeal.PostgreSQL.Type.Alias 28 | import Squeal.PostgreSQL.Expression 29 | import Squeal.PostgreSQL.Expression.Logic 30 | import Squeal.PostgreSQL.Type.List 31 | import Squeal.PostgreSQL.Query 32 | import Squeal.PostgreSQL.Render 33 | import Squeal.PostgreSQL.Type.Schema 34 | 35 | -- $setup 36 | -- >>> import Squeal.PostgreSQL 37 | 38 | {- | 39 | The argument of `exists` is an arbitrary subquery. The subquery is evaluated 40 | to determine whether it returns any rows. If it returns at least one row, 41 | the result of `exists` is `true`; if the subquery returns no rows, 42 | the result of `exists` is `false`. 43 | 44 | The subquery can refer to variables from the surrounding query, 45 | which will act as constants during any one evaluation of the subquery. 46 | 47 | The subquery will generally only be executed long enough to determine whether 48 | at least one row is returned, not all the way to completion. 49 | -} 50 | exists 51 | :: Query (Join lat from) with db params row 52 | -- ^ subquery 53 | -> Expression grp lat with db params from (null 'PGbool) 54 | exists query = UnsafeExpression $ "EXISTS" <+> parenthesized (renderSQL query) 55 | 56 | {- | 57 | The right-hand side is a parenthesized subquery, which must return 58 | exactly one column. The left-hand expression is evaluated and compared to each 59 | row of the subquery result using the given `Operator`, 60 | which must yield a Boolean result. The result of `subAll` is `true` 61 | if all rows yield true (including the case where the subquery returns no rows). 62 | The result is `false` if any `false` result is found. 63 | The result is `Squeal.PostgreSQL.Expression.Null.null_` if 64 | no comparison with a subquery row returns `false`, 65 | and at least one comparison returns `Squeal.PostgreSQL.Expression.Null.null_`. 66 | 67 | >>> printSQL $ subAll true (.==) (values_ (true `as` #foo)) 68 | (TRUE = ALL (SELECT * FROM (VALUES (TRUE)) AS t ("foo"))) 69 | -} 70 | subAll 71 | :: Expression grp lat with db params from ty1 -- ^ expression 72 | -> Operator ty1 ty2 ('Null 'PGbool) -- ^ operator 73 | -> Query (Join lat from) with db params '[col ::: ty2] -- ^ subquery 74 | -> Condition grp lat with db params from 75 | subAll expr (?) qry = expr ? 76 | (UnsafeExpression $ "ALL" <+> parenthesized (renderSQL qry)) 77 | 78 | {- | 79 | The right-hand side is a parenthesized subquery, which must return exactly one column. 80 | The left-hand expression is evaluated and compared to each row of the subquery result 81 | using the given `Operator`, which must yield a Boolean result. The result of `subAny` is `true` 82 | if any `true` result is obtained. The result is `false` if no true result is found 83 | (including the case where the subquery returns no rows). 84 | 85 | >>> printSQL $ subAny "foo" like (values_ ("foobar" `as` #foo)) 86 | ((E'foo' :: text) LIKE ANY (SELECT * FROM (VALUES ((E'foobar' :: text))) AS t ("foo"))) 87 | -} 88 | subAny 89 | :: Expression grp lat with db params from ty1 -- ^ expression 90 | -> Operator ty1 ty2 ('Null 'PGbool) -- ^ operator 91 | -> Query (Join lat from) with db params '[col ::: ty2] -- ^ subquery 92 | -> Condition grp lat with db params from 93 | subAny expr (?) qry = expr ? 94 | (UnsafeExpression $ "ANY" <+> parenthesized (renderSQL qry)) 95 | 96 | {- | 97 | The result is `true` if the left-hand expression's result is equal 98 | to any of the right-hand expressions. 99 | 100 | >>> printSQL $ true `in_` [true, false, null_] 101 | TRUE IN (TRUE, FALSE, NULL) 102 | -} 103 | in_ 104 | :: Expression grp lat with db params from ty -- ^ expression 105 | -> [Expression grp lat with db params from ty] 106 | -> Expression grp lat with db params from ('Null 'PGbool) 107 | _ `in_` [] = false 108 | expr `in_` exprs = UnsafeExpression $ renderSQL expr <+> "IN" 109 | <+> parenthesized (commaSeparated (renderSQL <$> exprs)) 110 | 111 | {- | 112 | The result is `true` if the left-hand expression's result is not equal 113 | to any of the right-hand expressions. 114 | 115 | >>> printSQL $ true `notIn` [false, null_] 116 | TRUE NOT IN (FALSE, NULL) 117 | -} 118 | notIn 119 | :: Expression grp lat with db params from ty -- ^ expression 120 | -> [Expression grp lat with db params from ty] 121 | -> Expression grp lat with db params from ('Null 'PGbool) 122 | _ `notIn` [] = true 123 | expr `notIn` exprs = UnsafeExpression $ renderSQL expr <+> "NOT IN" 124 | <+> parenthesized (commaSeparated (renderSQL <$> exprs)) 125 | -------------------------------------------------------------------------------- /squeal-postgresql/src/Squeal/PostgreSQL/Expression/Text.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module: Squeal.PostgreSQL.Expression.Text 3 | Description: text functions and operators 4 | Copyright: (c) Eitan Chatav, 2019 5 | Maintainer: eitan@morphism.tech 6 | Stability: experimental 7 | 8 | text functions and operators 9 | -} 10 | 11 | {-# LANGUAGE 12 | DataKinds 13 | , OverloadedStrings 14 | , RankNTypes 15 | , ScopedTypeVariables 16 | , TypeOperators 17 | #-} 18 | 19 | module Squeal.PostgreSQL.Expression.Text 20 | ( -- * Text Function 21 | lower 22 | , upper 23 | , charLength 24 | , like 25 | , ilike 26 | , replace 27 | , strpos 28 | ) where 29 | 30 | import Squeal.PostgreSQL.Expression 31 | import Squeal.PostgreSQL.Type.Schema 32 | 33 | -- $setup 34 | -- >>> import Squeal.PostgreSQL 35 | 36 | -- | >>> printSQL $ lower "ARRRGGG" 37 | -- lower((E'ARRRGGG' :: text)) 38 | lower :: null 'PGtext --> null 'PGtext 39 | lower = unsafeFunction "lower" 40 | 41 | -- | >>> printSQL $ upper "eeee" 42 | -- upper((E'eeee' :: text)) 43 | upper :: null 'PGtext --> null 'PGtext 44 | upper = unsafeFunction "upper" 45 | 46 | -- | >>> printSQL $ charLength "four" 47 | -- char_length((E'four' :: text)) 48 | charLength :: null 'PGtext --> null 'PGint4 49 | charLength = unsafeFunction "char_length" 50 | 51 | -- | The `like` expression returns true if the @string@ matches 52 | -- the supplied @pattern@. If @pattern@ does not contain percent signs 53 | -- or underscores, then the pattern only represents the string itself; 54 | -- in that case `like` acts like the equals operator. An underscore (_) 55 | -- in pattern stands for (matches) any single character; a percent sign (%) 56 | -- matches any sequence of zero or more characters. 57 | -- 58 | -- >>> printSQL $ "abc" `like` "a%" 59 | -- ((E'abc' :: text) LIKE (E'a%' :: text)) 60 | like :: Operator (null 'PGtext) (null 'PGtext) ('Null 'PGbool) 61 | like = unsafeBinaryOp "LIKE" 62 | 63 | -- | The key word ILIKE can be used instead of LIKE to make the 64 | -- match case-insensitive according to the active locale. 65 | -- 66 | -- >>> printSQL $ "abc" `ilike` "a%" 67 | -- ((E'abc' :: text) ILIKE (E'a%' :: text)) 68 | ilike :: Operator (null 'PGtext) (null 'PGtext) ('Null 'PGbool) 69 | ilike = unsafeBinaryOp "ILIKE" 70 | 71 | -- | Determines the location of the substring match using the `strpos` 72 | -- function. Returns the 1-based index of the first match, if no 73 | -- match exists the function returns (0). 74 | -- 75 | -- >>> printSQL $ strpos ("string" *: "substring") 76 | -- strpos((E'string' :: text), (E'substring' :: text)) 77 | strpos 78 | :: '[null 'PGtext, null 'PGtext] ---> null 'PGint4 79 | strpos = unsafeFunctionN "strpos" 80 | 81 | -- | Over the string in the first argument, replace all occurrences of 82 | -- the second argument with the third and return the modified string. 83 | -- 84 | -- >>> printSQL $ replace ("string" :* "from" *: "to") 85 | -- replace((E'string' :: text), (E'from' :: text), (E'to' :: text)) 86 | replace 87 | :: '[ null 'PGtext, null 'PGtext, null 'PGtext ] ---> null 'PGtext 88 | replace = unsafeFunctionN "replace" 89 | -------------------------------------------------------------------------------- /squeal-postgresql/src/Squeal/PostgreSQL/Expression/TextSearch.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module: Squeal.PostgreSQL.Expression.TextSearch 3 | Description: text search functions and operators 4 | Copyright: (c) Eitan Chatav, 2019 5 | Maintainer: eitan@morphism.tech 6 | Stability: experimental 7 | 8 | text search functions and operators 9 | -} 10 | 11 | {-# LANGUAGE 12 | DataKinds 13 | , OverloadedStrings 14 | , TypeOperators 15 | #-} 16 | 17 | module Squeal.PostgreSQL.Expression.TextSearch 18 | ( -- * Text Search Operator 19 | (@@) 20 | , (.&) 21 | , (.|) 22 | , (.!) 23 | , (<->) 24 | -- * Text Search Function 25 | , arrayToTSvector 26 | , tsvectorLength 27 | , numnode 28 | , plainToTSquery 29 | , phraseToTSquery 30 | , websearchToTSquery 31 | , queryTree 32 | , toTSquery 33 | , toTSvector 34 | , setWeight 35 | , strip 36 | , jsonToTSvector 37 | , jsonbToTSvector 38 | , tsDelete 39 | , tsFilter 40 | , tsHeadline 41 | ) where 42 | 43 | import Squeal.PostgreSQL.Expression 44 | import Squeal.PostgreSQL.Type.List 45 | import Squeal.PostgreSQL.Type.Schema 46 | 47 | -- | `Squeal.PostgreSQL.Expression.Type.tsvector` matches tsquery ? 48 | (@@) :: Operator (null 'PGtsvector) (null 'PGtsquery) ('Null 'PGbool) 49 | (@@) = unsafeBinaryOp "@@" 50 | 51 | -- | AND `Squeal.PostgreSQL.Expression.Type.tsquery`s together 52 | (.&) :: Operator (null 'PGtsquery) (null 'PGtsquery) (null 'PGtsquery) 53 | (.&) = unsafeBinaryOp "&&" 54 | 55 | -- | OR `Squeal.PostgreSQL.Expression.Type.tsquery`s together 56 | (.|) :: Operator (null 'PGtsquery) (null 'PGtsquery) (null 'PGtsquery) 57 | (.|) = unsafeBinaryOp "||" 58 | 59 | -- | negate a `Squeal.PostgreSQL.Expression.Type.tsquery` 60 | (.!) :: null 'PGtsquery --> null 'PGtsquery 61 | (.!) = unsafeLeftOp "!!" 62 | 63 | -- | `Squeal.PostgreSQL.Expression.Type.tsquery` followed by 64 | -- `Squeal.PostgreSQL.Expression.Type.tsquery` 65 | (<->) :: Operator (null 'PGtsquery) (null 'PGtsquery) (null 'PGtsquery) 66 | (<->) = unsafeBinaryOp "<->" 67 | 68 | -- | convert array of lexemes to `Squeal.PostgreSQL.Expression.Type.tsvector` 69 | arrayToTSvector 70 | :: null ('PGvararray ('NotNull 'PGtext)) 71 | --> null 'PGtsvector 72 | arrayToTSvector = unsafeFunction "array_to_tsvector" 73 | 74 | -- | number of lexemes in `Squeal.PostgreSQL.Expression.Type.tsvector` 75 | tsvectorLength :: null 'PGtsvector --> null 'PGint4 76 | tsvectorLength = unsafeFunction "length" 77 | 78 | -- | number of lexemes plus operators in `Squeal.PostgreSQL.Expression.Type.tsquery` 79 | numnode :: null 'PGtsquery --> null 'PGint4 80 | numnode = unsafeFunction "numnode" 81 | 82 | -- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` ignoring punctuation 83 | plainToTSquery :: null 'PGtext --> null 'PGtsquery 84 | plainToTSquery = unsafeFunction "plainto_tsquery" 85 | 86 | -- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` that searches for a phrase, 87 | -- ignoring punctuation 88 | phraseToTSquery :: null 'PGtext --> null 'PGtsquery 89 | phraseToTSquery = unsafeFunction "phraseto_tsquery" 90 | 91 | -- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` from a web search style query 92 | websearchToTSquery :: null 'PGtext --> null 'PGtsquery 93 | websearchToTSquery = unsafeFunction "websearch_to_tsquery" 94 | 95 | -- | get indexable part of a `Squeal.PostgreSQL.Expression.Type.tsquery` 96 | queryTree :: null 'PGtsquery --> null 'PGtext 97 | queryTree = unsafeFunction "query_tree" 98 | 99 | -- | normalize words and convert to `Squeal.PostgreSQL.Expression.Type.tsquery` 100 | toTSquery :: null 'PGtext --> null 'PGtsquery 101 | toTSquery = unsafeFunction "to_tsquery" 102 | 103 | -- | reduce document text to `Squeal.PostgreSQL.Expression.Type.tsvector` 104 | toTSvector 105 | :: ty `In` '[ 'PGtext, 'PGjson, 'PGjsonb] 106 | => null ty --> null 'PGtsvector 107 | toTSvector = unsafeFunction "to_tsvector" 108 | 109 | -- | assign weight to each element of `Squeal.PostgreSQL.Expression.Type.tsvector` 110 | setWeight :: '[null 'PGtsvector, null ('PGchar 1)] ---> null 'PGtsvector 111 | setWeight = unsafeFunctionN "set_weight" 112 | 113 | -- | remove positions and weights from `Squeal.PostgreSQL.Expression.Type.tsvector` 114 | strip :: null 'PGtsvector --> null 'PGtsvector 115 | strip = unsafeFunction "strip" 116 | 117 | -- | @jsonToTSvector (document *: filter)@ 118 | -- reduce each value in the document, specified by filter to a `Squeal.PostgreSQL.Expression.Type.tsvector`, 119 | -- and then concatenate those in document order to produce a single `Squeal.PostgreSQL.Expression.Type.tsvector`. 120 | -- filter is a `Squeal.PostgreSQL.Expression.Type.json` array, that enumerates what kind of elements 121 | -- need to be included into the resulting `Squeal.PostgreSQL.Expression.Type.tsvector`. 122 | -- Possible values for filter are "string" (to include all string values), 123 | -- "numeric" (to include all numeric values in the string format), 124 | -- "boolean" (to include all Boolean values in the string format "true"/"false"), 125 | -- "key" (to include all keys) or "all" (to include all above). 126 | -- These values can be combined together to include, e.g. all string and numeric values. 127 | jsonToTSvector :: '[null 'PGjson, null 'PGjson] ---> null 'PGtsvector 128 | jsonToTSvector = unsafeFunctionN "json_to_tsvector" 129 | 130 | -- | @jsonbToTSvector (document *: filter)@ 131 | -- reduce each value in the document, specified by filter to a `Squeal.PostgreSQL.Expression.Type.tsvector`, 132 | -- and then concatenate those in document order to produce a single `Squeal.PostgreSQL.Expression.Type.tsvector`. 133 | -- filter is a `Squeal.PostgreSQL.Expression.Type.jsonb` array, that enumerates what kind of elements 134 | -- need to be included into the resulting `Squeal.PostgreSQL.Expression.Type.tsvector`. 135 | -- Possible values for filter are "string" (to include all string values), 136 | -- "numeric" (to include all numeric values in the string format), 137 | -- "boolean" (to include all Boolean values in the string format "true"/"false"), 138 | -- "key" (to include all keys) or "all" (to include all above). 139 | -- These values can be combined together to include, e.g. all string and numeric values. 140 | jsonbToTSvector :: '[null 'PGjsonb, null 'PGjsonb] ---> null 'PGtsvector 141 | jsonbToTSvector = unsafeFunctionN "jsonb_to_tsvector" 142 | 143 | -- | remove given lexeme from `Squeal.PostgreSQL.Expression.Type.tsvector` 144 | tsDelete :: 145 | '[null 'PGtsvector, null ('PGvararray ('NotNull 'PGtext))] 146 | ---> null 'PGtsvector 147 | tsDelete = unsafeFunctionN "ts_delete" 148 | 149 | -- | select only elements with given weights from `Squeal.PostgreSQL.Expression.Type.tsvector` 150 | tsFilter :: 151 | '[null 'PGtsvector, null ('PGvararray ('NotNull ('PGchar 1)))] 152 | ---> null 'PGtsvector 153 | tsFilter = unsafeFunctionN "ts_filter" 154 | 155 | -- | display a `Squeal.PostgreSQL.Expression.Type.tsquery` match 156 | tsHeadline 157 | :: document `In` '[ 'PGtext, 'PGjson, 'PGjsonb] 158 | => '[null document, null 'PGtsquery] ---> null 'PGtext 159 | tsHeadline = unsafeFunctionN "ts_headline" 160 | -------------------------------------------------------------------------------- /squeal-postgresql/src/Squeal/PostgreSQL/Expression/Time.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module: Squeal.PostgreSQL.Expression.Time 3 | Description: date/time functions and operators 4 | Copyright: (c) Eitan Chatav, 2019 5 | Maintainer: eitan@morphism.tech 6 | Stability: experimental 7 | 8 | date/time functions and operators 9 | -} 10 | 11 | {-# LANGUAGE 12 | DataKinds 13 | , DeriveGeneric 14 | , FunctionalDependencies 15 | , LambdaCase 16 | , MultiParamTypeClasses 17 | , OverloadedStrings 18 | , PolyKinds 19 | , RankNTypes 20 | , TypeFamilies 21 | , TypeOperators 22 | , UndecidableInstances 23 | #-} 24 | 25 | module Squeal.PostgreSQL.Expression.Time 26 | ( -- * Time Operation 27 | TimeOp (..) 28 | -- * Time Function 29 | , currentDate 30 | , currentTime 31 | , currentTimestamp 32 | , dateTrunc 33 | , localTime 34 | , localTimestamp 35 | , now 36 | , makeDate 37 | , makeTime 38 | , makeTimestamp 39 | , makeTimestamptz 40 | , atTimeZone 41 | , PGAtTimeZone 42 | -- * Interval 43 | , interval_ 44 | , TimeUnit (..) 45 | ) where 46 | 47 | import Data.Fixed 48 | import Data.String 49 | import GHC.TypeLits 50 | 51 | import qualified GHC.Generics as GHC 52 | import qualified Generics.SOP as SOP 53 | 54 | import Squeal.PostgreSQL.Expression 55 | import Squeal.PostgreSQL.Render 56 | import Squeal.PostgreSQL.Type.List 57 | import Squeal.PostgreSQL.Type.Schema 58 | 59 | -- $setup 60 | -- >>> import Squeal.PostgreSQL 61 | 62 | -- | >>> printSQL currentDate 63 | -- CURRENT_DATE 64 | currentDate :: Expr (null 'PGdate) 65 | currentDate = UnsafeExpression "CURRENT_DATE" 66 | 67 | -- | >>> printSQL currentTime 68 | -- CURRENT_TIME 69 | currentTime :: Expr (null 'PGtimetz) 70 | currentTime = UnsafeExpression "CURRENT_TIME" 71 | 72 | -- | >>> printSQL currentTimestamp 73 | -- CURRENT_TIMESTAMP 74 | currentTimestamp :: Expr (null 'PGtimestamptz) 75 | currentTimestamp = UnsafeExpression "CURRENT_TIMESTAMP" 76 | 77 | -- | >>> printSQL localTime 78 | -- LOCALTIME 79 | localTime :: Expr (null 'PGtime) 80 | localTime = UnsafeExpression "LOCALTIME" 81 | 82 | -- | >>> printSQL localTimestamp 83 | -- LOCALTIMESTAMP 84 | localTimestamp :: Expr (null 'PGtimestamp) 85 | localTimestamp = UnsafeExpression "LOCALTIMESTAMP" 86 | 87 | -- | Current date and time (equivalent to `currentTimestamp`) 88 | -- 89 | -- >>> printSQL now 90 | -- now() 91 | now :: Expr (null 'PGtimestamptz) 92 | now = UnsafeExpression "now()" 93 | 94 | {-| 95 | Create date from year, month and day fields 96 | 97 | >>> printSQL (makeDate (1984 :* 7 *: 3)) 98 | make_date((1984 :: int4), (7 :: int4), (3 :: int4)) 99 | -} 100 | makeDate :: '[ null 'PGint4, null 'PGint4, null 'PGint4 ] ---> null 'PGdate 101 | makeDate = unsafeFunctionN "make_date" 102 | 103 | {-| 104 | Create time from hour, minute and seconds fields 105 | 106 | >>> printSQL (makeTime (8 :* 15 *: 23.5)) 107 | make_time((8 :: int4), (15 :: int4), (23.5 :: float8)) 108 | -} 109 | makeTime :: '[ null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtime 110 | makeTime = unsafeFunctionN "make_time" 111 | 112 | {-| 113 | Create timestamp from year, month, day, hour, minute and seconds fields 114 | 115 | >>> printSQL (makeTimestamp (2013 :* 7 :* 15 :* 8 :* 15 *: 23.5)) 116 | make_timestamp((2013 :: int4), (7 :: int4), (15 :: int4), (8 :: int4), (15 :: int4), (23.5 :: float8)) 117 | -} 118 | makeTimestamp :: 119 | '[ null 'PGint4, null 'PGint4, null 'PGint4 120 | , null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtimestamp 121 | makeTimestamp = unsafeFunctionN "make_timestamp" 122 | 123 | {-| 124 | Create timestamp with time zone from 125 | year, month, day, hour, minute and seconds fields; 126 | the current time zone is used 127 | 128 | >>> printSQL (makeTimestamptz (2013 :* 7 :* 15 :* 8 :* 15 *: 23.5)) 129 | make_timestamptz((2013 :: int4), (7 :: int4), (15 :: int4), (8 :: int4), (15 :: int4), (23.5 :: float8)) 130 | -} 131 | makeTimestamptz :: 132 | '[ null 'PGint4, null 'PGint4, null 'PGint4 133 | , null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtimestamptz 134 | makeTimestamptz = unsafeFunctionN "make_timestamptz" 135 | 136 | {-| 137 | Truncate a timestamp with the specified precision 138 | 139 | >>> printSQL $ dateTrunc Quarter (makeTimestamp (2010 :* 5 :* 6 :* 14 :* 45 *: 11.4)) 140 | date_trunc('quarter', make_timestamp((2010 :: int4), (5 :: int4), (6 :: int4), (14 :: int4), (45 :: int4), (11.4 :: float8))) 141 | -} 142 | dateTrunc 143 | :: time `In` '[ 'PGtimestamp, 'PGtimestamptz ] 144 | => TimeUnit -> null time --> null time 145 | dateTrunc tUnit args = unsafeFunctionN "date_trunc" (timeUnitExpr *: args) 146 | where 147 | timeUnitExpr :: forall grp lat with db params from null0. 148 | Expression grp lat with db params from (null0 'PGtext) 149 | timeUnitExpr = UnsafeExpression . singleQuotedUtf8 . renderSQL $ tUnit 150 | 151 | -- | Calculate the return time type of the `atTimeZone` `Operator`. 152 | type family PGAtTimeZone ty where 153 | PGAtTimeZone 'PGtimestamptz = 'PGtimestamp 154 | PGAtTimeZone 'PGtimestamp = 'PGtimestamptz 155 | PGAtTimeZone 'PGtimetz = 'PGtimetz 156 | PGAtTimeZone pg = TypeError 157 | ( 'Text "Squeal type error: AT TIME ZONE cannot be applied to " 158 | ':<>: 'ShowType pg ) 159 | 160 | {-| 161 | Convert a timestamp, timestamp with time zone, or time of day with timezone to a different timezone using an interval offset or specific timezone denoted by text. When using the interval offset, the interval duration must be less than one day or 24 hours. 162 | 163 | >>> printSQL $ (makeTimestamp (2009 :* 7 :* 22 :* 19 :* 45 *: 11.4)) `atTimeZone` (interval_ 8 Hours) 164 | (make_timestamp((2009 :: int4), (7 :: int4), (22 :: int4), (19 :: int4), (45 :: int4), (11.4 :: float8)) AT TIME ZONE (INTERVAL '8.000 hours')) 165 | 166 | >>> :{ 167 | let 168 | timezone :: Expr (null 'PGtext) 169 | timezone = "EST" 170 | in printSQL $ (makeTimestamptz (2015 :* 9 :* 15 :* 4 :* 45 *: 11.4)) `atTimeZone` timezone 171 | :} 172 | (make_timestamptz((2015 :: int4), (9 :: int4), (15 :: int4), (4 :: int4), (45 :: int4), (11.4 :: float8)) AT TIME ZONE (E'EST' :: text)) 173 | -} 174 | atTimeZone 175 | :: zone `In` '[ 'PGtext, 'PGinterval] 176 | => Operator (null time) (null zone) (null (PGAtTimeZone time)) 177 | atTimeZone = unsafeBinaryOp "AT TIME ZONE" 178 | 179 | {-| 180 | Affine space operations on time types. 181 | -} 182 | class TimeOp time diff | time -> diff where 183 | {-| 184 | >>> printSQL (makeDate (1984 :* 7 *: 3) !+ 365) 185 | (make_date((1984 :: int4), (7 :: int4), (3 :: int4)) + (365 :: int4)) 186 | -} 187 | (!+) :: Operator (null time) (null diff) (null time) 188 | (!+) = unsafeBinaryOp "+" 189 | {-| 190 | >>> printSQL (365 +! makeDate (1984 :* 7 *: 3)) 191 | ((365 :: int4) + make_date((1984 :: int4), (7 :: int4), (3 :: int4))) 192 | -} 193 | (+!) :: Operator (null diff) (null time) (null time) 194 | (+!) = unsafeBinaryOp "+" 195 | {-| 196 | >>> printSQL (makeDate (1984 :* 7 *: 3) !- 365) 197 | (make_date((1984 :: int4), (7 :: int4), (3 :: int4)) - (365 :: int4)) 198 | -} 199 | (!-) :: Operator (null time) (null diff) (null time) 200 | (!-) = unsafeBinaryOp "-" 201 | {-| 202 | >>> printSQL (makeDate (1984 :* 7 *: 3) !-! currentDate) 203 | (make_date((1984 :: int4), (7 :: int4), (3 :: int4)) - CURRENT_DATE) 204 | -} 205 | (!-!) :: Operator (null time) (null time) (null diff) 206 | (!-!) = unsafeBinaryOp "-" 207 | instance TimeOp 'PGtimestamp 'PGinterval 208 | instance TimeOp 'PGtimestamptz 'PGinterval 209 | instance TimeOp 'PGtime 'PGinterval 210 | instance TimeOp 'PGtimetz 'PGinterval 211 | instance TimeOp 'PGinterval 'PGinterval 212 | instance TimeOp 'PGdate 'PGint4 213 | infixl 6 !+ 214 | infixl 6 +! 215 | infixl 6 !- 216 | infixl 6 !-! 217 | 218 | -- | A `TimeUnit` to use in `interval_` construction. 219 | data TimeUnit 220 | = Years | Quarter | Months | Weeks | Days 221 | | Hours | Minutes | Seconds 222 | | Microseconds | Milliseconds 223 | | Decades | Centuries | Millennia 224 | deriving (Eq, Ord, Show, Read, Enum, GHC.Generic) 225 | instance SOP.Generic TimeUnit 226 | instance SOP.HasDatatypeInfo TimeUnit 227 | instance RenderSQL TimeUnit where 228 | renderSQL = \case 229 | Years -> "years" 230 | Quarter -> "quarter" 231 | Months -> "months" 232 | Weeks -> "weeks" 233 | Days -> "days" 234 | Hours -> "hours" 235 | Minutes -> "minutes" 236 | Seconds -> "seconds" 237 | Microseconds -> "microseconds" 238 | Milliseconds -> "milliseconds" 239 | Decades -> "decades" 240 | Centuries -> "centuries" 241 | Millennia -> "millennia" 242 | 243 | -- | >>> printSQL $ interval_ 7 Days 244 | -- (INTERVAL '7.000 days') 245 | interval_ :: Milli -> TimeUnit -> Expr (null 'PGinterval) 246 | interval_ num unit = UnsafeExpression . parenthesized $ "INTERVAL" <+> 247 | "'" <> fromString (show num) <+> renderSQL unit <> "'" 248 | -------------------------------------------------------------------------------- /squeal-postgresql/src/Squeal/PostgreSQL/Manipulation/Call.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module: Squeal.PostgreSQL.Call 3 | Description: call statements 4 | Copyright: (c) Eitan Chatav, 2019 5 | Maintainer: eitan@morphism.tech 6 | Stability: experimental 7 | 8 | call statements 9 | -} 10 | 11 | {-# LANGUAGE 12 | DeriveGeneric 13 | , DerivingStrategies 14 | , FlexibleContexts 15 | , FlexibleInstances 16 | , GADTs 17 | , GeneralizedNewtypeDeriving 18 | , LambdaCase 19 | , MultiParamTypeClasses 20 | , OverloadedStrings 21 | , PatternSynonyms 22 | , QuantifiedConstraints 23 | , RankNTypes 24 | , ScopedTypeVariables 25 | , TypeApplications 26 | , TypeFamilies 27 | , DataKinds 28 | , PolyKinds 29 | , TypeOperators 30 | , UndecidableInstances 31 | #-} 32 | 33 | module Squeal.PostgreSQL.Manipulation.Call 34 | ( -- * Call 35 | call 36 | , unsafeCall 37 | , callN 38 | , unsafeCallN 39 | ) where 40 | 41 | import Data.ByteString hiding (foldr) 42 | 43 | import Generics.SOP (SListI) 44 | 45 | import Squeal.PostgreSQL.Type.Alias 46 | import Squeal.PostgreSQL.Expression 47 | import Squeal.PostgreSQL.Manipulation 48 | import Squeal.PostgreSQL.Type.List 49 | import Squeal.PostgreSQL.Render 50 | import Squeal.PostgreSQL.Type.Schema 51 | 52 | -- $setup 53 | -- >>> import Squeal.PostgreSQL 54 | 55 | {- | 56 | >>> printSQL $ unsafeCall "p" true 57 | CALL p(TRUE) 58 | -} 59 | unsafeCall 60 | :: ByteString -- ^ procedure to call 61 | -> Expression 'Ungrouped '[] with db params '[] x -- ^ arguments 62 | -> Manipulation with db params '[] 63 | unsafeCall pro x = UnsafeManipulation $ 64 | "CALL" <+> pro <> parenthesized (renderSQL x) 65 | 66 | {- | Call a user defined procedure of one variable. 67 | 68 | >>> type Schema = '[ "p" ::: 'Procedure '[ 'NotNull 'PGint4 ] ] 69 | >>> :{ 70 | let 71 | p :: Manipulation '[] (Public Schema) '[] '[] 72 | p = call #p 1 73 | in 74 | printSQL p 75 | :} 76 | CALL "p"((1 :: int4)) 77 | -} 78 | call 79 | :: ( Has sch db schema 80 | , Has pro schema ('Procedure '[x]) ) 81 | => QualifiedAlias sch pro -- ^ procedure to call 82 | -> Expression 'Ungrouped '[] with db params '[] x -- ^ arguments 83 | -> Manipulation with db params '[] 84 | call = unsafeCall . renderSQL 85 | 86 | 87 | {- | 88 | >>> printSQL $ unsafeCallN "p" (true *: false) 89 | CALL p(TRUE, FALSE) 90 | -} 91 | unsafeCallN 92 | :: SListI xs 93 | => ByteString -- ^ procedure to call 94 | -> NP (Expression 'Ungrouped '[] with db params '[]) xs -- ^ arguments 95 | -> Manipulation with db params '[] 96 | unsafeCallN pro xs = UnsafeManipulation $ 97 | "CALL" <+> pro <> parenthesized (renderCommaSeparated renderSQL xs) 98 | 99 | {- | Call a user defined procedure. 100 | 101 | >>> type Schema = '[ "p" ::: 'Procedure '[ 'NotNull 'PGint4, 'NotNull 'PGtext ] ] 102 | >>> :{ 103 | let 104 | p :: Manipulation '[] (Public Schema) '[] '[] 105 | p = callN #p (1 *: "hi") 106 | in 107 | printSQL p 108 | :} 109 | CALL "p"((1 :: int4), (E'hi' :: text)) 110 | -} 111 | callN 112 | :: ( Has sch db schema 113 | , Has pro schema ('Procedure xs) 114 | , SListI xs ) 115 | => QualifiedAlias sch pro -- ^ procedure to call 116 | -> NP (Expression 'Ungrouped '[] with db params '[]) xs -- ^ arguments 117 | -> Manipulation with db params '[] 118 | callN = unsafeCallN . renderSQL 119 | -------------------------------------------------------------------------------- /squeal-postgresql/src/Squeal/PostgreSQL/Manipulation/Delete.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module: Squeal.PostgreSQL.Delete 3 | Description: delete statements 4 | Copyright: (c) Eitan Chatav, 2019 5 | Maintainer: eitan@morphism.tech 6 | Stability: experimental 7 | 8 | delete statements 9 | -} 10 | 11 | {-# LANGUAGE 12 | DeriveGeneric 13 | , DerivingStrategies 14 | , FlexibleContexts 15 | , FlexibleInstances 16 | , GADTs 17 | , GeneralizedNewtypeDeriving 18 | , LambdaCase 19 | , MultiParamTypeClasses 20 | , OverloadedStrings 21 | , PatternSynonyms 22 | , QuantifiedConstraints 23 | , RankNTypes 24 | , ScopedTypeVariables 25 | , TypeApplications 26 | , TypeFamilies 27 | , DataKinds 28 | , PolyKinds 29 | , TypeOperators 30 | , UndecidableInstances 31 | #-} 32 | 33 | module Squeal.PostgreSQL.Manipulation.Delete 34 | ( -- * Delete 35 | deleteFrom 36 | , deleteFrom_ 37 | ) where 38 | 39 | import qualified Generics.SOP as SOP 40 | 41 | import Squeal.PostgreSQL.Type.Alias 42 | import Squeal.PostgreSQL.Expression.Logic 43 | import Squeal.PostgreSQL.Manipulation 44 | import Squeal.PostgreSQL.Type.List 45 | import Squeal.PostgreSQL.Render 46 | import Squeal.PostgreSQL.Type.Schema 47 | 48 | -- $setup 49 | -- >>> import Squeal.PostgreSQL 50 | 51 | {----------------------------------------- 52 | DELETE statements 53 | -----------------------------------------} 54 | 55 | {- | Delete rows from a table. 56 | 57 | >>> type Columns = '["col1" ::: 'Def :=> 'NotNull 'PGint4, "col2" ::: 'NoDef :=> 'NotNull 'PGint4] 58 | >>> type Schema = '["tab1" ::: 'Table ('[] :=> Columns), "tab2" ::: 'Table ('[] :=> Columns)] 59 | >>> :{ 60 | let 61 | manp :: Manipulation with (Public Schema) '[] '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4] 62 | manp = deleteFrom #tab1 (Using (table #tab2)) (#tab1 ! #col1 .== #tab2 ! #col2) (Returning (#tab1 & DotStar)) 63 | in printSQL manp 64 | :} 65 | DELETE FROM "tab1" AS "tab1" USING "tab2" AS "tab2" WHERE ("tab1"."col1" = "tab2"."col2") RETURNING "tab1".* 66 | -} 67 | deleteFrom 68 | :: ( SOP.SListI row 69 | , Has sch db schema 70 | , Has tab0 schema ('Table table) ) 71 | => Aliased (QualifiedAlias sch) (tab ::: tab0) -- ^ table to delete from 72 | -> UsingClause with db params from 73 | -> Condition 'Ungrouped '[] with db params (tab ::: TableToRow table ': from) 74 | -- ^ condition under which to delete a row 75 | -> ReturningClause with db params (tab ::: TableToRow table ': from) row 76 | -- ^ results to return 77 | -> Manipulation with db params row 78 | deleteFrom (tab0 `As` tab) using wh returning = UnsafeManipulation $ 79 | "DELETE FROM" 80 | <+> renderSQL tab0 <+> "AS" <+> renderSQL tab 81 | <> case using of 82 | NoUsing -> "" 83 | Using tables -> " USING" <+> renderSQL tables 84 | <+> "WHERE" <+> renderSQL wh 85 | <> renderSQL returning 86 | 87 | {- | Delete rows returning `Nil`. 88 | 89 | >>> type Columns = '["col1" ::: 'Def :=> 'NotNull 'PGint4] 90 | >>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)] 91 | >>> :{ 92 | let 93 | manp :: Manipulation with (Public Schema) '[ 'NotNull 'PGint4] '[] 94 | manp = deleteFrom_ (#tab `as` #t) (#t ! #col1 .== param @1) 95 | in printSQL manp 96 | :} 97 | DELETE FROM "tab" AS "t" WHERE ("t"."col1" = ($1 :: int4)) 98 | -} 99 | deleteFrom_ 100 | :: ( Has sch db schema 101 | , Has tab0 schema ('Table table) ) 102 | => Aliased (QualifiedAlias sch) (tab ::: tab0) -- ^ table to delete from 103 | -> Condition 'Ungrouped '[] with db params '[tab ::: TableToRow table] 104 | -- ^ condition under which to delete a row 105 | -> Manipulation with db params '[] 106 | deleteFrom_ tab wh = deleteFrom tab NoUsing wh (Returning_ Nil) 107 | -------------------------------------------------------------------------------- /squeal-postgresql/src/Squeal/PostgreSQL/Manipulation/Update.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module: Squeal.PostgreSQL.Update 3 | Description: update statements 4 | Copyright: (c) Eitan Chatav, 2019 5 | Maintainer: eitan@morphism.tech 6 | Stability: experimental 7 | 8 | update statements 9 | -} 10 | 11 | {-# LANGUAGE 12 | DeriveGeneric 13 | , DerivingStrategies 14 | , FlexibleContexts 15 | , FlexibleInstances 16 | , GADTs 17 | , GeneralizedNewtypeDeriving 18 | , LambdaCase 19 | , MultiParamTypeClasses 20 | , OverloadedStrings 21 | , PatternSynonyms 22 | , QuantifiedConstraints 23 | , RankNTypes 24 | , ScopedTypeVariables 25 | , TypeApplications 26 | , TypeFamilies 27 | , DataKinds 28 | , PolyKinds 29 | , TypeOperators 30 | , UndecidableInstances 31 | #-} 32 | 33 | module Squeal.PostgreSQL.Manipulation.Update 34 | ( -- * Update 35 | update 36 | , update_ 37 | ) where 38 | 39 | import Data.ByteString hiding (foldr) 40 | import GHC.TypeLits 41 | 42 | import qualified Generics.SOP as SOP 43 | 44 | import Squeal.PostgreSQL.Type.Alias 45 | import Squeal.PostgreSQL.Expression 46 | import Squeal.PostgreSQL.Expression.Default 47 | import Squeal.PostgreSQL.Expression.Logic 48 | import Squeal.PostgreSQL.Manipulation 49 | import Squeal.PostgreSQL.Type.List 50 | import Squeal.PostgreSQL.Render 51 | import Squeal.PostgreSQL.Type.Schema 52 | 53 | -- $setup 54 | -- >>> import Squeal.PostgreSQL 55 | 56 | renderUpdate 57 | :: (forall x. RenderSQL (expr x)) 58 | => Aliased (Optional expr) ty 59 | -> ByteString 60 | renderUpdate (expr `As` col) = renderSQL col <+> "=" <+> renderSQL expr 61 | 62 | {----------------------------------------- 63 | UPDATE statements 64 | -----------------------------------------} 65 | 66 | {- | An `update` command changes the values of the specified columns 67 | in all rows that satisfy the condition. 68 | 69 | >>> type Columns = '["col1" ::: 'Def :=> 'NotNull 'PGint4, "col2" ::: 'NoDef :=> 'NotNull 'PGint4] 70 | >>> type Schema = '["tab1" ::: 'Table ('[] :=> Columns), "tab2" ::: 'Table ('[] :=> Columns)] 71 | >>> :{ 72 | let 73 | manp :: Manipulation with (Public Schema) '[] 74 | '["col1" ::: 'NotNull 'PGint4, 75 | "col2" ::: 'NotNull 'PGint4] 76 | manp = update 77 | (#tab1 `as` #t1) 78 | (Set (2 + #t2 ! #col2) `as` #col1) 79 | (Using (table (#tab2 `as` #t2))) 80 | (#t1 ! #col1 ./= #t2 ! #col2) 81 | (Returning (#t1 & DotStar)) 82 | in printSQL manp 83 | :} 84 | UPDATE "tab1" AS "t1" SET "col1" = ((2 :: int4) + "t2"."col2") FROM "tab2" AS "t2" WHERE ("t1"."col1" <> "t2"."col2") RETURNING "t1".* 85 | -} 86 | update 87 | :: ( Has sch db schema 88 | , Has tab0 schema ('Table table) 89 | , Updatable table updates 90 | , SOP.SListI row ) 91 | => Aliased (QualifiedAlias sch) (tab ::: tab0) -- ^ table to update 92 | -> NP (Aliased (Optional (Expression 'Ungrouped '[] with db params (tab ::: TableToRow table ': from)))) updates 93 | -- ^ update expressions, modified values to replace old values 94 | -> UsingClause with db params from 95 | -- ^ FROM A table expression allowing columns from other tables to appear 96 | -- in the WHERE condition and update expressions. 97 | -> Condition 'Ungrouped '[] with db params (tab ::: TableToRow table ': from) 98 | -- ^ WHERE condition under which to perform update on a row 99 | -> ReturningClause with db params (tab ::: TableToRow table ': from) row -- ^ results to return 100 | -> Manipulation with db params row 101 | update (tab0 `As` tab) columns using wh returning = UnsafeManipulation $ 102 | "UPDATE" 103 | <+> renderSQL tab0 <+> "AS" <+> renderSQL tab 104 | <+> "SET" 105 | <+> renderCommaSeparated renderUpdate columns 106 | <> case using of 107 | NoUsing -> "" 108 | Using tables -> " FROM" <+> renderSQL tables 109 | <+> "WHERE" <+> renderSQL wh 110 | <> renderSQL returning 111 | 112 | {- | Update a row returning `Nil`. 113 | 114 | >>> type Columns = '["col1" ::: 'Def :=> 'NotNull 'PGint4, "col2" ::: 'NoDef :=> 'NotNull 'PGint4] 115 | >>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)] 116 | >>> :{ 117 | let 118 | manp :: Manipulation with (Public Schema) '[] '[] 119 | manp = update_ #tab (Set 2 `as` #col1) (#col1 ./= #col2) 120 | in printSQL manp 121 | :} 122 | UPDATE "tab" AS "tab" SET "col1" = (2 :: int4) WHERE ("col1" <> "col2") 123 | -} 124 | update_ 125 | :: ( Has sch db schema 126 | , Has tab0 schema ('Table table) 127 | , KnownSymbol tab 128 | , Updatable table updates ) 129 | => Aliased (QualifiedAlias sch) (tab ::: tab0) -- ^ table to update 130 | -> NP (Aliased (Optional (Expression 'Ungrouped '[] with db params '[tab ::: TableToRow table]))) updates 131 | -- ^ modified values to replace old values 132 | -> Condition 'Ungrouped '[] with db params '[tab ::: TableToRow table] 133 | -- ^ condition under which to perform update on a row 134 | -> Manipulation with db params '[] 135 | update_ tab columns wh = update tab columns NoUsing wh (Returning_ Nil) 136 | -------------------------------------------------------------------------------- /squeal-postgresql/src/Squeal/PostgreSQL/Query/From.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module: Squeal.PostgreSQL.Query.From 3 | Description: from clauses 4 | Copyright: (c) Eitan Chatav, 2019 5 | Maintainer: eitan@morphism.tech 6 | Stability: experimental 7 | 8 | from clauses 9 | -} 10 | 11 | {-# LANGUAGE 12 | ConstraintKinds 13 | , DeriveGeneric 14 | , DerivingStrategies 15 | , FlexibleContexts 16 | , FlexibleInstances 17 | , GADTs 18 | , GeneralizedNewtypeDeriving 19 | , LambdaCase 20 | , MultiParamTypeClasses 21 | , OverloadedLabels 22 | , OverloadedStrings 23 | , QuantifiedConstraints 24 | , ScopedTypeVariables 25 | , StandaloneDeriving 26 | , TypeApplications 27 | , TypeFamilies 28 | , DataKinds 29 | , PolyKinds 30 | , TypeOperators 31 | , RankNTypes 32 | , UndecidableInstances 33 | #-} 34 | 35 | module Squeal.PostgreSQL.Query.From 36 | ( -- * From Clause 37 | FromClause (..) 38 | , table 39 | , subquery 40 | , view 41 | , common 42 | ) where 43 | 44 | import Control.DeepSeq 45 | import Data.ByteString (ByteString) 46 | 47 | import qualified GHC.Generics as GHC 48 | 49 | import Squeal.PostgreSQL.Type.Alias 50 | import Squeal.PostgreSQL.Query 51 | import Squeal.PostgreSQL.Render 52 | import Squeal.PostgreSQL.Type.List 53 | import Squeal.PostgreSQL.Type.Schema 54 | 55 | -- $setup 56 | -- >>> import Squeal.PostgreSQL 57 | 58 | {----------------------------------------- 59 | FROM clauses 60 | -----------------------------------------} 61 | 62 | {- | 63 | A `FromClause` can be a table name, or a derived table such 64 | as a subquery, a @JOIN@ construct, or complex combinations of these. 65 | -} 66 | newtype FromClause 67 | (lat :: FromType) 68 | (with :: FromType) 69 | (db :: SchemasType) 70 | (params :: [NullType]) 71 | (from :: FromType) 72 | = UnsafeFromClause { renderFromClause :: ByteString } 73 | deriving stock (GHC.Generic,Show,Eq,Ord) 74 | deriving newtype (NFData) 75 | instance RenderSQL (FromClause lat with db params from) where 76 | renderSQL = renderFromClause 77 | 78 | -- | A real `table` is a table from the database. 79 | table 80 | :: (Has sch db schema, Has tab schema ('Table table)) 81 | => Aliased (QualifiedAlias sch) (alias ::: tab) -- ^ (renamable) table alias 82 | -> FromClause lat with db params '[alias ::: TableToRow table] 83 | table (tab `As` alias) = UnsafeFromClause $ 84 | renderSQL tab <+> "AS" <+> renderSQL alias 85 | 86 | {- | `subquery` derives a table from a `Query`. 87 | The subquery may not reference columns provided by preceding `FromClause` items. 88 | Use `Squeal.PostgreSQL.Query.From.Join.JoinLateral` 89 | if the subquery must reference columns provided by preceding `FromClause` items. 90 | -} 91 | subquery 92 | :: Aliased (Query lat with db params) query 93 | -- ^ aliased `Query` 94 | -> FromClause lat with db params '[query] 95 | subquery = UnsafeFromClause . renderAliased (parenthesized . renderSQL) 96 | 97 | -- | `view` derives a table from a `View`. 98 | view 99 | :: (Has sch db schema, Has vw schema ('View view)) 100 | => Aliased (QualifiedAlias sch) (alias ::: vw) -- ^ (renamable) view alias 101 | -> FromClause lat with db params '[alias ::: view] 102 | view (vw `As` alias) = UnsafeFromClause $ 103 | renderSQL vw <+> "AS" <+> renderSQL alias 104 | 105 | -- | `common` derives a table from a common table expression. 106 | common 107 | :: Has cte with common 108 | => Aliased Alias (alias ::: cte) -- ^ (renamable) common table expression alias 109 | -> FromClause lat with db params '[alias ::: common] 110 | common (cte `As` alias) = UnsafeFromClause $ 111 | renderSQL cte <+> "AS" <+> renderSQL alias 112 | 113 | instance Additional (FromClause lat with db params) where 114 | also right left = UnsafeFromClause $ 115 | renderSQL left <> ", " <> renderSQL right 116 | -------------------------------------------------------------------------------- /squeal-postgresql/src/Squeal/PostgreSQL/Query/From/Set.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module: Squeal.PostgreSQL.Query.From.Set 3 | Description: set returning functions 4 | Copyright: (c) Eitan Chatav, 2019 5 | Maintainer: eitan@morphism.tech 6 | Stability: experimental 7 | 8 | set returning functions 9 | -} 10 | 11 | {-# LANGUAGE 12 | ConstraintKinds 13 | , DeriveGeneric 14 | , DerivingStrategies 15 | , FlexibleContexts 16 | , FlexibleInstances 17 | , GADTs 18 | , GeneralizedNewtypeDeriving 19 | , LambdaCase 20 | , MultiParamTypeClasses 21 | , OverloadedLabels 22 | , OverloadedStrings 23 | , QuantifiedConstraints 24 | , ScopedTypeVariables 25 | , StandaloneDeriving 26 | , TypeApplications 27 | , TypeFamilies 28 | , DataKinds 29 | , PolyKinds 30 | , TypeOperators 31 | , RankNTypes 32 | , UndecidableInstances 33 | #-} 34 | 35 | module Squeal.PostgreSQL.Query.From.Set 36 | ( -- * Set Functions 37 | type (-|->) 38 | , type (--|->) 39 | , SetFun 40 | , SetFunN 41 | , generateSeries 42 | , generateSeriesStep 43 | , generateSeriesTimestamp 44 | , unsafeSetFunction 45 | , setFunction 46 | , unsafeSetFunctionN 47 | , setFunctionN 48 | ) where 49 | 50 | import Data.ByteString (ByteString) 51 | import Generics.SOP hiding (from) 52 | import GHC.TypeLits 53 | 54 | import qualified Generics.SOP as SOP 55 | 56 | import Squeal.PostgreSQL.Type.Alias 57 | import Squeal.PostgreSQL.Expression 58 | import Squeal.PostgreSQL.Query.From 59 | import Squeal.PostgreSQL.Render 60 | import Squeal.PostgreSQL.Type.List 61 | import Squeal.PostgreSQL.Type.Schema 62 | 63 | {- | 64 | A @RankNType@ for set returning functions with 1 argument. 65 | -} 66 | type (-|->) arg set = forall db. SetFun db arg set 67 | 68 | {- | 69 | A @RankNType@ for set returning functions with multiple argument. 70 | -} 71 | type (--|->) arg set = forall db. SetFunN db arg set 72 | -- ^ output 73 | 74 | {- | 75 | Like `-|->` but depends on the schemas of the database 76 | -} 77 | type SetFun db arg row 78 | = forall lat with params 79 | . Expression 'Ungrouped lat with db params '[] arg 80 | -- ^ input 81 | -> FromClause lat with db params '[row] 82 | -- ^ output 83 | 84 | {- | 85 | Like `--|->` but depends on the schemas of the database 86 | -} 87 | type SetFunN db args set 88 | = forall lat with params 89 | . NP (Expression 'Ungrouped lat with db params '[]) args 90 | -- ^ input 91 | -> FromClause lat with db params '[set] 92 | -- ^ output 93 | 94 | -- $setup 95 | -- >>> import Squeal.PostgreSQL 96 | 97 | -- | Escape hatch for a set returning function of a single variable 98 | unsafeSetFunction 99 | :: forall fun ty row. KnownSymbol fun 100 | => ByteString 101 | -> ty -|-> (fun ::: row) -- ^ set returning function 102 | unsafeSetFunction fun x = UnsafeFromClause $ 103 | fun <> parenthesized (renderSQL x) 104 | 105 | {- | Call a user defined set returning function of a single variable 106 | 107 | >>> type Fn = '[ 'Null 'PGbool] :=> 'ReturnsTable '["ret" ::: 'NotNull 'PGnumeric] 108 | >>> type Schema = '["fn" ::: 'Function Fn] 109 | >>> :{ 110 | let 111 | fn :: SetFun (Public Schema) ('Null 'PGbool) ("fn" ::: '["ret" ::: 'NotNull 'PGnumeric]) 112 | fn = setFunction #fn 113 | in 114 | printSQL (fn true) 115 | :} 116 | "fn"(TRUE) 117 | -} 118 | setFunction 119 | :: ( Has sch db schema 120 | , Has fun schema ('Function ('[ty] :=> 'ReturnsTable row)) ) 121 | => QualifiedAlias sch fun -- ^ function alias 122 | -> SetFun db ty (fun ::: row) 123 | setFunction fun = unsafeSetFunction (renderSQL fun) 124 | 125 | {- | Escape hatch for a multivariable set returning function-} 126 | unsafeSetFunctionN 127 | :: forall fun tys row. (SOP.SListI tys, KnownSymbol fun) 128 | => ByteString 129 | -> tys --|-> (fun ::: row) -- ^ set returning function 130 | unsafeSetFunctionN fun xs = UnsafeFromClause $ 131 | fun <> parenthesized (renderCommaSeparated renderSQL xs) 132 | 133 | {- | Call a user defined multivariable set returning function 134 | 135 | >>> type Fn = '[ 'Null 'PGbool, 'Null 'PGtext] :=> 'ReturnsTable '["ret" ::: 'NotNull 'PGnumeric] 136 | >>> type Schema = '["fn" ::: 'Function Fn] 137 | >>> :{ 138 | let 139 | fn :: SetFunN (Public Schema) 140 | '[ 'Null 'PGbool, 'Null 'PGtext] 141 | ("fn" ::: '["ret" ::: 'NotNull 'PGnumeric]) 142 | fn = setFunctionN #fn 143 | in 144 | printSQL (fn (true *: "hi")) 145 | :} 146 | "fn"(TRUE, (E'hi' :: text)) 147 | -} 148 | setFunctionN 149 | :: ( Has sch db schema 150 | , Has fun schema ('Function (tys :=> 'ReturnsTable row)) 151 | , SOP.SListI tys ) 152 | => QualifiedAlias sch fun -- ^ function alias 153 | -> SetFunN db tys (fun ::: row) 154 | setFunctionN fun = unsafeSetFunctionN (renderSQL fun) 155 | 156 | {- | @generateSeries (start :* stop)@ 157 | 158 | Generate a series of values, 159 | from @start@ to @stop@ with a step size of one 160 | 161 | >>> printSQL (generateSeries @'PGint4 (1 *: 10)) 162 | generate_series((1 :: int4), (10 :: int4)) 163 | -} 164 | generateSeries 165 | :: ty `In` '[ 'PGint4, 'PGint8, 'PGnumeric] 166 | => '[ null ty, null ty] --|-> 167 | ("generate_series" ::: '["generate_series" ::: null ty]) 168 | -- ^ set returning function 169 | generateSeries = unsafeSetFunctionN "generate_series" 170 | 171 | {- | @generateSeriesStep (start :* stop *: step)@ 172 | 173 | Generate a series of values, 174 | from @start@ to @stop@ with a step size of @step@ 175 | 176 | >>> printSQL (generateSeriesStep @'PGint8 (2 :* 100 *: 2)) 177 | generate_series((2 :: int8), (100 :: int8), (2 :: int8)) 178 | -} 179 | generateSeriesStep 180 | :: ty `In` '[ 'PGint4, 'PGint8, 'PGnumeric] 181 | => '[null ty, null ty, null ty] --|-> 182 | ("generate_series" ::: '["generate_series" ::: null ty]) 183 | -- ^ set returning function 184 | generateSeriesStep = unsafeSetFunctionN "generate_series" 185 | 186 | {- | @generateSeriesTimestamp (start :* stop *: step)@ 187 | 188 | Generate a series of timestamps, 189 | from @start@ to @stop@ with a step size of @step@ 190 | 191 | >>> :{ 192 | let 193 | start = now 194 | stop = now !+ interval_ 10 Years 195 | step = interval_ 1 Months 196 | in printSQL (generateSeriesTimestamp (start :* stop *: step)) 197 | :} 198 | generate_series(now(), (now() + (INTERVAL '10.000 years')), (INTERVAL '1.000 months')) 199 | -} 200 | generateSeriesTimestamp 201 | :: ty `In` '[ 'PGtimestamp, 'PGtimestamptz] 202 | => '[null ty, null ty, null 'PGinterval] --|-> 203 | ("generate_series" ::: '["generate_series" ::: null ty]) 204 | -- ^ set returning function 205 | generateSeriesTimestamp = unsafeSetFunctionN "generate_series" 206 | -------------------------------------------------------------------------------- /squeal-postgresql/src/Squeal/PostgreSQL/Query/Values.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module: Squeal.PostgreSQL.Query.Values 3 | Description: values statements 4 | Copyright: (c) Eitan Chatav, 2019 5 | Maintainer: eitan@morphism.tech 6 | Stability: experimental 7 | 8 | values statements 9 | -} 10 | 11 | {-# LANGUAGE 12 | ConstraintKinds 13 | , DeriveGeneric 14 | , DerivingStrategies 15 | , FlexibleContexts 16 | , FlexibleInstances 17 | , GADTs 18 | , GeneralizedNewtypeDeriving 19 | , LambdaCase 20 | , MultiParamTypeClasses 21 | , OverloadedLabels 22 | , OverloadedStrings 23 | , QuantifiedConstraints 24 | , ScopedTypeVariables 25 | , StandaloneDeriving 26 | , TypeApplications 27 | , TypeFamilies 28 | , DataKinds 29 | , PolyKinds 30 | , TypeOperators 31 | , RankNTypes 32 | , UndecidableInstances 33 | #-} 34 | 35 | module Squeal.PostgreSQL.Query.Values 36 | ( -- ** Values 37 | values 38 | , values_ 39 | ) where 40 | 41 | import Data.ByteString (ByteString) 42 | import Generics.SOP hiding (from) 43 | 44 | import Squeal.PostgreSQL.Type.Alias 45 | import Squeal.PostgreSQL.Expression 46 | import Squeal.PostgreSQL.Query 47 | import Squeal.PostgreSQL.Render 48 | 49 | -- $setup 50 | -- >>> import Squeal.PostgreSQL 51 | 52 | -- | `values` computes a row value or set of row values 53 | -- specified by value expressions. It is most commonly used 54 | -- to generate a “constant table” within a larger command, 55 | -- but it can be used on its own. 56 | -- 57 | -- >>> type Row = '["a" ::: 'NotNull 'PGint4, "b" ::: 'NotNull 'PGtext] 58 | -- >>> let query = values (1 `as` #a :* "one" `as` #b) [] :: Query lat with db '[] Row 59 | -- >>> printSQL query 60 | -- SELECT * FROM (VALUES ((1 :: int4), (E'one' :: text))) AS t ("a", "b") 61 | values 62 | :: SListI cols 63 | => NP (Aliased (Expression 'Ungrouped lat with db params '[] )) cols 64 | -> [NP (Aliased (Expression 'Ungrouped lat with db params '[] )) cols] 65 | -- ^ When more than one row is specified, all the rows must 66 | -- must have the same number of elements 67 | -> Query lat with db params cols 68 | values rw rws = UnsafeQuery $ "SELECT * FROM" 69 | <+> parenthesized ( 70 | "VALUES" 71 | <+> commaSeparated 72 | ( parenthesized 73 | . renderCommaSeparated renderValuePart <$> rw:rws ) 74 | ) <+> "AS t" 75 | <+> parenthesized (renderCommaSeparated renderAliasPart rw) 76 | where 77 | renderAliasPart, renderValuePart 78 | :: Aliased (Expression 'Ungrouped lat with db params '[] ) ty -> ByteString 79 | renderAliasPart (_ `As` name) = renderSQL name 80 | renderValuePart (value `As` _) = renderSQL value 81 | 82 | -- | `values_` computes a row value or set of row values 83 | -- specified by value expressions. 84 | values_ 85 | :: SListI cols 86 | => NP (Aliased (Expression 'Ungrouped lat with db params '[] )) cols 87 | -- ^ one row of values 88 | -> Query lat with db params cols 89 | values_ rw = values rw [] 90 | -------------------------------------------------------------------------------- /squeal-postgresql/src/Squeal/PostgreSQL/Render.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module: Squeal.PostgreSQL.Render 3 | Description: render functions 4 | Copyright: (c) Eitan Chatav, 2019 5 | Maintainer: eitan@morphism.tech 6 | Stability: experimental 7 | 8 | render functions 9 | -} 10 | 11 | {-# LANGUAGE 12 | AllowAmbiguousTypes 13 | , ConstraintKinds 14 | , FlexibleContexts 15 | , LambdaCase 16 | , MagicHash 17 | , OverloadedStrings 18 | , PolyKinds 19 | , RankNTypes 20 | , ScopedTypeVariables 21 | , TypeApplications 22 | #-} 23 | 24 | module Squeal.PostgreSQL.Render 25 | ( -- * Render 26 | RenderSQL (..) 27 | , printSQL 28 | , escape 29 | , parenthesized 30 | , bracketed 31 | , (<+>) 32 | , commaSeparated 33 | , doubleQuoted 34 | , singleQuotedText 35 | , singleQuotedUtf8 36 | , escapeQuotedString 37 | , escapeQuotedText 38 | , renderCommaSeparated 39 | , renderCommaSeparatedConstraint 40 | , renderCommaSeparatedMaybe 41 | , renderNat 42 | , renderSymbol 43 | ) where 44 | 45 | import Control.Monad.IO.Class (MonadIO (..)) 46 | import Data.ByteString (ByteString) 47 | import Data.Maybe (catMaybes) 48 | import Data.Text (Text) 49 | import Generics.SOP 50 | import GHC.Exts 51 | import GHC.TypeLits hiding (Text) 52 | 53 | import qualified Data.Text as Text 54 | import qualified Data.Text.Encoding as Text 55 | import qualified Data.ByteString as ByteString 56 | import qualified Data.ByteString.Char8 as Char8 57 | 58 | -- | Parenthesize a `ByteString`. 59 | parenthesized :: ByteString -> ByteString 60 | parenthesized str = "(" <> str <> ")" 61 | 62 | -- | Square bracket a `ByteString` 63 | bracketed :: ByteString -> ByteString 64 | bracketed str = "[" <> str <> "]" 65 | 66 | -- | Concatenate two `ByteString`s with a space between. 67 | (<+>) :: ByteString -> ByteString -> ByteString 68 | infixr 7 <+> 69 | str1 <+> str2 = str1 <> " " <> str2 70 | 71 | -- | Comma separate a list of `ByteString`s. 72 | commaSeparated :: [ByteString] -> ByteString 73 | commaSeparated = ByteString.intercalate ", " 74 | 75 | -- | Add double quotes around a `ByteString`. 76 | doubleQuoted :: ByteString -> ByteString 77 | doubleQuoted str = "\"" <> str <> "\"" 78 | 79 | -- | Add single quotes around a `Text` and escape single quotes within it. 80 | singleQuotedText :: Text -> ByteString 81 | singleQuotedText str = 82 | "'" <> Text.encodeUtf8 (Text.replace "'" "''" str) <> "'" 83 | 84 | -- | Add single quotes around a `ByteString` and escape single quotes within it. 85 | singleQuotedUtf8 :: ByteString -> ByteString 86 | singleQuotedUtf8 = singleQuotedText . Text.decodeUtf8 87 | 88 | -- | Escape quote a string. 89 | escapeQuotedString :: String -> ByteString 90 | escapeQuotedString x = "E\'" <> Text.encodeUtf8 (fromString (escape =<< x)) <> "\'" 91 | 92 | -- | Escape quote a string. 93 | escapeQuotedText :: Text -> ByteString 94 | escapeQuotedText x = 95 | "E\'" <> Text.encodeUtf8 (Text.concatMap (fromString . escape) x) <> "\'" 96 | 97 | -- | Comma separate the renderings of a heterogeneous list. 98 | renderCommaSeparated 99 | :: SListI xs 100 | => (forall x. expression x -> ByteString) 101 | -> NP expression xs -> ByteString 102 | renderCommaSeparated render 103 | = commaSeparated 104 | . hcollapse 105 | . hmap (K . render) 106 | 107 | -- | Comma separate the renderings of a heterogeneous list. 108 | renderCommaSeparatedConstraint 109 | :: forall c xs expression. (All c xs, SListI xs) 110 | => (forall x. c x => expression x -> ByteString) 111 | -> NP expression xs -> ByteString 112 | renderCommaSeparatedConstraint render 113 | = commaSeparated 114 | . hcollapse 115 | . hcmap (Proxy @c) (K . render) 116 | 117 | -- | Comma separate the `Maybe` renderings of a heterogeneous list, dropping 118 | -- `Nothing`s. 119 | renderCommaSeparatedMaybe 120 | :: SListI xs 121 | => (forall x. expression x -> Maybe ByteString) 122 | -> NP expression xs -> ByteString 123 | renderCommaSeparatedMaybe render 124 | = commaSeparated 125 | . catMaybes 126 | . hcollapse 127 | . hmap (K . render) 128 | 129 | -- | Render a promoted `Nat`. 130 | renderNat :: forall n. KnownNat n => ByteString 131 | renderNat = fromString (show (natVal' (proxy# :: Proxy# n))) 132 | 133 | -- | Render a promoted `Symbol`. 134 | renderSymbol :: forall s. KnownSymbol s => ByteString 135 | renderSymbol = fromString (symbolVal' (proxy# :: Proxy# s)) 136 | 137 | -- | A class for rendering SQL 138 | class RenderSQL sql where renderSQL :: sql -> ByteString 139 | 140 | -- | Print SQL. 141 | printSQL :: (RenderSQL sql, MonadIO io) => sql -> io () 142 | printSQL = liftIO . Char8.putStrLn . renderSQL 143 | 144 | -- | `escape` a character to prevent injection 145 | escape :: Char -> String 146 | escape = \case 147 | '\NUL' -> "" 148 | '\'' -> "''" 149 | '"' -> "\\\"" 150 | '\b' -> "\\b" 151 | '\n' -> "\\n" 152 | '\r' -> "\\r" 153 | '\t' -> "\\t" 154 | '\\' -> "\\\\" 155 | c -> [c] 156 | -------------------------------------------------------------------------------- /squeal-postgresql/src/Squeal/PostgreSQL/Session/Connection.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module: Squeal.PostgreSQL.Session.Connection 3 | Description: database connections 4 | Copyright: (c) Eitan Chatav, 2019 5 | Maintainer: eitan@morphism.tech 6 | Stability: experimental 7 | 8 | database connections 9 | -} 10 | 11 | {-# LANGUAGE 12 | DataKinds 13 | , PolyKinds 14 | , RankNTypes 15 | , TypeOperators 16 | #-} 17 | 18 | module Squeal.PostgreSQL.Session.Connection 19 | ( LibPQ.Connection 20 | , connectdb 21 | , finish 22 | , lowerConnection 23 | , SOP.K (..) 24 | , SOP.unK 25 | ) where 26 | 27 | import Control.Monad.IO.Class 28 | import Data.ByteString (ByteString) 29 | 30 | import Squeal.PostgreSQL.Type.Schema 31 | 32 | import qualified Generics.SOP as SOP 33 | import qualified Database.PostgreSQL.LibPQ as LibPQ 34 | 35 | -- $setup 36 | -- >>> import Squeal.PostgreSQL 37 | 38 | {- | Makes a new connection to the database server. 39 | 40 | This function opens a new database connection using the parameters taken 41 | from the string conninfo. 42 | 43 | The passed string can be empty to use all default parameters, or it can 44 | contain one or more parameter settings separated by whitespace. 45 | Each parameter setting is in the form keyword = value. Spaces around the equal 46 | sign are optional. To write an empty value or a value containing spaces, 47 | surround it with single quotes, e.g., keyword = 'a value'. Single quotes and 48 | backslashes within the value must be escaped with a backslash, i.e., ' and \. 49 | 50 | To specify the schema you wish to connect with, use type application. 51 | 52 | >>> :set -XDataKinds 53 | >>> :set -XPolyKinds 54 | >>> :set -XTypeOperators 55 | >>> type DB = '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint2])]] 56 | >>> :set -XTypeApplications 57 | >>> :set -XOverloadedStrings 58 | >>> conn <- connectdb @DB "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" 59 | 60 | Note that, for now, squeal doesn't offer any protection from connecting 61 | with the wrong schema! 62 | -} 63 | connectdb 64 | :: forall (db :: SchemasType) io 65 | . MonadIO io 66 | => ByteString -- ^ conninfo 67 | -> io (SOP.K LibPQ.Connection db) 68 | connectdb = fmap SOP.K . liftIO . LibPQ.connectdb 69 | 70 | -- | Closes the connection to the server. 71 | finish :: MonadIO io => SOP.K LibPQ.Connection db -> io () 72 | finish = liftIO . LibPQ.finish . SOP.unK 73 | 74 | -- | Safely `lowerConnection` to a smaller schema. 75 | lowerConnection 76 | :: SOP.K LibPQ.Connection (schema ': db) 77 | -> SOP.K LibPQ.Connection db 78 | lowerConnection (SOP.K conn) = SOP.K conn 79 | -------------------------------------------------------------------------------- /squeal-postgresql/src/Squeal/PostgreSQL/Session/Exception.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module: Squeal.PostgreSQL.Session.Exception 3 | Description: exceptions 4 | Copyright: (c) Eitan Chatav, 2019 5 | Maintainer: eitan@morphism.tech 6 | Stability: experimental 7 | 8 | exceptions 9 | -} 10 | 11 | {-# LANGUAGE 12 | OverloadedStrings 13 | , PatternSynonyms 14 | #-} 15 | 16 | module Squeal.PostgreSQL.Session.Exception 17 | ( SquealException (..) 18 | , pattern UniqueViolation 19 | , pattern CheckViolation 20 | , pattern SerializationFailure 21 | , pattern DeadlockDetected 22 | , SQLState (..) 23 | , LibPQ.ExecStatus (..) 24 | , catchSqueal 25 | , handleSqueal 26 | , trySqueal 27 | , throwSqueal 28 | ) where 29 | 30 | import Control.Monad.Catch 31 | import Data.ByteString (ByteString) 32 | import Data.Text (Text) 33 | 34 | import qualified Database.PostgreSQL.LibPQ as LibPQ 35 | 36 | -- $setup 37 | -- >>> import Squeal.PostgreSQL 38 | 39 | -- | the state of LibPQ 40 | data SQLState = SQLState 41 | { sqlExecStatus :: LibPQ.ExecStatus 42 | , sqlStateCode :: ByteString 43 | -- ^ https://www.postgresql.org/docs/current/static/errcodes-appendix.html 44 | , sqlErrorMessage :: ByteString 45 | } deriving (Eq, Show) 46 | 47 | -- | `Exception`s that can be thrown by Squeal. 48 | data SquealException 49 | = SQLException SQLState 50 | -- ^ SQL exception state 51 | | ConnectionException Text 52 | -- ^ `Database.PostgreSQL.LibPQ` function connection exception 53 | | DecodingException Text Text 54 | -- ^ decoding exception function and error message 55 | | ColumnsException Text LibPQ.Column 56 | -- ^ unexpected number of columns 57 | | RowsException Text LibPQ.Row LibPQ.Row 58 | -- ^ too few rows, expected at least and actual number of rows 59 | deriving (Eq, Show) 60 | instance Exception SquealException 61 | 62 | -- | A pattern for unique violation exceptions. 63 | pattern UniqueViolation :: ByteString -> SquealException 64 | pattern UniqueViolation msg = 65 | SQLException (SQLState LibPQ.FatalError "23505" msg) 66 | -- | A pattern for check constraint violation exceptions. 67 | pattern CheckViolation :: ByteString -> SquealException 68 | pattern CheckViolation msg = 69 | SQLException (SQLState LibPQ.FatalError "23514" msg) 70 | -- | A pattern for serialization failure exceptions. 71 | pattern SerializationFailure :: ByteString -> SquealException 72 | pattern SerializationFailure msg = 73 | SQLException (SQLState LibPQ.FatalError "40001" msg) 74 | -- | A pattern for deadlock detection exceptions. 75 | pattern DeadlockDetected :: ByteString -> SquealException 76 | pattern DeadlockDetected msg = 77 | SQLException (SQLState LibPQ.FatalError "40P01" msg) 78 | 79 | -- | Catch `SquealException`s. 80 | catchSqueal 81 | :: MonadCatch m 82 | => m a 83 | -> (SquealException -> m a) -- ^ handler 84 | -> m a 85 | catchSqueal = catch 86 | 87 | -- | Handle `SquealException`s. 88 | handleSqueal 89 | :: MonadCatch m 90 | => (SquealException -> m a) -- ^ handler 91 | -> m a -> m a 92 | handleSqueal = handle 93 | 94 | -- | `Either` return a `SquealException` or a result. 95 | trySqueal :: MonadCatch m => m a -> m (Either SquealException a) 96 | trySqueal = try 97 | 98 | -- | Throw `SquealException`s. 99 | throwSqueal :: MonadThrow m => SquealException -> m a 100 | throwSqueal = throwM 101 | -------------------------------------------------------------------------------- /squeal-postgresql/src/Squeal/PostgreSQL/Session/Indexed.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module: Squeal.PostgreSQL.Session.Indexed 3 | Description: indexed session monad 4 | Copyright: (c) Eitan Chatav, 2019 5 | Maintainer: eitan@morphism.tech 6 | Stability: experimental 7 | 8 | `Squeal.PostgreSQL.Indexed` provides an indexed monad transformer 9 | class and a class extending it to run `Definition`s. 10 | -} 11 | 12 | {-# LANGUAGE 13 | DataKinds 14 | , DefaultSignatures 15 | , FlexibleContexts 16 | , FlexibleInstances 17 | , FunctionalDependencies 18 | , PolyKinds 19 | , MultiParamTypeClasses 20 | , QuantifiedConstraints 21 | , RankNTypes 22 | , TypeApplications 23 | , TypeFamilies 24 | , UndecidableInstances 25 | #-} 26 | 27 | module Squeal.PostgreSQL.Session.Indexed 28 | ( IndexedMonadTrans (..) 29 | , Indexed (..) 30 | , IndexedMonadTransPQ (..) 31 | , indexedDefine 32 | ) where 33 | 34 | import Control.Category (Category (..)) 35 | import Control.Monad 36 | import Control.Monad.IO.Class 37 | import Control.Monad.Trans 38 | import Data.Function ((&)) 39 | import Prelude hiding (id, (.)) 40 | 41 | import Squeal.PostgreSQL.Definition 42 | 43 | {- | An [Atkey indexed monad] 44 | (https://bentnib.org/paramnotions-jfp.pdf) 45 | is a `Functor` [enriched category] 46 | (https://ncatlab.org/nlab/show/enriched+category). 47 | An indexed monad transformer transforms a `Monad` into an indexed monad, 48 | and is a monad transformer when its source and target are the same, 49 | enabling use of standard @do@ notation for endo-index operations. 50 | -} 51 | class 52 | ( forall i j m. Monad m => Functor (t i j m) 53 | , forall i m. Monad m => Monad (t i i m) 54 | , forall i. MonadTrans (t i i) 55 | ) => IndexedMonadTrans t where 56 | 57 | {-# MINIMAL pqJoin | pqBind #-} 58 | 59 | -- | indexed analog of `<*>` 60 | pqAp 61 | :: Monad m 62 | => t i j m (x -> y) 63 | -> t j k m x 64 | -> t i k m y 65 | pqAp tf tx = pqBind (<$> tx) tf 66 | 67 | -- | indexed analog of `join` 68 | pqJoin 69 | :: Monad m 70 | => t i j m (t j k m y) 71 | -> t i k m y 72 | pqJoin t = t & pqBind id 73 | 74 | -- | indexed analog of `=<<` 75 | pqBind 76 | :: Monad m 77 | => (x -> t j k m y) 78 | -> t i j m x 79 | -> t i k m y 80 | pqBind f t = pqJoin (f <$> t) 81 | 82 | -- | indexed analog of flipped `>>` 83 | pqThen 84 | :: Monad m 85 | => t j k m y 86 | -> t i j m x 87 | -> t i k m y 88 | pqThen pq2 pq1 = pq1 & pqBind (\ _ -> pq2) 89 | 90 | -- | indexed analog of `<=<` 91 | pqAndThen 92 | :: Monad m 93 | => (y -> t j k m z) 94 | -> (x -> t i j m y) 95 | -> x -> t i k m z 96 | pqAndThen g f x = pqBind g (f x) 97 | 98 | {- | `Indexed` reshuffles the type parameters of an `IndexedMonadTrans`, 99 | exposing its `Category` instance.-} 100 | newtype Indexed t m r i j = Indexed {runIndexed :: t i j m r} 101 | instance 102 | ( IndexedMonadTrans t 103 | , Monad m 104 | , Monoid r 105 | ) => Category (Indexed t m r) where 106 | id = Indexed (pure mempty) 107 | Indexed g . Indexed f = Indexed $ pqAp (fmap (<>) f) g 108 | 109 | {- | `IndexedMonadTransPQ` is a class for indexed monad transformers 110 | that support running `Definition`s using `define` which acts functorially in effect. 111 | 112 | * @define id = return ()@ 113 | * @define (statement1 >>> statement2) = define statement1 & pqThen (define statement2)@ 114 | -} 115 | class IndexedMonadTrans pq => IndexedMonadTransPQ pq where 116 | define :: MonadIO io => Definition db0 db1 -> pq db0 db1 io () 117 | 118 | {- | Run a pure SQL `Definition` functorially in effect 119 | 120 | * @indexedDefine id = id@ 121 | * @indexedDefine (def1 >>> def2) = indexedDefine def1 >>> indexedDefine def2@ 122 | -} 123 | indexedDefine 124 | :: (IndexedMonadTransPQ pq, MonadIO io) 125 | => Definition db0 db1 -> Indexed pq io () db0 db1 126 | indexedDefine = Indexed . define 127 | -------------------------------------------------------------------------------- /squeal-postgresql/src/Squeal/PostgreSQL/Session/Pool.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module: Squeal.PostgreSQL.Pool 3 | Description: connection pools 4 | Copyright: (c) Eitan Chatav, 2019 5 | Maintainer: eitan@morphism.tech 6 | Stability: experimental 7 | 8 | Connection pools. 9 | 10 | Typical use case would be to create your pool using `createConnectionPool` 11 | and run anything that requires the pool connection with `usingConnectionPool`. 12 | 13 | Here's a simplified example: 14 | 15 | >>> import Squeal.PostgreSQL 16 | 17 | >>> :{ 18 | do 19 | let 20 | qry :: Query_ (Public '[]) () (Only Char) 21 | qry = values_ (inline 'a' `as` #fromOnly) 22 | pool <- createConnectionPool "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" 1 0.5 10 23 | chr <- usingConnectionPool pool $ do 24 | result <- runQuery qry 25 | Just (Only a) <- firstRow result 26 | return a 27 | destroyConnectionPool pool 28 | putChar chr 29 | :} 30 | a 31 | -} 32 | 33 | {-# LANGUAGE 34 | CPP 35 | , DeriveFunctor 36 | , FlexibleContexts 37 | , FlexibleInstances 38 | , InstanceSigs 39 | , MultiParamTypeClasses 40 | , PolyKinds 41 | , RankNTypes 42 | , ScopedTypeVariables 43 | , TypeFamilies 44 | , DataKinds 45 | , PolyKinds 46 | , UndecidableInstances 47 | #-} 48 | 49 | module Squeal.PostgreSQL.Session.Pool 50 | ( -- * Pool 51 | Pool 52 | , createConnectionPool 53 | , usingConnectionPool 54 | , destroyConnectionPool 55 | ) where 56 | 57 | import Control.Monad.Catch 58 | import Control.Monad.IO.Class 59 | import Data.ByteString 60 | import Data.Time 61 | import Data.Pool 62 | 63 | import Squeal.PostgreSQL.Type.Schema 64 | import Squeal.PostgreSQL.Session (PQ (..)) 65 | import Squeal.PostgreSQL.Session.Connection 66 | 67 | -- | Create a striped pool of connections. 68 | -- Although the garbage collector will destroy all idle connections when the pool is garbage collected it's recommended to manually `destroyConnectionPool` when you're done with the pool so that the connections are freed up as soon as possible. 69 | createConnectionPool 70 | :: forall (db :: SchemasType) io. MonadIO io 71 | => ByteString 72 | -- ^ The passed string can be empty to use all default parameters, or it can 73 | -- contain one or more parameter settings separated by whitespace. 74 | -- Each parameter setting is in the form keyword = value. Spaces around the equal 75 | -- sign are optional. To write an empty value or a value containing spaces, 76 | -- surround it with single quotes, e.g., keyword = 'a value'. Single quotes and 77 | -- backslashes within the value must be escaped with a backslash, i.e., ' and \. 78 | -> Int 79 | -- ^ The number of stripes (distinct sub-pools) to maintain. The smallest acceptable value is 1. 80 | -> NominalDiffTime 81 | -- ^ Amount of time for which an unused connection is kept open. The smallest acceptable value is 0.5 seconds. 82 | -- The elapsed time before destroying a connection may be a little longer than requested, as the reaper thread wakes at 1-second intervals. 83 | -> Int 84 | -- ^ Maximum number of connections to keep open per stripe. The smallest acceptable value is 1. 85 | -- Requests for connections will block if this limit is reached on a single stripe, even if other stripes have idle connections available. 86 | -> io (Pool (K Connection db)) 87 | createConnectionPool conninfo stripes idle maxResrc = 88 | #if MIN_VERSION_resource_pool(0,4,0) 89 | liftIO . newPool $ setNumStripes 90 | (Just stripes) 91 | (defaultPoolConfig (connectdb conninfo) finish (realToFrac idle) maxResrc) 92 | #else 93 | liftIO $ createPool (connectdb conninfo) finish stripes idle maxResrc 94 | #endif 95 | 96 | {-| 97 | Temporarily take a connection from a `Pool`, perform an action with it, 98 | and return it to the pool afterwards. 99 | 100 | If the pool has an idle connection available, it is used immediately. 101 | Otherwise, if the maximum number of connections has not yet been reached, 102 | a new connection is created and used. 103 | If the maximum number of connections has been reached, this function blocks 104 | until a connection becomes available. 105 | -} 106 | usingConnectionPool 107 | :: (MonadIO io, MonadMask io) 108 | => Pool (K Connection db) -- ^ pool 109 | -> PQ db db io x -- ^ session 110 | -> io x 111 | usingConnectionPool pool (PQ session) = mask $ \restore -> do 112 | (conn, local) <- liftIO $ takeResource pool 113 | ret <- restore (session conn) `onException` 114 | liftIO (destroyResource pool local conn) 115 | liftIO $ putResource local conn 116 | return $ unK ret 117 | 118 | {- | 119 | Destroy all connections in all stripes in the pool. 120 | Note that this will ignore any exceptions in the destroy function. 121 | 122 | This function is useful when you detect that all connections 123 | in the pool are broken. For example after a database has been 124 | restarted all connections opened before the restart will be broken. 125 | In that case it's better to close those connections so that 126 | `usingConnectionPool` won't take a broken connection from the pool 127 | but will open a new connection instead. 128 | 129 | Another use-case for this function is that when you know you are done 130 | with the pool you can destroy all idle connections immediately 131 | instead of waiting on the garbage collector to destroy them, 132 | thus freeing up those connections sooner. 133 | -} 134 | destroyConnectionPool 135 | :: MonadIO io 136 | => Pool (K Connection db) -- ^ pool 137 | -> io () 138 | destroyConnectionPool = liftIO . destroyAllResources 139 | -------------------------------------------------------------------------------- /squeal-postgresql/src/Squeal/PostgreSQL/Session/Result.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module: Squeal.PostgreSQL.Session.Result 3 | Description: results 4 | Copyright: (c) Eitan Chatav, 2019 5 | Maintainer: eitan@morphism.tech 6 | Stability: experimental 7 | 8 | Get values from a `Result`. 9 | -} 10 | 11 | {-# LANGUAGE 12 | FlexibleContexts 13 | , FlexibleInstances 14 | , GADTs 15 | , LambdaCase 16 | , OverloadedStrings 17 | , ScopedTypeVariables 18 | , TypeApplications 19 | , UndecidableInstances 20 | #-} 21 | 22 | module Squeal.PostgreSQL.Session.Result 23 | ( Result (..) 24 | , MonadResult (..) 25 | , liftResult 26 | , nextRow 27 | ) where 28 | 29 | import Control.Exception (throw) 30 | import Control.Monad (when, (<=<)) 31 | import Control.Monad.Catch 32 | import Control.Monad.IO.Class 33 | import Data.ByteString (ByteString) 34 | import Data.Text (Text) 35 | import Data.Traversable (for) 36 | import Text.Read (readMaybe) 37 | 38 | import qualified Data.ByteString as ByteString 39 | import qualified Data.ByteString.Char8 as Char8 40 | import qualified Data.Text.Encoding as Text 41 | import qualified Database.PostgreSQL.LibPQ as LibPQ 42 | import qualified Generics.SOP as SOP 43 | 44 | import Squeal.PostgreSQL.Session.Decode 45 | import Squeal.PostgreSQL.Session.Exception 46 | 47 | {- | `Result`s are generated by executing 48 | `Squeal.PostgreSQL.Session.Statement`s 49 | in a `Squeal.PostgreSQL.Session.Monad.MonadPQ`. 50 | 51 | They contain an underlying `LibPQ.Result` 52 | and a `DecodeRow`. 53 | -} 54 | data Result y where 55 | Result 56 | :: SOP.SListI row 57 | => DecodeRow row y 58 | -> LibPQ.Result 59 | -> Result y 60 | instance Functor Result where 61 | fmap f (Result decode result) = Result (fmap f decode) result 62 | 63 | {- | A `MonadResult` operation extracts values 64 | from the `Result` of a `Squeal.PostgreSQL.Session.Monad.MonadPQ` operation. 65 | There is no need to define instances of `MonadResult`. 66 | An instance of `MonadIO` implies an instance of `MonadResult`. 67 | However, the constraint `MonadResult` 68 | does not imply the constraint `MonadIO`. 69 | -} 70 | class Monad m => MonadResult m where 71 | -- | Get a row corresponding to a given row number from a `LibPQ.Result`, 72 | -- throwing an exception if the row number is out of bounds. 73 | getRow :: LibPQ.Row -> Result y -> m y 74 | -- | Get all rows from a `LibPQ.Result`. 75 | getRows :: Result y -> m [y] 76 | -- | Get the first row if possible from a `LibPQ.Result`. 77 | firstRow :: Result y -> m (Maybe y) 78 | -- | Returns the number of rows (tuples) in the query result. 79 | ntuples :: Result y -> m LibPQ.Row 80 | -- | Returns the number of columns (fields) in the query result. 81 | nfields :: Result y -> m LibPQ.Column 82 | {- | 83 | Returns the command status tag from the SQL command 84 | that generated the `Result`. 85 | Commonly this is just the name of the command, 86 | but it might include additional data such as the number of rows processed. 87 | -} 88 | cmdStatus :: Result y -> m Text 89 | {- | 90 | Returns the number of rows affected by the SQL command. 91 | This function returns `Just` the number of 92 | rows affected by the SQL statement that generated the `Result`. 93 | This function can only be used following the execution of a 94 | SELECT, CREATE TABLE AS, INSERT, UPDATE, DELETE, MOVE, FETCH, 95 | or COPY statement,or an EXECUTE of a prepared query that 96 | contains an INSERT, UPDATE, or DELETE statement. 97 | If the command that generated the PGresult was anything else, 98 | `cmdTuples` returns `Nothing`. 99 | -} 100 | cmdTuples :: Result y -> m (Maybe LibPQ.Row) 101 | -- | Returns the result status of the command. 102 | resultStatus :: Result y -> m LibPQ.ExecStatus 103 | -- | Check if a `Result`'s status is either `LibPQ.CommandOk` 104 | -- or `LibPQ.TuplesOk` otherwise `throw` a `SQLException`. 105 | okResult :: Result y -> m () 106 | -- | Returns the error message most recently generated by an operation 107 | -- on the connection. 108 | resultErrorMessage :: Result y -> m (Maybe ByteString) 109 | -- | Returns the error code most recently generated by an operation 110 | -- on the connection. 111 | -- 112 | -- https://www.postgresql.org/docs/current/static/errcodes-appendix.html 113 | resultErrorCode :: Result y -> m (Maybe ByteString) 114 | 115 | instance (Monad io, MonadIO io) => MonadResult io where 116 | getRow r (Result decode result) = liftIO $ do 117 | numRows <- LibPQ.ntuples result 118 | numCols <- LibPQ.nfields result 119 | when (numRows < r) $ throw $ RowsException "getRow" r numRows 120 | row' <- traverse (LibPQ.getvalue result r) [0 .. numCols - 1] 121 | case SOP.fromList row' of 122 | Nothing -> throw $ ColumnsException "getRow" numCols 123 | Just row -> case execDecodeRow decode row of 124 | Left parseError -> throw $ DecodingException "getRow" parseError 125 | Right y -> return y 126 | 127 | getRows (Result decode result) = liftIO $ do 128 | numCols <- LibPQ.nfields result 129 | numRows <- LibPQ.ntuples result 130 | for [0 .. numRows - 1] $ \ r -> do 131 | row' <- traverse (LibPQ.getvalue result r) [0 .. numCols - 1] 132 | case SOP.fromList row' of 133 | Nothing -> throw $ ColumnsException "getRows" numCols 134 | Just row -> case execDecodeRow decode row of 135 | Left parseError -> throw $ DecodingException "getRows" parseError 136 | Right y -> return y 137 | 138 | firstRow (Result decode result) = liftIO $ do 139 | numRows <- LibPQ.ntuples result 140 | numCols <- LibPQ.nfields result 141 | if numRows <= 0 then return Nothing else do 142 | row' <- traverse (LibPQ.getvalue result 0) [0 .. numCols - 1] 143 | case SOP.fromList row' of 144 | Nothing -> throw $ ColumnsException "firstRow" numCols 145 | Just row -> case execDecodeRow decode row of 146 | Left parseError -> throw $ DecodingException "firstRow" parseError 147 | Right y -> return $ Just y 148 | 149 | ntuples = liftResult LibPQ.ntuples 150 | 151 | nfields = liftResult LibPQ.nfields 152 | 153 | resultStatus = liftResult LibPQ.resultStatus 154 | 155 | cmdStatus = liftResult (getCmdStatus <=< LibPQ.cmdStatus) 156 | where 157 | getCmdStatus = \case 158 | Nothing -> throwM $ ConnectionException "LibPQ.cmdStatus" 159 | Just bytes -> return $ Text.decodeUtf8 bytes 160 | 161 | cmdTuples = liftResult (getCmdTuples <=< LibPQ.cmdTuples) 162 | where 163 | getCmdTuples = \case 164 | Nothing -> throwM $ ConnectionException "LibPQ.cmdTuples" 165 | Just bytes -> return $ 166 | if ByteString.null bytes 167 | then Nothing 168 | else fromInteger <$> readMaybe (Char8.unpack bytes) 169 | 170 | okResult = liftResult okResult_ 171 | 172 | resultErrorMessage = liftResult LibPQ.resultErrorMessage 173 | 174 | resultErrorCode = liftResult (flip LibPQ.resultErrorField LibPQ.DiagSqlstate) 175 | 176 | -- | Intended to be used for unfolding in streaming libraries, `nextRow` 177 | -- takes a total number of rows (which can be found with `ntuples`) 178 | -- and a `LibPQ.Result` and given a row number if it's too large returns `Nothing`, 179 | -- otherwise returning the row along with the next row number. 180 | nextRow 181 | :: MonadIO io 182 | => LibPQ.Row -- ^ total number of rows 183 | -> Result y -- ^ result 184 | -> LibPQ.Row -- ^ row number 185 | -> io (Maybe (LibPQ.Row, y)) 186 | nextRow total (Result decode result) r 187 | = liftIO $ if r >= total then return Nothing else do 188 | numCols <- LibPQ.nfields result 189 | row' <- traverse (LibPQ.getvalue result r) [0 .. numCols - 1] 190 | case SOP.fromList row' of 191 | Nothing -> throw $ ColumnsException "nextRow" numCols 192 | Just row -> case execDecodeRow decode row of 193 | Left parseError -> throw $ DecodingException "nextRow" parseError 194 | Right y -> return $ Just (r+1, y) 195 | 196 | okResult_ :: MonadIO io => LibPQ.Result -> io () 197 | okResult_ result = liftIO $ do 198 | status <- LibPQ.resultStatus result 199 | case status of 200 | LibPQ.CommandOk -> return () 201 | LibPQ.TuplesOk -> return () 202 | _ -> do 203 | stateCodeMaybe <- LibPQ.resultErrorField result LibPQ.DiagSqlstate 204 | case stateCodeMaybe of 205 | Nothing -> throw $ ConnectionException "LibPQ.resultErrorField" 206 | Just stateCode -> do 207 | msgMaybe <- LibPQ.resultErrorMessage result 208 | case msgMaybe of 209 | Nothing -> throw $ ConnectionException "LibPQ.resultErrorMessage" 210 | Just msg -> throw . SQLException $ SQLState status stateCode msg 211 | 212 | -- | Lifts actions on results from @LibPQ@. 213 | liftResult 214 | :: MonadIO io 215 | => (LibPQ.Result -> IO x) 216 | -> Result y -> io x 217 | liftResult f (Result _ result) = liftIO $ f result 218 | 219 | execDecodeRow 220 | :: DecodeRow row y 221 | -> SOP.NP (SOP.K (Maybe ByteString)) row 222 | -> Either Text y 223 | execDecodeRow decode = runDecodeRow decode 224 | -------------------------------------------------------------------------------- /squeal-postgresql/src/Squeal/PostgreSQL/Session/Statement.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module: Squeal.PostgreSQL.Session.Statement 3 | Description: statements 4 | Copyright: (c) Eitan Chatav, 2019 5 | Maintainer: eitan@morphism.tech 6 | Stability: experimental 7 | 8 | A top-level `Statement` type wraps a `Squeal.PostgreSQL.Query.Query` 9 | or `Squeal.PostgreSQL.Manipulation.Manipulation` 10 | together with an `EncodeParams` and a `DecodeRow`. 11 | -} 12 | 13 | {-# LANGUAGE 14 | DataKinds 15 | , DeriveFunctor 16 | , DeriveFoldable 17 | , DeriveGeneric 18 | , DeriveTraversable 19 | , FlexibleContexts 20 | , GADTs 21 | , RankNTypes 22 | #-} 23 | 24 | module Squeal.PostgreSQL.Session.Statement 25 | ( -- * Statement 26 | Statement (..) 27 | , query 28 | , manipulation 29 | -- * Prepared 30 | , Prepared (..) 31 | ) where 32 | 33 | import Control.Applicative 34 | import Control.Arrow 35 | import Control.Category 36 | import Control.Monad 37 | import Control.Monad.Fix 38 | import Data.Functor.Contravariant 39 | import Data.Profunctor 40 | import Data.Profunctor.Traversing 41 | import GHC.Generics 42 | import Prelude hiding ((.),id) 43 | 44 | import qualified Generics.SOP as SOP 45 | 46 | import Squeal.PostgreSQL.Manipulation 47 | import Squeal.PostgreSQL.Session.Decode 48 | import Squeal.PostgreSQL.Session.Encode 49 | import Squeal.PostgreSQL.Session.Oid 50 | import Squeal.PostgreSQL.Query 51 | import Squeal.PostgreSQL.Render hiding ((<+>)) 52 | 53 | -- | A `Statement` consists of a `Squeal.PostgreSQL.Statement.Manipulation` 54 | -- or a `Squeal.PostgreSQL.Session.Statement.Query` that can be run 55 | -- in a `Squeal.PostgreSQL.Session.Monad.MonadPQ`. 56 | data Statement db x y where 57 | -- | Constructor for a data manipulation language `Statement` 58 | Manipulation 59 | :: (SOP.All (OidOfNull db) params, SOP.SListI row) 60 | => EncodeParams db params x -- ^ encoding of parameters 61 | -> DecodeRow row y -- ^ decoding of returned rows 62 | -> Manipulation '[] db params row 63 | -- ^ `Squeal.PostgreSQL.Manipulation.Insert.insertInto`, 64 | -- `Squeal.PostgreSQL.Manipulation.Update.update`, 65 | -- or `Squeal.PostgreSQL.Manipulation.Delete.deleteFrom`, ... 66 | -> Statement db x y 67 | -- | Constructor for a structured query language `Statement` 68 | Query 69 | :: (SOP.All (OidOfNull db) params, SOP.SListI row) 70 | => EncodeParams db params x -- ^ encoding of parameters 71 | -> DecodeRow row y -- ^ decoding of returned rows 72 | -> Query '[] '[] db params row 73 | -- ^ `Squeal.PostgreSQL.Query.Select.select`, 74 | -- `Squeal.PostgreSQL.Query.Values.values`, ... 75 | -> Statement db x y 76 | 77 | instance Profunctor (Statement db) where 78 | lmap f (Manipulation encode decode q) = 79 | Manipulation (contramap f encode) decode q 80 | lmap f (Query encode decode q) = 81 | Query (contramap f encode) decode q 82 | rmap f (Manipulation encode decode q) = 83 | Manipulation encode (fmap f decode) q 84 | rmap f (Query encode decode q) = 85 | Query encode (fmap f decode) q 86 | dimap f g (Manipulation encode decode q) = 87 | Manipulation (contramap f encode) (fmap g decode) q 88 | dimap f g (Query encode decode q) = 89 | Query (contramap f encode) (fmap g decode) q 90 | 91 | instance Functor (Statement db x) where fmap = rmap 92 | 93 | instance RenderSQL (Statement db x y) where 94 | renderSQL (Manipulation _ _ q) = renderSQL q 95 | renderSQL (Query _ _ q) = renderSQL q 96 | 97 | -- | Smart constructor for a structured query language `Statement` 98 | query :: 99 | ( GenericParams db params x xs 100 | , GenericRow row y ys 101 | ) => Query '[] '[] db params row 102 | -- ^ `Squeal.PostgreSQL.Query.Select.select`, 103 | -- `Squeal.PostgreSQL.Query.Values.values`, ... 104 | -> Statement db x y 105 | query = Query genericParams genericRow 106 | 107 | -- | Smart constructor for a data manipulation language `Statement` 108 | manipulation :: 109 | ( GenericParams db params x xs 110 | , GenericRow row y ys 111 | ) => Manipulation '[] db params row 112 | -- ^ `Squeal.PostgreSQL.Manipulation.Insert.insertInto`, 113 | -- `Squeal.PostgreSQL.Manipulation.Update.update`, 114 | -- or `Squeal.PostgreSQL.Manipulation.Delete.deleteFrom`, ... 115 | -> Statement db x y 116 | manipulation = Manipulation genericParams genericRow 117 | 118 | {- | 119 | `Squeal.PostgreSQL.Session.Monad.prepare` and 120 | `Squeal.PostgreSQL.Session.Monad.prepare_` create a `Prepared` statement. 121 | A `Prepared` statement is a server-side object 122 | that can be used to optimize performance. 123 | When `Squeal.PostgreSQL.Session.Monad.prepare` 124 | or `Squeal.PostgreSQL.Session.Monad.prepare_` is executed, 125 | the specified `Statement` is parsed, analyzed, and rewritten. 126 | 127 | When the `runPrepared` command is subsequently issued, 128 | the `Prepared` statement is planned and executed. 129 | This division of labor avoids repetitive parse analysis work, 130 | while allowing the execution plan to 131 | depend on the specific parameter values supplied. 132 | 133 | `Prepared` statements only last for the duration 134 | of the current database session. 135 | `Prepared` statements can be manually cleaned up 136 | using the `deallocate` command. 137 | -} 138 | data Prepared m x y = Prepared 139 | { runPrepared :: x -> m y -- ^ execute a prepared statement 140 | , deallocate :: m () -- ^ manually clean up a prepared statement 141 | } deriving (Functor, Generic, Generic1) 142 | 143 | instance Applicative m => Applicative (Prepared m x) where 144 | pure a = Prepared (\_ -> pure a) (pure ()) 145 | p1 <*> p2 = Prepared 146 | (run2 (<*>) p1 p2) 147 | (deallocate p1 *> deallocate p2) 148 | 149 | instance Alternative m => Alternative (Prepared m x) where 150 | empty = Prepared (runKleisli empty) empty 151 | p1 <|> p2 = Prepared 152 | (run2 (<|>) p1 p2) 153 | (deallocate p1 *> deallocate p2) 154 | 155 | instance Functor m => Profunctor (Prepared m) where 156 | dimap g f prepared = Prepared 157 | (fmap f . runPrepared prepared . g) 158 | (deallocate prepared) 159 | 160 | instance Monad m => Strong (Prepared m) where 161 | first' p = Prepared (run1 first' p) (deallocate p) 162 | second' p = Prepared (run1 second' p) (deallocate p) 163 | 164 | instance Monad m => Choice (Prepared m) where 165 | left' p = Prepared (run1 left' p) (deallocate p) 166 | right' p = Prepared (run1 right' p) (deallocate p) 167 | 168 | instance MonadFix m => Costrong (Prepared m) where 169 | unfirst p = Prepared (run1 unfirst p) (deallocate p) 170 | unsecond p = Prepared (run1 unsecond p) (deallocate p) 171 | 172 | instance Monad m => Category (Prepared m) where 173 | id = Prepared return (return ()) 174 | cd . ab = Prepared 175 | (runPrepared ab >=> runPrepared cd) 176 | (deallocate ab >> deallocate cd) 177 | 178 | instance Monad m => Arrow (Prepared m) where 179 | arr ab = Prepared (return . ab) (return ()) 180 | first = first' 181 | second = second' 182 | ab *** cd = first ab >>> second cd 183 | ab &&& ac = Prepared 184 | (run2 (&&&) ab ac) 185 | (deallocate ab >> deallocate ac) 186 | 187 | instance Monad m => ArrowChoice (Prepared m) where 188 | left = left' 189 | right = right' 190 | ab +++ cd = left ab >>> right cd 191 | bd ||| cd = Prepared 192 | (run2 (|||) bd cd) 193 | (deallocate bd >> deallocate cd) 194 | 195 | instance MonadFix m => ArrowLoop (Prepared m) where 196 | loop p = Prepared (run1 loop p) (deallocate p) 197 | 198 | instance MonadPlus m => ArrowZero (Prepared m) where 199 | zeroArrow = Prepared (runKleisli zeroArrow) (return ()) 200 | 201 | instance MonadPlus m => ArrowPlus (Prepared m) where 202 | p1 <+> p2 = Prepared 203 | (run2 (<+>) p1 p2) 204 | (deallocate p1 >> deallocate p2) 205 | 206 | instance Monad m => Traversing (Prepared m) where 207 | traverse' p = Prepared (run1 traverse' p) (deallocate p) 208 | 209 | -- helper functions 210 | 211 | run1 212 | :: (Kleisli m a b -> Kleisli m c d) 213 | -> Prepared m a b -> c -> m d 214 | run1 m = runKleisli . m . Kleisli . runPrepared 215 | 216 | run2 217 | :: (Kleisli m a b -> Kleisli m c d -> Kleisli m e f) 218 | -> Prepared m a b -> Prepared m c d -> e -> m f 219 | run2 (?) p1 p2 = runKleisli $ 220 | Kleisli (runPrepared p1) ? Kleisli (runPrepared p2) 221 | -------------------------------------------------------------------------------- /squeal-postgresql/src/Squeal/PostgreSQL/Session/Transaction.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module: Squeal.PostgreSQL.Session.Transaction 3 | Description: transaction control language 4 | Copyright: (c) Eitan Chatav, 2019 5 | Maintainer: eitan@morphism.tech 6 | Stability: experimental 7 | 8 | transaction control language 9 | -} 10 | 11 | {-# LANGUAGE 12 | MonoLocalBinds 13 | , RankNTypes 14 | #-} 15 | 16 | module Squeal.PostgreSQL.Session.Transaction 17 | ( -- * Transaction 18 | Transaction 19 | , transactionally 20 | , transactionally_ 21 | , transactionallyRetry 22 | , transactionallyRetry_ 23 | , ephemerally 24 | , ephemerally_ 25 | , withSavepoint 26 | -- * Transaction Mode 27 | , TransactionMode (..) 28 | , defaultMode 29 | , longRunningMode 30 | , retryMode 31 | , IsolationLevel (..) 32 | , AccessMode (..) 33 | , DeferrableMode (..) 34 | ) where 35 | 36 | import Control.Monad.Catch 37 | import Data.ByteString 38 | 39 | import Squeal.PostgreSQL.Session.Monad 40 | import Squeal.PostgreSQL.Session.Result 41 | import Squeal.PostgreSQL.Session.Transaction.Unsafe 42 | ( TransactionMode (..) 43 | , defaultMode 44 | , longRunningMode 45 | , retryMode 46 | , IsolationLevel (..) 47 | , AccessMode (..) 48 | , DeferrableMode (..) 49 | ) 50 | import qualified Squeal.PostgreSQL.Session.Transaction.Unsafe as Unsafe 51 | 52 | {- | A type of "safe" `Transaction`s, 53 | do-blocks that permit only 54 | database operations, pure functions, and synchronous exception handling 55 | forbidding arbitrary `IO` operations. 56 | 57 | To permit arbitrary `IO`, 58 | 59 | >>> import qualified Squeal.PostgreSQL.Session.Transaction.Unsafe as Unsafe 60 | 61 | Then use the @Unsafe@ qualified form of the functions below. 62 | 63 | A safe `Transaction` can be run in two ways, 64 | 65 | 1) it can be run directly in `IO` because as a 66 | universally quantified type, 67 | @Transaction db x@ permits interpretation in "subtypes" like 68 | @(MonadPQ db m, MonadIO m, MonadCatch m) => m x@ 69 | or 70 | @PQ db db IO x@ 71 | 72 | 2) it can be run in a transaction block, using 73 | `transactionally`, `ephemerally`, 74 | or `transactionallyRetry` 75 | -} 76 | type Transaction db x = forall m. 77 | ( MonadPQ db m 78 | , MonadResult m 79 | , MonadCatch m 80 | ) => m x 81 | 82 | {- | Run a computation `transactionally`; 83 | first `Unsafe.begin`, 84 | then run the computation, 85 | `onException` `Unsafe.rollback` and rethrow the exception, 86 | otherwise `Unsafe.commit` and `return` the result. 87 | -} 88 | transactionally 89 | :: (MonadMask tx, MonadResult tx, MonadPQ db tx) 90 | => TransactionMode 91 | -> Transaction db x -- ^ run inside a transaction 92 | -> tx x 93 | transactionally mode tx = Unsafe.transactionally mode tx 94 | 95 | -- | Run a computation `transactionally_`, in `defaultMode`. 96 | transactionally_ 97 | :: (MonadMask tx, MonadResult tx, MonadPQ db tx) 98 | => Transaction db x -- ^ run inside a transaction 99 | -> tx x 100 | transactionally_ tx = Unsafe.transactionally_ tx 101 | 102 | {- | 103 | `transactionallyRetry` a computation; 104 | 105 | * first `Unsafe.begin`, 106 | * then `try` the computation, 107 | - if it raises a serialization failure or deadloack detection, 108 | then `Unsafe.rollback` and restart the transaction, 109 | - if it raises any other exception then `Unsafe.rollback` and rethrow the exception, 110 | - otherwise `Unsafe.commit` and `return` the result. 111 | -} 112 | transactionallyRetry 113 | :: (MonadMask tx, MonadResult tx, MonadPQ db tx) 114 | => TransactionMode 115 | -> Transaction db x -- ^ run inside a transaction 116 | -> tx x 117 | transactionallyRetry mode tx = Unsafe.transactionallyRetry mode tx 118 | 119 | {- | `transactionallyRetry` in `retryMode`. -} 120 | transactionallyRetry_ 121 | :: (MonadMask tx, MonadResult tx, MonadPQ db tx) 122 | => Transaction db x -- ^ run inside a transaction 123 | -> tx x 124 | transactionallyRetry_ tx = Unsafe.transactionallyRetry_ tx 125 | 126 | {- | Run a computation `ephemerally`; 127 | Like `transactionally` but always `Unsafe.rollback`, useful in testing. 128 | -} 129 | ephemerally 130 | :: (MonadMask tx, MonadResult tx, MonadPQ db tx) 131 | => TransactionMode 132 | -> Transaction db x -- ^ run inside an ephemeral transaction 133 | -> tx x 134 | ephemerally mode tx = Unsafe.ephemerally mode tx 135 | 136 | {- | Run a computation `ephemerally` in `defaultMode`. -} 137 | ephemerally_ 138 | :: (MonadMask tx, MonadResult tx, MonadPQ db tx) 139 | => Transaction db x -- ^ run inside an ephemeral transaction 140 | -> tx x 141 | ephemerally_ tx = Unsafe.ephemerally_ tx 142 | 143 | {- | `withSavepoint`, used in a transaction block, 144 | allows a form of nested transactions, 145 | creating a savepoint, then running a transaction, 146 | rolling back to the savepoint if it returned `Left`, 147 | then releasing the savepoint and returning transaction's result. 148 | 149 | Make sure to run `withSavepoint` in a transaction block, 150 | not directly or you will provoke a SQL exception. 151 | -} 152 | withSavepoint 153 | :: ByteString -- ^ savepoint name 154 | -> Transaction db (Either e x) 155 | -> Transaction db (Either e x) 156 | withSavepoint sv tx = Unsafe.withSavepoint sv tx 157 | -------------------------------------------------------------------------------- /squeal-postgresql/src/Squeal/PostgreSQL/Type.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module: Squeal.PostgreSQL.Type 3 | Description: types 4 | Copyright: (c) Eitan Chatav, 2010 5 | Maintainer: eitan@morphism.tech 6 | Stability: experimental 7 | 8 | storage newtypes 9 | -} 10 | {-# LANGUAGE 11 | AllowAmbiguousTypes 12 | , DeriveAnyClass 13 | , DeriveFoldable 14 | , DeriveFunctor 15 | , DeriveGeneric 16 | , DeriveTraversable 17 | , DerivingStrategies 18 | , DefaultSignatures 19 | , FlexibleContexts 20 | , FlexibleInstances 21 | , FunctionalDependencies 22 | , GADTs 23 | , LambdaCase 24 | , MultiParamTypeClasses 25 | , OverloadedStrings 26 | , ScopedTypeVariables 27 | , TypeApplications 28 | , TypeFamilies 29 | , DataKinds 30 | , PolyKinds 31 | , TypeOperators 32 | , UndecidableInstances 33 | , UndecidableSuperClasses 34 | #-} 35 | 36 | module Squeal.PostgreSQL.Type 37 | ( -- * Storage newtypes 38 | Money (..) 39 | , Json (..) 40 | , Jsonb (..) 41 | , Composite (..) 42 | , Enumerated (..) 43 | , VarArray (..) 44 | , FixArray (..) 45 | , VarChar, varChar, getVarChar 46 | , FixChar, fixChar, getFixChar 47 | , Only (..) 48 | ) where 49 | 50 | import Data.Proxy 51 | import Data.Int (Int64) 52 | import GHC.TypeLits 53 | 54 | import qualified Data.Text as Strict (Text) 55 | import qualified Data.Text as Strict.Text 56 | import qualified GHC.Generics as GHC 57 | import qualified Generics.SOP as SOP 58 | 59 | -- $setup 60 | -- >>> import Squeal.PostgreSQL 61 | 62 | {- | The `Money` newtype stores a monetary value in terms 63 | of the number of cents, i.e. @$2,000.20@ would be expressed as 64 | @Money { cents = 200020 }@. 65 | 66 | >>> :kind! PG Money 67 | PG Money :: PGType 68 | = 'PGmoney 69 | -} 70 | newtype Money = Money { cents :: Int64 } 71 | deriving stock (Eq, Ord, Show, Read, GHC.Generic) 72 | deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic) 73 | 74 | {- | The `Json` newtype is an indication that the Haskell 75 | type it's applied to should be stored as a 76 | `Squeal.PostgreSQL.Type.Schema.PGjson`. 77 | 78 | >>> :kind! PG (Json [String]) 79 | PG (Json [String]) :: PGType 80 | = 'PGjson 81 | -} 82 | newtype Json hask = Json {getJson :: hask} 83 | deriving stock (Eq, Ord, Show, Read, GHC.Generic) 84 | deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic) 85 | 86 | {- | The `Jsonb` newtype is an indication that the Haskell 87 | type it's applied to should be stored as a 88 | `Squeal.PostgreSQL.Type.Schema.PGjsonb`. 89 | 90 | >>> :kind! PG (Jsonb [String]) 91 | PG (Jsonb [String]) :: PGType 92 | = 'PGjsonb 93 | -} 94 | newtype Jsonb hask = Jsonb {getJsonb :: hask} 95 | deriving stock (Eq, Ord, Show, Read, GHC.Generic) 96 | deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic) 97 | 98 | {- | The `Composite` newtype is an indication that the Haskell 99 | type it's applied to should be stored as a 100 | `Squeal.PostgreSQL.Type.Schema.PGcomposite`. 101 | 102 | >>> :{ 103 | data Complex = Complex 104 | { real :: Double 105 | , imaginary :: Double 106 | } deriving stock GHC.Generic 107 | deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) 108 | :} 109 | 110 | >>> :kind! PG (Composite Complex) 111 | PG (Composite Complex) :: PGType 112 | = 'PGcomposite 113 | '["real" ::: 'NotNull 'PGfloat8, 114 | "imaginary" ::: 'NotNull 'PGfloat8] 115 | -} 116 | newtype Composite record = Composite {getComposite :: record} 117 | deriving stock (Eq, Ord, Show, Read, GHC.Generic) 118 | deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic) 119 | 120 | {- | The `Enumerated` newtype is an indication that the Haskell 121 | type it's applied to should be stored as a 122 | `Squeal.PostgreSQL.Type.Schema.PGenum`. 123 | 124 | >>> :kind! PG (Enumerated Ordering) 125 | PG (Enumerated Ordering) :: PGType 126 | = 'PGenum '["LT", "EQ", "GT"] 127 | -} 128 | newtype Enumerated enum = Enumerated {getEnumerated :: enum} 129 | deriving stock (Eq, Ord, Show, Read, GHC.Generic) 130 | deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic) 131 | 132 | {- | The `VarArray` newtype is an indication that the Haskell 133 | type it's applied to should be stored as a 134 | `Squeal.PostgreSQL.Type.Schema.PGvararray`. 135 | 136 | >>> import Data.Vector 137 | >>> :kind! PG (VarArray (Vector Double)) 138 | PG (VarArray (Vector Double)) :: PGType 139 | = 'PGvararray ('NotNull 'PGfloat8) 140 | -} 141 | newtype VarArray arr 142 | = VarArray {getVarArray :: arr} 143 | deriving stock (Eq, Ord, Show, Read, GHC.Generic) 144 | deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic) 145 | 146 | {- | The `FixArray` newtype is an indication that the Haskell 147 | type it's applied to should be stored as a 148 | `Squeal.PostgreSQL.Type.Schema.PGfixarray`. 149 | 150 | >>> :kind! PG (FixArray ((Double, Double), (Double, Double))) 151 | PG (FixArray ((Double, Double), (Double, Double))) :: PGType 152 | = 'PGfixarray '[2, 2] ('NotNull 'PGfloat8) 153 | -} 154 | newtype FixArray arr = FixArray {getFixArray :: arr} 155 | deriving stock (Eq, Ord, Show, Read, GHC.Generic) 156 | deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic) 157 | 158 | -- | `Only` is a 1-tuple type, useful for encoding or decoding a singleton 159 | newtype Only x = Only { fromOnly :: x } 160 | deriving (Functor,Foldable,Traversable,Eq,Ord,Read,Show,GHC.Generic) 161 | instance SOP.Generic (Only x) 162 | instance SOP.HasDatatypeInfo (Only x) 163 | 164 | {- | Variable-length text type with limit 165 | 166 | >>> :kind! PG (VarChar 4) 167 | PG (VarChar 4) :: PGType 168 | = 'PGvarchar 4 169 | -} 170 | newtype VarChar (n :: Nat) = VarChar Strict.Text 171 | deriving (Eq,Ord,Read,Show) 172 | 173 | -- | Constructor for `VarChar` 174 | varChar :: forall n . KnownNat n => Strict.Text -> Maybe (VarChar n) 175 | varChar t = 176 | if Strict.Text.length t <= fromIntegral (natVal @n Proxy) 177 | then Just $ VarChar t 178 | else Nothing 179 | 180 | -- | Access the `Strict.Text` of a `VarChar` 181 | getVarChar :: VarChar n -> Strict.Text 182 | getVarChar (VarChar t) = t 183 | 184 | {- | Fixed-length, blank padded 185 | 186 | >>> :kind! PG (FixChar 4) 187 | PG (FixChar 4) :: PGType 188 | = 'PGchar 4 189 | -} 190 | newtype FixChar (n :: Nat) = FixChar Strict.Text 191 | deriving (Eq,Ord,Read,Show) 192 | 193 | -- | Constructor for `FixChar` 194 | fixChar :: forall n . KnownNat n => Strict.Text -> Maybe (FixChar n) 195 | fixChar t = 196 | if Strict.Text.length t == fromIntegral (natVal @n Proxy) 197 | then Just $ FixChar t 198 | else Nothing 199 | 200 | -- | Access the `Strict.Text` of a `FixChar` 201 | getFixChar :: FixChar n -> Strict.Text 202 | getFixChar (FixChar t) = t 203 | -------------------------------------------------------------------------------- /squeal-postgresql/src/Squeal/PostgreSQL/Type/List.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module: Squeal.PostgreSQL.Type.List 3 | Description: list related types and functions 4 | Copyright: (c) Eitan Chatav, 2019 5 | Maintainer: eitan@morphism.tech 6 | Stability: experimental 7 | 8 | Haskell singly-linked lists are very powerful. This module 9 | provides functionality for type-level lists, heterogeneous 10 | lists and type aligned lists. 11 | -} 12 | 13 | {-# LANGUAGE 14 | DataKinds 15 | , FlexibleContexts 16 | , GADTs 17 | , LambdaCase 18 | , MultiParamTypeClasses 19 | , OverloadedStrings 20 | , PolyKinds 21 | , QuantifiedConstraints 22 | , RankNTypes 23 | , ScopedTypeVariables 24 | , TypeApplications 25 | , TypeFamilies 26 | , TypeOperators 27 | , UndecidableInstances 28 | #-} 29 | 30 | module Squeal.PostgreSQL.Type.List 31 | ( -- * Heterogeneous List 32 | SOP.NP (..) 33 | , (*:) 34 | , one 35 | -- * Path 36 | , Path (..) 37 | -- * Type Level List 38 | , Join 39 | , disjoin 40 | , Additional (..) 41 | , Elem 42 | , In 43 | , Length 44 | , SubList 45 | , SubsetList 46 | -- * Type Level Sort 47 | , Sort 48 | , MergeSort 49 | , Twos 50 | , FoldMerge 51 | , Merge 52 | , MergeHelper 53 | , MapFst 54 | ) where 55 | 56 | import Control.Category.Free 57 | import Data.Function ((&)) 58 | import Data.Kind 59 | import Data.Type.Bool 60 | import GHC.TypeLits 61 | 62 | import Generics.SOP as SOP 63 | 64 | -- | `Join` is simply promoted `++` and is used in @JOIN@s in 65 | -- `Squeal.PostgreSQL.Query.FromClause`s. 66 | type family Join xs ys where 67 | Join '[] ys = ys 68 | Join (x ': xs) ys = x ': Join xs ys 69 | 70 | -- | `disjoin` is a utility function for splitting an `NP` list into pieces. 71 | disjoin 72 | :: forall xs ys expr. SListI xs 73 | => NP expr (Join xs ys) 74 | -> (NP expr xs, NP expr ys) 75 | disjoin = case sList @xs of 76 | SNil -> \ys -> (Nil, ys) 77 | SCons -> \(x :* xsys) -> 78 | case disjoin xsys of (xs,ys) -> (x :* xs, ys) 79 | 80 | -- | The `Additional` class is for appending 81 | -- type-level list parameterized constructors such as `NP`, 82 | -- `Squeal.PostgreSQL.Query.Selection`, and `Squeal.PostgreSQL.Query.FromClause`. 83 | class Additional expr where 84 | also :: expr ys -> expr xs -> expr (Join xs ys) 85 | instance Additional (NP expr) where 86 | also ys = \case 87 | Nil -> ys 88 | x :* xs -> x :* (xs & also ys) 89 | 90 | -- | A useful operator for ending an `NP` list of length 91 | -- at least 2 without `Nil` 92 | (*:) :: f x -> f y -> NP f '[x,y] 93 | x *: y = x :* y :* Nil 94 | infixl 8 *: 95 | 96 | -- | A list of length `one`. 97 | one :: f x -> NP f '[x] 98 | one f = f :* Nil 99 | 100 | -- | @Elem@ is a promoted `Data.List.elem`. 101 | type family Elem x xs where 102 | Elem x '[] = 'False 103 | Elem x (x ': _) = 'True 104 | Elem x (_ ': xs) = Elem x xs 105 | 106 | -- | @In x xs@ is a constraint that proves that @x@ is in @xs@. 107 | type family In x xs :: Constraint where 108 | In x xs = If (Elem x xs) (() :: Constraint) 109 | (TypeError ('ShowType x ':<>: 'Text " is not in " ':<>: 'ShowType xs)) 110 | 111 | {- | Calculate the `Length` of a type level list 112 | 113 | >>> :kind! Length '[Char,String,Bool,Double] 114 | Length '[Char,String,Bool,Double] :: Nat 115 | = 4 116 | -} 117 | type family Length (xs :: [k]) :: Nat where 118 | Length '[] = 0 119 | Length (_ : xs) = 1 + Length xs 120 | 121 | {- | `SubList` checks that one type level list is a sublist of another, 122 | with the same ordering. 123 | 124 | >>> :kind! SubList '[1,2,3] '[4,5,6] 125 | SubList '[1,2,3] '[4,5,6] :: Bool 126 | = 'False 127 | >>> :kind! SubList '[1,2,3] '[1,2,3,4] 128 | SubList '[1,2,3] '[1,2,3,4] :: Bool 129 | = 'True 130 | >>> :kind! SubList '[1,2,3] '[0,1,0,2,0,3] 131 | SubList '[1,2,3] '[0,1,0,2,0,3] :: Bool 132 | = 'True 133 | >>> :kind! SubList '[1,2,3] '[3,2,1] 134 | SubList '[1,2,3] '[3,2,1] :: Bool 135 | = 'False 136 | -} 137 | type family SubList (xs :: [k]) (ys :: [k]) :: Bool where 138 | SubList '[] ys = 'True 139 | SubList (x ': xs) '[] = 'False 140 | SubList (x ': xs) (x ': ys) = SubList xs ys 141 | SubList (x ': xs) (y ': ys) = SubList (x ': xs) ys 142 | 143 | {- | `SubsetList` checks that one type level list is a subset of another, 144 | regardless of ordering and repeats. 145 | 146 | >>> :kind! SubsetList '[1,2,3] '[4,5,6] 147 | SubsetList '[1,2,3] '[4,5,6] :: Bool 148 | = 'False 149 | >>> :kind! SubsetList '[1,2,3] '[1,2,3,4] 150 | SubsetList '[1,2,3] '[1,2,3,4] :: Bool 151 | = 'True 152 | >>> :kind! SubsetList '[1,2,3] '[0,1,0,2,0,3] 153 | SubsetList '[1,2,3] '[0,1,0,2,0,3] :: Bool 154 | = 'True 155 | >>> :kind! SubsetList '[1,2,3] '[3,2,1] 156 | SubsetList '[1,2,3] '[3,2,1] :: Bool 157 | = 'True 158 | >>> :kind! SubsetList '[1,1,1] '[3,2,1] 159 | SubsetList '[1,1,1] '[3,2,1] :: Bool 160 | = 'True 161 | -} 162 | type family SubsetList (xs :: [k]) (ys :: [k]) :: Bool where 163 | SubsetList '[] ys = 'True 164 | SubsetList (x ': xs) ys = Elem x ys && SubsetList xs ys 165 | 166 | -- | 'Sort' sorts a type level list of 'Symbol's in ascending lexicographic order 167 | type Sort ls = MergeSort (Twos ls) 168 | 169 | -- | 'MergeSort' is the workhorse behind 'Sort' 170 | type family MergeSort (ls :: [[Symbol]]) :: [Symbol] where 171 | MergeSort '[] = '[] 172 | MergeSort '[x] = x 173 | MergeSort ls = MergeSort (FoldMerge ls) 174 | 175 | -- | @Two@s splits a type-level list into a list of sorted lists of length 2 (with a singelton list potentially at the end) 176 | -- It is required for implementing 'MergeSort' 177 | type family Twos (ls :: [k]) :: [[k]] where 178 | Twos (x ': y ': rs) = Merge '[x] '[y] ': Twos rs 179 | Twos '[x] = '[ '[x]] 180 | Twos '[] = '[] 181 | 182 | -- | 'Merge' two sorted lists into one list 183 | type family Merge (ls :: [Symbol]) (rs :: [Symbol]) :: [Symbol] where 184 | Merge '[] r = r 185 | Merge l '[] = l 186 | Merge (l ': ls) (r ': rs) = MergeHelper (l ': ls) (r ': rs) (CmpSymbol l r) 187 | 188 | -- | 'MergeHelper' decides whether to take an element from the right or left list next, 189 | -- depending on the result of their comparison 190 | type family MergeHelper (ls :: [Symbol]) (rs :: [Symbol]) (cmp :: Ordering) where 191 | MergeHelper ls (r ': rs) 'GT = r ': Merge ls rs 192 | MergeHelper (l ': ls) rs leq = l ': Merge ls rs 193 | 194 | -- | 'FoldMerge' folds over a list of sorted lists, merging them into a single sorted list 195 | type family FoldMerge (ls :: [[Symbol]]) :: [[Symbol]] where 196 | FoldMerge (x ': y ': rs) = (Merge x y ': FoldMerge rs) 197 | FoldMerge '[x] = '[x] 198 | FoldMerge '[] = '[] 199 | 200 | -- | 'MapFst' takes the first value of each tuple of a type level list of tuples. Useful for getting 201 | -- only the names in associatve lists 202 | type family MapFst (ls :: [(j, k)]) :: [j] where 203 | MapFst ('(j, _) ': rest) = j ': MapFst rest 204 | MapFst '[] = '[] 205 | -------------------------------------------------------------------------------- /squeal-postgresql/test/Doc.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Test.DocTest 4 | 5 | main :: IO () 6 | main = doctest [ "-isrc", "src" ] 7 | -------------------------------------------------------------------------------- /squeal-presentation.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/morphismtech/squeal/533cab7bbc4ccd8da2872af511c79acf9896cd8c/squeal-presentation.pdf -------------------------------------------------------------------------------- /squeal.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/morphismtech/squeal/533cab7bbc4ccd8da2872af511c79acf9896cd8c/squeal.gif -------------------------------------------------------------------------------- /stack-ghc8_10.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-18.28 2 | packages: 3 | - squeal-postgresql 4 | - squeal-postgresql-ltree 5 | - squeal-postgresql-uuid-ossp 6 | -------------------------------------------------------------------------------- /stack-ghc8_8.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-16.31 2 | packages: 3 | - squeal-postgresql 4 | - squeal-postgresql-ltree 5 | - squeal-postgresql-uuid-ossp 6 | -------------------------------------------------------------------------------- /stack-ghc9_0.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-19.33 2 | packages: 3 | - squeal-postgresql 4 | - squeal-postgresql-ltree 5 | - squeal-postgresql-uuid-ossp 6 | -------------------------------------------------------------------------------- /stack-ghc9_2.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-20.26 2 | packages: 3 | - squeal-postgresql 4 | - squeal-postgresql-ltree 5 | - squeal-postgresql-uuid-ossp 6 | extra-deps: 7 | - records-sop-0.1.1.1 8 | -------------------------------------------------------------------------------- /stack-ghc9_4.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-21.9 2 | packages: 3 | - squeal-postgresql 4 | - squeal-postgresql-ltree 5 | - squeal-postgresql-uuid-ossp 6 | extra-deps: 7 | - records-sop-0.1.1.1 8 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-22.13 2 | packages: 3 | - squeal-postgresql 4 | - squeal-postgresql-ltree 5 | - squeal-postgresql-uuid-ossp 6 | --------------------------------------------------------------------------------