├── .ghci ├── .gitattributes ├── .github └── workflows │ ├── build.yaml │ └── test.yaml ├── .gitignore ├── .hlint.yaml ├── .stylish-haskell.yaml ├── ChangeLog.md ├── LICENSE ├── Makefile ├── README.md ├── Setup.hs ├── benchmark ├── README.md ├── RepeatThreadPool.hs ├── requests-per-second-constant.hs └── requests-per-second.hs ├── package.yaml ├── postgresql-pure.cabal ├── src └── Database │ ├── HDBC │ └── PostgreSQL │ │ └── Pure.hs │ └── PostgreSQL │ ├── Pure.hs │ ├── Pure │ ├── Internal │ │ ├── Connection.hs │ │ ├── Data.hs │ │ ├── Exception.hs │ │ ├── MonadFail.hs │ │ ├── Query.hs │ │ └── SocketIO.hs │ ├── List.hs │ ├── Oid.hs │ └── Parser.hs │ └── Simple │ └── Time │ └── Internal │ ├── Parser.hs │ └── Printer.hs ├── stack-ghc-8.4.yaml ├── stack-ghc-8.4.yaml.lock ├── stack-ghc-8.6.yaml ├── stack-ghc-8.6.yaml.lock ├── stack-ghc-8.8.yaml ├── stack-ghc-8.8.yaml.lock ├── stack-nightly.yaml ├── stack-nightly.yaml.lock ├── template ├── Builder.hs ├── BuilderItem.hs ├── Length.hs ├── LengthItem.hs ├── Parser.hs └── ParserItem.hs ├── test-asset ├── create-tables.sql └── insert.sql ├── test-doctest └── doctest.hs ├── test-hdbc-postgresql ├── SpecificDB.hs ├── SpecificDBTests.hs ├── TestMisc.hs ├── TestSbasics.hs ├── TestTime.hs ├── TestUtils.hs ├── Testbasics.hs ├── Tests.hs └── runtests.hs ├── test-original ├── Database │ ├── HDBC │ │ └── PostgreSQL │ │ │ └── PureSpec.hs │ └── PostgreSQL │ │ ├── Pure │ │ └── ListSpec.hs │ │ └── PureSpec.hs ├── Spec.hs └── Test │ └── Hspec │ └── Core │ └── Hooks │ └── Extra.hs └── test-relational-record ├── DataSource.hs ├── DataSource └── Pure.hs ├── Relation ├── Person.hs └── Pure │ └── Person.hs └── Spec.hs /.ghci: -------------------------------------------------------------------------------- 1 | :set -XOverloadedStrings -XFlexibleContexts -XTypeFamilies -XDataKinds -XTypeApplications -fno-ignore-asserts 2 | -------------------------------------------------------------------------------- /.gitattributes: -------------------------------------------------------------------------------- 1 | * text=auto eol=lf 2 | *.hs text eol=lf 3 | *.yaml text eol=lf 4 | *.cabal text eol=lf 5 | *.ps1 text eol=crlf 6 | -------------------------------------------------------------------------------- /.github/workflows/build.yaml: -------------------------------------------------------------------------------- 1 | name: build 2 | 3 | on: 4 | - push 5 | - pull_request 6 | 7 | jobs: 8 | build: 9 | strategy: 10 | matrix: 11 | include: 12 | - os: windows-latest 13 | ghc: ghc-8.4 14 | continue-on-error: false 15 | - os: windows-latest 16 | ghc: ghc-8.6 17 | continue-on-error: false 18 | - os: windows-latest 19 | ghc: ghc-8.8 20 | continue-on-error: true 21 | - os: windows-latest 22 | ghc: nightly 23 | continue-on-error: true 24 | - os: macos-latest 25 | ghc: ghc-8.4 26 | continue-on-error: false 27 | - os: macos-latest 28 | ghc: ghc-8.6 29 | continue-on-error: false 30 | - os: macos-latest 31 | ghc: ghc-8.8 32 | continue-on-error: false 33 | - os: macos-latest 34 | ghc: nightly 35 | continue-on-error: true 36 | - os: ubuntu-latest 37 | ghc: ghc-8.4 38 | continue-on-error: false 39 | - os: ubuntu-latest 40 | ghc: ghc-8.6 41 | continue-on-error: false 42 | - os: ubuntu-latest 43 | ghc: ghc-8.8 44 | continue-on-error: false 45 | - os: ubuntu-latest 46 | ghc: nightly 47 | continue-on-error: true 48 | 49 | runs-on: ${{ matrix.os }} 50 | 51 | continue-on-error: ${{ matrix.continue-on-error }} 52 | 53 | steps: 54 | - uses: actions/checkout@v2 55 | - uses: actions/setup-haskell@v1 56 | with: 57 | enable-stack: true 58 | stack-version: 'latest' 59 | - uses: actions/cache@v2 60 | with: 61 | path: .stack-work 62 | key: project-${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('src') }}-${{ hashFiles('package.yaml') }}-${{ hashFiles(format('stack-{0}.yaml.lock', matrix.ghc)) }} 63 | - uses: actions/cache@v2 64 | with: 65 | path: ~/.stack 66 | key: user-${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('package.yaml') }}-${{ hashFiles(format('stack-{0}.yaml.lock', matrix.ghc)) }} 67 | - run: make build-deps-${{ matrix.ghc }} 68 | - run: make build-${{ matrix.ghc }} 69 | -------------------------------------------------------------------------------- /.github/workflows/test.yaml: -------------------------------------------------------------------------------- 1 | name: test 2 | 3 | on: 4 | - push 5 | - pull_request 6 | 7 | jobs: 8 | test: 9 | strategy: 10 | matrix: 11 | ghc: [ghc-8.4, ghc-8.6, ghc-8.8] 12 | test: [doctest, original, hdbc-postgresql, relational-record] 13 | continue-on-error: [false] 14 | include: 15 | - ghc: nightly 16 | test: doctest 17 | continue-on-error: true 18 | - ghc: nightly 19 | test: original 20 | continue-on-error: true 21 | - ghc: nightly 22 | test: hdbc-postgresql 23 | continue-on-error: true 24 | - ghc: nightly 25 | test: relational-record 26 | continue-on-error: true 27 | 28 | runs-on: ubuntu-latest 29 | 30 | services: 31 | postgres: 32 | image: postgres 33 | env: 34 | POSTGRES_PASSWORD: 'password' 35 | options: >- 36 | --health-cmd pg_isready 37 | --health-interval 10s 38 | --health-timeout 5s 39 | --health-retries 5 40 | ports: 41 | - 5432:5432 42 | 43 | continue-on-error: ${{ matrix.continue-on-error }} 44 | 45 | steps: 46 | - uses: actions/checkout@v2 47 | - run: sudo apt-get install -y postgresql-client-12 48 | - run: echo '::set-env name=PGHOST::localhost' 49 | - run: echo '::set-env name=PGPORT::5432' 50 | - run: echo '::set-env name=PGDATABASE::postgres' 51 | - run: echo '::set-env name=PGUSER::postgres' 52 | - run: echo '::set-env name=PGPASSWORD::password' 53 | - run: echo '::set-env name=PURE_HOST::localhost' 54 | - run: echo '::set-env name=PURE_PORT::5432' 55 | - run: echo '::set-env name=PURE_DATABASE::postgres' 56 | - run: echo '::set-env name=PURE_USER::postgres' 57 | - run: echo '::set-env name=PURE_PASSWORD::password' 58 | - run: | 59 | pg_isready 60 | psql < test-asset/create-tables.sql 61 | - run: | 62 | pg_isready 63 | psql < test-asset/insert.sql 64 | - uses: actions/setup-haskell@v1 65 | with: 66 | enable-stack: true 67 | stack-version: 'latest' 68 | - uses: actions/cache@v2 69 | with: 70 | path: .stack-work 71 | key: project-${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('src') }}-${{ hashFiles(format('test-', matrix.test)) }}-${{ hashFiles('package.yaml') }}-${{ hashFiles(format('stack-{0}.yaml.lock', matrix.ghc)) }} 72 | - uses: actions/cache@v2 73 | with: 74 | path: ~/.stack 75 | key: user-${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('package.yaml') }}-${{ hashFiles(format('stack-{0}.yaml.lock', matrix.ghc)) }} 76 | - run: make build-deps-${{ matrix.ghc }} 77 | - run: make build-${{ matrix.ghc }} 78 | - run: make test-${{ matrix.test }}-${{ matrix.ghc }} 79 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | dist-newstyle/ 3 | stack.yaml 4 | *~ 5 | 6 | TAGS 7 | 8 | src/Database/PostgreSQL/Pure/Internal/Builder.hs 9 | src/Database/PostgreSQL/Pure/Internal/Parser.hs 10 | src/Database/PostgreSQL/Pure/Internal/Length.hs 11 | -------------------------------------------------------------------------------- /.hlint.yaml: -------------------------------------------------------------------------------- 1 | - ignore: { name: Use lambda-case } 2 | - ignore: { name: Use tuple-section } 3 | - ignore: { name: Reduce duplication } 4 | -------------------------------------------------------------------------------- /.stylish-haskell.yaml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/iijlab/postgresql-pure/2a640f102f3e3540aedbcf4cfb5d1ed10310f773/.stylish-haskell.yaml -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for postgresql-pure 2 | 3 | ## 0.2.2.0 4 | 5 | 2020.07.19 6 | 7 | - Default implementations get to be given for `FromRecord` and `ToRecord`. 8 | 9 | ## 0.2.1.0 10 | 11 | 2020.07.14 12 | 13 | - Add necessary files. 14 | 15 | ## 0.2.0.0 16 | 17 | 2020.07.13 18 | 19 | ### Breaking changes 20 | 21 | - Remove orphan `IsLabel` instance definitions; [#2](https://github.com/iij-ii/postgresql-pure/pull/2) thanks to [@nakaji-dayo](https://github.com/nakaji-dayo). 22 | 23 | ### Other changes 24 | 25 | - Add cleartext password authentication; [#1](https://github.com/iij-ii/postgresql-pure/pull/1) thanks to [@goodlyrottenapple](https://github.com/goodlyrottenapple). 26 | - Change the Haskell type corresponding to `timetz` from `(TimeOfDay, TimeZone)` to `TimeOfDayWithTimeZone`. 27 | - Not only tuples but also other types which have `Length` type function can be record. 28 | 29 | ## 0.1.3.0 30 | 31 | 2020.06.15 32 | 33 | - Expose a function for type class instance implementations. 34 | - A new instance `FromField String`. 35 | - New instances for `FromRecord` and `ToRecord`. 36 | 37 | ## 0.1.2.0 38 | 39 | 2019.10.21 40 | 41 | - Fix a compilation error with network ≧ 3.0.0. 42 | 43 | ## 0.1.1.0 44 | 45 | 2019.10.21 46 | 47 | - Fix an issue sometimes missing “Error” responses after “Sync” requests. 48 | 49 | ## 0.1.0.0 50 | 51 | 2019.10.21 52 | 53 | - Release. 54 | 55 | ### Known Issues 56 | 57 | - Sometimes missing “Error” responses after “Sync” requests 58 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2019, IIJ Innovation Institute Inc. 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions 6 | are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | * Redistributions in binary form must reproduce the above copyright 11 | notice, this list of conditions and the following disclaimer in 12 | the documentation and/or other materials provided with the 13 | distribution. 14 | * Neither the name of the copyright holders nor the names of its 15 | contributors may be used to endorse or promote products derived 16 | from this software without specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 21 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 22 | COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 23 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 24 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 25 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 26 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 27 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 28 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 29 | POSSIBILITY OF SUCH DAMAGE. 30 | 31 | # postgresql-simple 32 | 33 | ## Files 34 | 35 | - src/Database/PostgreSQL/Simple/Time/Internal/Parser.hs 36 | - src/Database/PostgreSQL/Simple/Time/Internal/Printer.hs 37 | 38 | ## Full Text 39 | 40 | Copyright (c) 2011, Leon P Smith 41 | 42 | All rights reserved. 43 | 44 | Redistribution and use in source and binary forms, with or without 45 | modification, are permitted provided that the following conditions are met: 46 | 47 | * Redistributions of source code must retain the above copyright 48 | notice, this list of conditions and the following disclaimer. 49 | 50 | * Redistributions in binary form must reproduce the above 51 | copyright notice, this list of conditions and the following 52 | disclaimer in the documentation and/or other materials provided 53 | with the distribution. 54 | 55 | * Neither the name of Leon P Smith nor the names of other 56 | contributors may be used to endorse or promote products derived 57 | from this software without specific prior written permission. 58 | 59 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 60 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 61 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 62 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 63 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 64 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 65 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 66 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 67 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 68 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 69 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 70 | 71 | 72 | Copyright (c) 2011, MailRank, Inc. 73 | 74 | All rights reserved. 75 | 76 | Redistribution and use in source and binary forms, with or without 77 | modification, are permitted provided that the following conditions 78 | are met: 79 | 80 | 1. Redistributions of source code must retain the above copyright 81 | notice, this list of conditions and the following disclaimer. 82 | 83 | 2. Redistributions in binary form must reproduce the above copyright 84 | notice, this list of conditions and the following disclaimer in the 85 | documentation and/or other materials provided with the distribution. 86 | 87 | 3. Neither the name of the author nor the names of his contributors 88 | may be used to endorse or promote products derived from this software 89 | without specific prior written permission. 90 | 91 | THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS 92 | OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 93 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 94 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 95 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 96 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 97 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 98 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 99 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 100 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 101 | POSSIBILITY OF SUCH DAMAGE. 102 | 103 | # HDBC-postgresql 104 | 105 | ## Files 106 | 107 | - test-hdbc-postgresql/runtests.hs 108 | - test-hdbc-postgresql/SpecificDB.hs 109 | - test-hdbc-postgresql/SpecificDBTests.hs 110 | - test-hdbc-postgresql/Testbasics.hs 111 | - test-hdbc-postgresql/TestMisc.hs 112 | - test-hdbc-postgresql/TestSbasics.hs 113 | - test-hdbc-postgresql/Tests.hs 114 | - test-hdbc-postgresql/TestTime.hs 115 | - test-hdbc-postgresql/TestUtils.hs 116 | 117 | ## Full Text 118 | 119 | Copyright (c) 2005-2011 John Goerzen 120 | All rights reserved. 121 | 122 | Redistribution and use in source and binary forms, with or without 123 | modification, are permitted provided that the following conditions are met: 124 | 125 | * Redistributions of source code must retain the above copyright notice, this 126 | list of conditions and the following disclaimer. 127 | 128 | * Redistributions in binary form must reproduce the above copyright notice, this 129 | list of conditions and the following disclaimer in the documentation and/or 130 | other materials provided with the distribution. 131 | 132 | * Neither the name of John Goerzen nor the names of its 133 | contributors may be used to endorse or promote products derived from this 134 | software without specific prior written permission. 135 | 136 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 137 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 138 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 139 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 140 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 141 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 142 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 143 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 144 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 145 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 146 | 147 | # postgres-wire 148 | 149 | ## Files 150 | 151 | - benchmark/requests-per-second.hs 152 | 153 | ## Full Text 154 | 155 | MIT License 156 | 157 | Copyright (c) 2017 Vyacheslav Hashov 158 | 159 | Permission is hereby granted, free of charge, to any person obtaining a copy 160 | of this software and associated documentation files (the "Software"), to deal 161 | in the Software without restriction, including without limitation the rights 162 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 163 | copies of the Software, and to permit persons to whom the Software is 164 | furnished to do so, subject to the following conditions: 165 | 166 | The above copyright notice and this permission notice shall be included in all 167 | copies or substantial portions of the Software. 168 | 169 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 170 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 171 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 172 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 173 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 174 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 175 | SOFTWARE. 176 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | PWSH = pwsh 2 | 3 | .PHONY: build 4 | build: build-ghc-8.4 build-ghc-8.6 build-ghc-8.8 build-nightly 5 | 6 | .PHONY: build-ghc-8.4 7 | build-ghc-8.4: build-deps-ghc-8.4 src 8 | stack --stack-yaml stack-ghc-8.4.yaml build --ghc-options -Werror 9 | 10 | .PHONY: build-ghc-8.6 11 | build-ghc-8.6: build-deps-ghc-8.6 src 12 | stack --stack-yaml stack-ghc-8.6.yaml build --ghc-options -Werror 13 | 14 | .PHONY: build-ghc-8.8 15 | build-ghc-8.8: build-deps-ghc-8.8 src 16 | stack --stack-yaml stack-ghc-8.8.yaml build --ghc-options -Werror 17 | 18 | .PHONY: build-nightly 19 | build-nightly: build-deps-nightly src 20 | stack --stack-yaml stack-nightly.yaml --resolver nightly build --ghc-options -Werror 21 | 22 | .PHONY: build-deps-ghc-8.4 23 | build-deps-ghc-8.4: stack-ghc-8.4.yaml package.yaml 24 | stack --stack-yaml stack-ghc-8.4.yaml build --only-dependencies 25 | 26 | .PHONY: build-deps-ghc-8.6 27 | build-deps-ghc-8.6: stack-ghc-8.6.yaml package.yaml 28 | stack --stack-yaml stack-ghc-8.6.yaml build --only-dependencies 29 | 30 | .PHONY: build-deps-ghc-8.8 31 | build-deps-ghc-8.8: stack-ghc-8.8.yaml package.yaml 32 | stack --stack-yaml stack-ghc-8.8.yaml build --only-dependencies 33 | 34 | .PHONY: build-deps-nightly 35 | build-deps-nightly: stack-nightly.yaml package.yaml 36 | stack --stack-yaml stack-nightly.yaml --resolver nightly build --only-dependencies 37 | 38 | .PHONY: test 39 | test: test-ghc-8.4 test-ghc-8.6 test-ghc-8.8 test-nightly 40 | 41 | .PHONY: test-ghc-8.4 42 | test-ghc-8.4: test-doctest-ghc-8.4 test-original-ghc-8.4 test-hdbc-postgresql-ghc-8.4 test-relational-record-ghc-8.4 43 | 44 | .PHONY: test-doctest-ghc-8.4 45 | test-doctest-ghc-8.4: build-ghc-8.4 46 | stack --stack-yaml stack-ghc-8.4.yaml build --ghc-options -Werror postgresql-pure:test:doctest 47 | 48 | .PHONY: test-original-ghc-8.4 49 | test-original-ghc-8.4: build-ghc-8.4 50 | stack --stack-yaml stack-ghc-8.4.yaml build --ghc-options -Werror postgresql-pure:test:original 51 | 52 | .PHONY: test-hdbc-postgresql-ghc-8.4 53 | test-hdbc-postgresql-ghc-8.4: build-ghc-8.4 54 | stack --stack-yaml stack-ghc-8.4.yaml build --ghc-options -Werror postgresql-pure:test:hdbc-postgresql 55 | 56 | .PHONY: test-relational-record-ghc-8.4 57 | test-relational-record-ghc-8.4: build-ghc-8.4 58 | stack --stack-yaml stack-ghc-8.4.yaml build --ghc-options -Werror postgresql-pure:test:relational-record 59 | 60 | .PHONY: test-ghc-8.6 61 | test-ghc-8.6: test-doctest-ghc-8.6 test-original-ghc-8.6 test-hdbc-postgresql-ghc-8.6 test-relational-record-ghc-8.6 62 | 63 | .PHONY: test-doctest-ghc-8.6 64 | test-doctest-ghc-8.6: build-ghc-8.6 65 | stack --stack-yaml stack-ghc-8.6.yaml build --ghc-options -Werror postgresql-pure:test:doctest 66 | 67 | .PHONY: test-original-ghc-8.6 68 | test-original-ghc-8.6: build-ghc-8.6 69 | stack --stack-yaml stack-ghc-8.6.yaml build --ghc-options -Werror postgresql-pure:test:original 70 | 71 | .PHONY: test-hdbc-postgresql-ghc-8.6 72 | test-hdbc-postgresql-ghc-8.6: build-ghc-8.6 73 | stack --stack-yaml stack-ghc-8.6.yaml build --ghc-options -Werror postgresql-pure:test:hdbc-postgresql 74 | 75 | .PHONY: test-relational-record-ghc-8.6 76 | test-relational-record-ghc-8.6: build-ghc-8.6 77 | stack --stack-yaml stack-ghc-8.6.yaml build --ghc-options -Werror postgresql-pure:test:relational-record 78 | 79 | .PHONY: test-ghc-8.8 80 | test-ghc-8.8: test-doctest-ghc-8.8 test-original-ghc-8.8 test-hdbc-postgresql-ghc-8.8 test-relational-record-ghc-8.8 81 | 82 | .PHONY: test-doctest-ghc-8.8 83 | test-doctest-ghc-8.8: build-ghc-8.8 84 | stack --stack-yaml stack-ghc-8.8.yaml build --ghc-options -Werror postgresql-pure:test:doctest 85 | 86 | .PHONY: test-original-ghc-8.8 87 | test-original-ghc-8.8: build-ghc-8.8 88 | stack --stack-yaml stack-ghc-8.8.yaml build --ghc-options -Werror postgresql-pure:test:original 89 | 90 | .PHONY: test-hdbc-postgresql-ghc-8.8 91 | test-hdbc-postgresql-ghc-8.8: build-ghc-8.8 92 | stack --stack-yaml stack-ghc-8.8.yaml build --ghc-options -Werror postgresql-pure:test:hdbc-postgresql 93 | 94 | .PHONY: test-relational-record-ghc-8.8 95 | test-relational-record-ghc-8.8: build-ghc-8.8 96 | stack --stack-yaml stack-ghc-8.8.yaml build --ghc-options -Werror postgresql-pure:test:relational-record 97 | 98 | .PHONY: test-nightly 99 | test-nightly: test-doctest-nightly test-original-nightly test-hdbc-postgresql-nightly test-relational-record-nightly 100 | 101 | .PHONY: test-doctest-nightly 102 | test-doctest-nightly: build-nightly 103 | stack --stack-yaml stack-nightly.yaml --resolver nightly build --ghc-options -Werror postgresql-pure:test:doctest 104 | 105 | .PHONY: test-original-nightly 106 | test-original-nightly: build-nightly 107 | stack --stack-yaml stack-nightly.yaml --resolver nightly build --ghc-options -Werror postgresql-pure:test:original 108 | 109 | .PHONY: test-hdbc-postgresql-nightly 110 | test-hdbc-postgresql-nightly: build-nightly 111 | stack --stack-yaml stack-nightly.yaml --resolver nightly build --ghc-options -Werror postgresql-pure:test:hdbc-postgresql 112 | 113 | .PHONY: test-relational-record-nightly 114 | test-relational-record-nightly: build-nightly 115 | stack --stack-yaml stack-nightly.yaml --resolver nightly build --ghc-options -Werror postgresql-pure:test:relational-record 116 | 117 | .PHONY: format 118 | format: 119 | $(PWSH) -Command "& { Get-ChildItem -Filter '*.hs' -Recurse src, test, test-doctest, test-relational-record, benchmark | Where-Object { $$_.Directory -notlike '*\src\Database\PostgreSQL\Simple\Time\Internal' } | ForEach-Object { stack exec -- stylish-haskell -i $$_.FullName } }" 120 | stack exec -- stylish-haskell -i Setup.hs 121 | 122 | .PHONY: lint 123 | lint: 124 | stack exec -- hlint\ 125 | src/Database/PostgreSQL/Pure.hs\ 126 | src/Database/PostgreSQL/Pure\ 127 | src/Database/HDBC\ 128 | test\ 129 | test-doctest\ 130 | test-relational-record\ 131 | benchmark 132 | 133 | pages-path=../postgresql-pure-pages 134 | 135 | .PHONY: doc 136 | doc: 137 | $(PWSH) -Command "& {\ 138 | Remove-Item -Recurse $(pages-path)\*;\ 139 | stack --stack-yaml stack-nightly.yaml haddock --haddock-arguments '--odir $(pages-path)';\ 140 | $$revision = $$(git rev-parse HEAD);\ 141 | Push-Location $(pages-path);\ 142 | git add .;\ 143 | git commit -m $$revision;\ 144 | Pop-Location\ 145 | }" 146 | 147 | .PHONY: push-doc 148 | push-doc: 149 | $(PWSH) -Command "& {\ 150 | Push-Location $(pages-path);\ 151 | git push;\ 152 | Pop-Location\ 153 | }" 154 | 155 | .PHONY: targets 156 | targets: 157 | $(PWSH) -Command "& { Get-Content .\Makefile | Where-Object { $$_ -like '.PHONY*' } | ForEach-Object { $$_.Substring(8) } }" 158 | 159 | .PHONY: clean 160 | clean: 161 | stack --stack-yaml stack-ghc-8.4.yaml clean 162 | stack --stack-yaml stack-ghc-8.6.yaml clean 163 | stack --stack-yaml stack-ghc-8.8.yaml clean 164 | 165 | .PHONY: clean-full 166 | clean-full: 167 | stack --stack-yaml stack-ghc-8.4.yaml clean --full 168 | stack --stack-yaml stack-ghc-8.6.yaml clean --full 169 | stack --stack-yaml stack-ghc-8.8.yaml clean --full 170 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # postgresql-pure 2 | 3 | [![Hackage](https://matrix.hackage.haskell.org/api/v2/packages/postgresql-pure/badge)](http://hackage.haskell.org/package/postgresql-pure) [![Haddock](https://img.shields.io/badge/Haddock-0.2.2.0-blue)](https://iij-ii.github.io/postgresql-pure/) [![CI build](https://github.com/iij-ii/postgresql-pure/workflows/build/badge.svg)](https://github.com/iij-ii/postgresql-pure/actions?query=workflow%3Abuild) [![CI test](https://github.com/iij-ii/postgresql-pure/workflows/test/badge.svg)](https://github.com/iij-ii/postgresql-pure/actions?query=workflow%3Atest) 4 | 5 | ## Copyright 6 | 7 | 2019 IIJ Innovation Institute Inc. 8 | 9 | And some files are licensed by followings. See the LICENSE file for details. 10 | 11 | - BSD-3-Clause 12 | - 2012-2015 Leon P Smith 13 | - 2015 Bryan O'Sullivan 14 | - BSD-3-Clause 15 | - 2005-2011 John Goerzen 16 | - MIT 17 | - 2017 Vyacheslav Hashov 18 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeApplications #-} 2 | 3 | import Prelude hiding (head, init, last, reverse, tail) 4 | import qualified Prelude 5 | 6 | import Control.Exception (IOException, try) 7 | import Data.Char (isDigit) 8 | import Data.Either (fromRight) 9 | import Data.Foldable (for_) 10 | import Data.List (intercalate, intersperse, isPrefixOf, replicate, stripPrefix) 11 | import Distribution.Simple (Args, UserHooks (preBuild), defaultMainWithHooks, simpleUserHooks) 12 | import Distribution.Simple.Setup (BuildFlags) 13 | import Distribution.Types.HookedBuildInfo (HookedBuildInfo, emptyHookedBuildInfo) 14 | import System.Directory (copyFile, createDirectoryIfMissing, getModificationTime, 15 | getTemporaryDirectory, removeFile) 16 | import System.FilePath (dropExtension, takeFileName, ()) 17 | import System.IO (Handle, IOMode (ReadMode), hClose, hGetLine, hIsEOF, hPutStrLn, 18 | hSetNewlineMode, noNewlineTranslation, openTempFile, stdin, 19 | withFile) 20 | 21 | main :: IO () 22 | main = 23 | defaultMainWithHooks 24 | simpleUserHooks 25 | { preBuild = \_ _ -> preProcessBuilder >> preProcessParser >> preProcessLength >> pure emptyHookedBuildInfo } 26 | 27 | preProcess :: FilePath -> (Word -> [String] -> [String]) -> IO () 28 | preProcess srcPath embed = do 29 | let 30 | fileName = takeFileName srcPath 31 | templatePath = "template" fileName 32 | templateItemPath = "template" dropExtension fileName ++ "Item.hs" 33 | d <- dirty srcPath templatePath templateItemPath 34 | if d 35 | then do 36 | putStrLn $ "necessary to update " ++ srcPath 37 | tempPath <- 38 | withFile templatePath ReadMode $ \template -> do 39 | tempDir <- ( "postgresql-pure") <$> getTemporaryDirectory 40 | createDirectoryIfMissing True tempDir 41 | (tempPath, temp) <- openTempFile tempDir fileName 42 | hSetNewlineMode template noNewlineTranslation 43 | hSetNewlineMode temp noNewlineTranslation 44 | hSetNewlineMode stdin noNewlineTranslation 45 | templateItem <- lines <$> readFile templateItemPath 46 | loop template temp templateItem 47 | hClose temp 48 | pure tempPath 49 | copyFile tempPath srcPath 50 | removeFile tempPath 51 | else putStrLn $ "unnecessary to update " ++ srcPath 52 | where 53 | loop :: Handle -> Handle -> [String] -> IO () 54 | loop template temp templateItem = 55 | go 56 | where 57 | go = do 58 | eof <- hIsEOF template 59 | if eof 60 | then pure () 61 | else do 62 | line <- hGetLine template 63 | for_ (preprocess line templateItem) (hPutStrLn temp) 64 | go 65 | 66 | preprocess :: String -> [String] -> [String] 67 | preprocess line templateItem 68 | | Just rest <- stripPrefix "---- embed " line 69 | , let n = read $ takeWhile isDigit rest 70 | = embed n templateItem 71 | | otherwise = [line] 72 | 73 | preProcessBuilder :: IO () 74 | preProcessBuilder = preProcess "src/Database/PostgreSQL/Pure/Internal/Builder.hs" embed 75 | where 76 | embed :: Word -> [String] -> [String] 77 | embed l templateItem 78 | | l >= 2 = concatMap go templateItem 79 | | otherwise = error "length must be larger than or equal to 2" 80 | where 81 | go "" = [""] 82 | go t 83 | | Just rest <- stripPrefix "" t = [toField ++ Prelude.head (go rest)] 84 | | Just rest <- stripPrefix "" t = [typeTuple ++ Prelude.head (go rest)] 85 | | Just rest <- stripPrefix "" t = [valueTuple ++ Prelude.head (go rest)] 86 | | Just rest <- stripPrefix "" t = [formatList ++ Prelude.head (go rest)] 87 | | Just rest <- stripPrefix "" t = [oidList ++ Prelude.head (go rest)] 88 | | Just rest <- stripPrefix "" t = [toFieldNothingList ++ Prelude.head (go rest)] 89 | | Just rest <- stripPrefix "" t = [toFieldJustList ++ Prelude.head (go rest)] 90 | | Just rest <- stripPrefix "" t = [length ++ Prelude.head (go rest)] 91 | | Just rest <- stripPrefix "<>" t = ["<>" ++ Prelude.head (go rest)] 92 | | Just rest <- stripPrefix "<" t = error $ "unknown tag: " ++ takeWhile (/= '>') rest 93 | | (s, rest) <- span (/= '<') t = [s ++ Prelude.head (go rest)] 94 | n = fromIntegral l 95 | toField = paren $ take n $ ("ToField " ++) <$> i012 96 | typeTuple = paren $ take n i012 97 | valueTuple = paren $ take n v012 98 | formatList = bracket $ take n f012 99 | oidList = bracket $ take n o012 100 | toFieldNothingList = bracket $ take n $ (\(f, v) -> "toField backendParams encode Nothing " ++ f ++ " " ++ v) <$> zip f012 v012 101 | toFieldJustList = bracket $ take n $ (\(o, f, v) -> "toField backendParams encode (Just " ++ o ++ ") " ++ f ++ " " ++ v) <$> zip3 o012 f012 v012 102 | length = show l 103 | paren xs = "(" ++ intercalate ", " xs ++ ")" 104 | bracket xs = "[" ++ intercalate ", " xs ++ "]" 105 | i012 = ('i':) . show <$> [0 ..] 106 | o012 = ('o':) . show <$> [0 ..] 107 | f012 = ('f':) . show <$> [0 ..] 108 | v012 = ('v':) . show <$> [0 ..] 109 | 110 | preProcessParser :: IO () 111 | preProcessParser = preProcess "src/Database/PostgreSQL/Pure/Internal/Parser.hs" embed 112 | where 113 | embed :: Word -> [String] -> [String] 114 | embed l templateItem 115 | | l >= 2 = concatMap go templateItem 116 | | otherwise = error "length must be larger than or equal to 2" 117 | where 118 | go "" = [""] 119 | go t 120 | | Just rest <- stripPrefix "" t = [fromField ++ Prelude.head (go rest)] 121 | | Just rest <- stripPrefix "" t = [tuple ++ Prelude.head (go rest)] 122 | | Just rest <- stripPrefix "" t = [list ++ Prelude.head (go rest)] 123 | | Just rest <- stripPrefix "" t = [length ++ Prelude.head (go rest)] 124 | | Just rest <- stripPrefix "" t = [tupleCons ++ Prelude.head (go rest)] 125 | | Just rest <- stripPrefix "" t = [decode ++ Prelude.head (go rest)] 126 | | Just rest <- stripPrefix "<$>" t = ["<$>" ++ Prelude.head (go rest)] 127 | | Just rest <- stripPrefix "<>" t = ["<>" ++ Prelude.head (go rest)] 128 | | Just rest <- stripPrefix "<" t = error $ "unknown tag: " ++ takeWhile (/= '>') rest 129 | | (s, rest) <- span (/= '<') t = [s ++ Prelude.head (go rest)] 130 | n = fromIntegral l 131 | fromField = paren $ take n $ ("FromField " ++) <$> i012 132 | tuple = paren $ take n i012 133 | list = bracket $ take n i012 134 | length = show l 135 | tupleCons = "(" ++ replicate (n - 1) ',' ++ ")" 136 | decode = intercalate " <*> " $ take n $ ("column decode " ++) <$> i012 137 | paren xs = "(" ++ intercalate ", " xs ++ ")" 138 | bracket xs = "[" ++ intercalate ", " xs ++ "]" 139 | i012 = ('i':) . show <$> [0 ..] 140 | 141 | preProcessLength :: IO () 142 | preProcessLength = preProcess "src/Database/PostgreSQL/Pure/Internal/Length.hs" embed 143 | where 144 | embed :: Word -> [String] -> [String] 145 | embed l templateItem 146 | | l >= 2 = concatMap go templateItem 147 | | otherwise = error "length must be larger than or equal to 2" 148 | where 149 | go "" = [""] 150 | go t 151 | | Just rest <- stripPrefix "" t = [tuple ++ Prelude.head (go rest)] 152 | | Just rest <- stripPrefix "" t = [length ++ Prelude.head (go rest)] 153 | | Just rest <- stripPrefix "<" t = error $ "unknown tag: " ++ takeWhile (/= '>') rest 154 | | (s, rest) <- span (/= '<') t = [s ++ Prelude.head (go rest)] 155 | n = fromIntegral l 156 | tuple = paren $ take n i012 157 | length = show l 158 | paren xs = "(" ++ intercalate ", " xs ++ ")" 159 | i012 = ('i':) . show <$> [0 ..] 160 | 161 | dirty :: FilePath -> FilePath -> FilePath -> IO Bool 162 | dirty src template templateItem = 163 | try @IOException @Bool (do 164 | srcTime <- getModificationTime src 165 | templateTime <- getModificationTime template 166 | templateItemTime <- getModificationTime templateItem 167 | setupTime <- getModificationTime "Setup.hs" 168 | pure $ srcTime < maximum [templateTime, templateItemTime, setupTime] 169 | ) >>= pure . fromRight True 170 | -------------------------------------------------------------------------------- /benchmark/README.md: -------------------------------------------------------------------------------- 1 | # postgresql-benchmarck 2 | 3 | ## Libraries 4 | 5 | - postgresql-libpq 6 | - https://hackage.haskell.org/package/postgresql-libpq 7 | - low-level binding to libpq https://github.com/phadej/postgresql-libpq 8 | 9 | - postgresql-simple 10 | - https://hackage.haskell.org/package/postgresql-simple 11 | - Mid-Level PostgreSQL client library 12 | - depends on *postgresql-libpq* 13 | 14 | - HDBC-postgresql 15 | - http://hackage.haskell.org/package/HDBC-postgresql 16 | - PostgreSQL driver for HDBC 17 | - uses libpq directly 18 | 19 | - postgresql-typed 20 | - https://hackage.haskell.org/package/postgresql-typed 21 | - PostgreSQL interface with compile-time SQL type checking, optional HDBC backend 22 | - no libpq 23 | 24 | - hasql 25 | - https://hackage.haskell.org/package/hasql 26 | - An efficient PostgreSQL driver and a flexible mapping API 27 | - depends on *postgresql-libpq* 28 | 29 | - postgres-wire 30 | - https://github.com/postgres-haskell/postgres-wire 31 | - not yet released 32 | - no libpq 33 | -------------------------------------------------------------------------------- /benchmark/RepeatThreadPool.hs: -------------------------------------------------------------------------------- 1 | module RepeatThreadPool 2 | ( Pool 3 | , start 4 | , state 5 | , kill 6 | ) where 7 | 8 | import Control.Concurrent (ThreadId, forkIO, killThread) 9 | import Control.Monad (replicateM) 10 | import Data.IORef (IORef, newIORef, readIORef, writeIORef) 11 | import Data.Traversable (for) 12 | 13 | newtype Pool a = Pool [(ThreadId, IORef a)] 14 | 15 | start :: Word -> IO a -> (a -> IO a) -> IO (Pool a) 16 | start n ini task = do 17 | ts <- replicateM (fromIntegral n) $ do 18 | s <- ini 19 | ref <- newIORef s 20 | tid <- forkIO $ go ref s 21 | pure (tid, ref) 22 | pure $ Pool ts 23 | where 24 | go r s = do 25 | s' <- task s 26 | writeIORef r s' 27 | go r s' 28 | 29 | state :: Pool a -> IO [a] 30 | state (Pool ts) = for ts $ \(_, ref) -> readIORef ref 31 | 32 | kill :: Pool a -> IO [a] 33 | kill (Pool ts) = 34 | for ts $ \(tid, ref) -> do 35 | killThread tid 36 | readIORef ref 37 | -------------------------------------------------------------------------------- /benchmark/requests-per-second-constant.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE DuplicateRecordFields #-} 5 | {-# LANGUAGE NamedFieldPuns #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE QuasiQuotes #-} 8 | 9 | {-# OPTIONS_GHC -Wno-orphans #-} 10 | {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- for postgresql-typed's pgSQL quasiquotes 11 | 12 | #if __GLASGOW_HASKELL__ >= 808 13 | #define MIN_VERSION_postgresql_typed(a, b, c) 0 14 | #endif 15 | 16 | import qualified Database.PostgreSQL.Simple as S 17 | #if !MIN_VERSION_postgresql_simple(0,6,0) 18 | import qualified Database.PostgreSQL.Simple.FromField as S 19 | import qualified Database.PostgreSQL.Simple.FromRow as S 20 | #endif 21 | 22 | import qualified Database.PostgreSQL.Pure as P 23 | import qualified Database.PostgreSQL.Pure.Oid as P 24 | 25 | #if __GLASGOW_HASKELL__ < 808 26 | import qualified Database.PostgreSQL.Typed as T 27 | #endif 28 | 29 | #ifndef mingw32_HOST_OS 30 | #if !MIN_VERSION_base(4,13,0) 31 | import qualified Database.PostgreSQL.Driver as W 32 | import qualified Database.PostgreSQL.Protocol.Codecs.Decoders as WD 33 | import qualified Database.PostgreSQL.Protocol.DataRows as W 34 | import qualified Database.PostgreSQL.Protocol.Decoders as WD 35 | import qualified Database.PostgreSQL.Protocol.Store.Decode as WD 36 | #endif 37 | #endif 38 | 39 | import qualified RepeatThreadPool as Pool 40 | 41 | import Control.Applicative ((<|>)) 42 | import Control.Concurrent (threadDelay) 43 | import Control.DeepSeq (NFData (rnf), deepseq) 44 | import Control.Exception (AsyncException (ThreadKilled), catchJust, throwIO) 45 | import Control.Monad (void) 46 | import qualified Data.Attoparsec.ByteString as AP 47 | import qualified Data.Attoparsec.ByteString.Char8 as APC 48 | import Data.ByteString (ByteString) 49 | import qualified Data.ByteString.Char8 as BSC 50 | import qualified Data.ByteString.Lazy as BSL 51 | import qualified Data.ByteString.UTF8 as BSU 52 | import qualified Data.Csv as Csv 53 | import Data.Default.Class (def) 54 | import Data.Functor (($>)) 55 | import Data.Hourglass (TimeFormatElem (Format_Day2, Format_Hour, Format_Minute, Format_Month2, Format_Second, Format_Text, Format_TzHM, Format_Year), 56 | TimeFormatString (TimeFormatString), timePrint) 57 | import Data.Int (Int32, Int64) 58 | import Data.IORef 59 | import Data.List (sortOn) 60 | import Data.Maybe (fromJust, fromMaybe) 61 | import Data.Proxy (Proxy (Proxy)) 62 | import Data.Scientific 63 | import Data.String (IsString) 64 | import Data.Time 65 | import Data.Traversable (for) 66 | import GHC.Generics (Generic) 67 | import System.CPUTime (getCPUTime) 68 | import System.Environment (lookupEnv) 69 | import System.Hourglass (timeCurrent) 70 | import System.IO (IOMode (WriteMode), withFile) 71 | import System.Random.Shuffle (shuffleM) 72 | import Time.System (timeCurrentP) 73 | import Time.Types (Elapsed (Elapsed), ElapsedP (ElapsedP), 74 | NanoSeconds (NanoSeconds), Seconds (Seconds)) 75 | 76 | #if __GLASGOW_HASKELL__ < 808 && !MIN_VERSION_postgresql_typed(0,6,0) 77 | import Network (PortID (PortNumber)) 78 | #endif 79 | 80 | main :: IO () 81 | main = do 82 | current <- timeCurrent 83 | host <- getEnvDef "PB_HOST" "localhost" 84 | concurrencies <- parseEnvDef "PB_CONCURRENCY" [10] (listParser concurrencyParser) 85 | period <- parseEnvDef "PB_PERIOD" 60 periodParser 86 | sample <- readEnvDef "PB_SAMPLE" 1 87 | libraries <- parseEnvDef "PB_LIBRARY" measures (listParser libraryParser) 88 | patterns <- shuffleM $ (,,) <$> libraries <*> concurrencies <*> [0 .. sample - 1] 89 | dat <- 90 | for patterns $ \((name, measure), concurrency, nth) -> do 91 | let config = Config { concurrency, period, host } 92 | putStrLn $ "target: " <> name <> ", concurrency: " <> show concurrency <> ", nth: " <> show nth 93 | Result cpuTime tps <- measure config 94 | pure $ ResultRecord name concurrency nth cpuTime tps 95 | let 96 | sortedDat = 97 | sortOn 98 | (\ResultRecord { methodName, concurrency, nth } -> (methodName, concurrency, nth)) 99 | dat 100 | let csv = Csv.encodeDefaultOrderedByName sortedDat 101 | withFile ("constant-" <> timePrint timeFormat current <> ".csv") WriteMode $ flip BSL.hPutStr csv 102 | 103 | listParser :: AP.Parser a -> AP.Parser [a] 104 | listParser p = ((:) <$> (p <* APC.char ',' <* AP.many' APC.space) <*> listParser p) <|> ((:[]) <$> p) 105 | 106 | concurrencyParser :: AP.Parser Word 107 | concurrencyParser = APC.decimal 108 | 109 | periodParser :: AP.Parser Word 110 | periodParser = do 111 | n <- APC.decimal 112 | unit <- (APC.char 's' $> 1) <|> (APC.char 'm' $> 60) 113 | pure $ n * unit 114 | 115 | libraryParser :: AP.Parser (String, Config -> IO Result) 116 | libraryParser = 117 | ("pure" $> ("pure", measurePure)) 118 | <|> ("simple" $> ("simple", measureSimple)) 119 | <|> ("typed" $> ("typed", measureTyped)) 120 | <|> ("wire" $> ("wire", measureWire)) 121 | 122 | query :: IsString a => a 123 | query = "SELECT 2147483647 :: int4, 9223372036854775807 :: int8, 1234567890.0123456789 :: numeric, 0.015625 :: float4, 0.00024414062 :: float8, 'hello' :: varchar, 'hello' :: text, '\\xDEADBEEF' :: bytea, '1000-01-01 00:00:00.000001' :: timestamp, '2000-01-01 00:00:00.000001+14:30' :: timestamptz, '0001-01-01' :: date, '23:00:00' :: time, true :: bool" 124 | 125 | measures :: [(String, Config -> IO Result)] 126 | measures = 127 | [ ("pure", measurePure) 128 | , ("simple", measureSimple) 129 | , ("typed", measureTyped) 130 | , ("wire", measureWire) 131 | ] 132 | 133 | data PureConnection = PureConnection { psRef :: IORef (Maybe (P.PreparedStatement 0 13)), connection :: P.Connection } 134 | 135 | measurePure :: Config -> IO Result 136 | measurePure config@Config { host } = do 137 | let 138 | pureConfig = 139 | def 140 | { P.user = "postgres" 141 | , P.database = "tiny_tpcc" 142 | , P.address = P.AddressNotResolved host "5432" 143 | } 144 | doMeasure 145 | config 146 | (PureConnection <$> newIORef Nothing <*> P.connect pureConfig) 147 | (P.disconnect . connection) 148 | $ \PureConnection { psRef, connection } -> do 149 | mps <- readIORef psRef 150 | case mps of 151 | Nothing -> do 152 | let 153 | resultOids = (P.int4, P.int8, P.numeric, P.float4, P.float8, P.varchar, P.text, P.bytea, P.timestamp, P.timestamptz, P.date, P.time, P.bool) 154 | psProc = P.parse "ps" (P.Query query) (Just (Proxy, resultOids)) :: P.PreparedStatementProcedure 0 13 155 | pProc = fromJust $ P.bind "" P.BinaryFormat P.BinaryFormat (P.parameters connection) (const $ fail "") () psProc :: P.PortalProcedure 0 13 156 | eProc = P.execute 0 (const $ fail "") pProc :: P.ExecutedProcedure 0 13 (Int32, Int64, Scientific, Float, Double, ByteString, ByteString, ByteString, LocalTime, UTCTime, Day, TimeOfDay, Bool) 157 | ((ps, _, e, _), _) <- P.sync connection eProc 158 | deepseq (P.records e) $ pure () 159 | writeIORef psRef $ Just ps 160 | Just ps -> do 161 | let 162 | pProc = fromJust $ P.bind "" P.BinaryFormat P.BinaryFormat (P.parameters connection) (const $ fail "") () ps :: P.PortalProcedure 0 13 163 | eProc = P.execute 0 (const $ fail "") pProc :: P.ExecutedProcedure 0 13 (Int32, Int64, Scientific, Float, Double, ByteString, ByteString, ByteString, LocalTime, UTCTime, Day, TimeOfDay, Bool) 164 | void $ P.sync connection eProc 165 | 166 | measureSimple :: Config -> IO Result 167 | measureSimple config@Config { host } = do 168 | let libpqParam = "user='postgres' dbname='tiny_tpcc' host='" <> BSU.fromString host <> "'" 169 | doMeasure 170 | config 171 | (S.connectPostgreSQL libpqParam) 172 | S.close 173 | $ \conn -> do 174 | r <- S.query_ conn query :: IO [(Int32, Int64, Scientific, Float, Double, ByteString, ByteString, ByteString, LocalTime, UTCTime, Day, TimeOfDay, Bool)] 175 | deepseq r $ pure () 176 | 177 | measureTyped :: Config -> IO Result 178 | #if __GLASGOW_HASKELL__ >= 808 179 | measureTyped = error "postgresql-typed is not compatible with template-haskell >= 2.15.0.0" 180 | #else 181 | measureTyped config@Config { host } = do 182 | let 183 | postgresqlConfig = 184 | T.defaultPGDatabase 185 | { T.pgDBUser = "postgres" 186 | , T.pgDBName = "tiny_tpcc" 187 | #if MIN_VERSION_postgresql_typed(0,6,0) 188 | , T.pgDBAddr = Left (host, "5432") 189 | #else 190 | , T.pgDBHost = host 191 | , T.pgDBPort = PortNumber 5432 192 | #endif 193 | } 194 | doMeasure 195 | config 196 | (T.pgConnect postgresqlConfig) 197 | T.pgDisconnect 198 | $ \conn -> do 199 | r <- 200 | T.pgQuery 201 | conn 202 | [T.pgSQL|! SELECT 2147483647 :: int4, 9223372036854775807 :: int8, 1234567890.0123456789 :: numeric, 0.015625 :: float4, 0.00024414062 :: float8, 'hello' :: varchar, 'hello' :: text, '\xDEADBEEF' :: bytea, '1000-01-01 00:00:00.000001' :: timestamp, '2000-01-01 00:00:00.000001+14:30' :: timestamptz, '0001-01-01' :: date, '23:00:00' :: time, true :: bool |] 203 | :: IO [(Int32, Int64, Scientific, Float, Double, ByteString, ByteString, ByteString, LocalTime, UTCTime, Day, TimeOfDay, Bool)] 204 | deepseq r $ pure () 205 | #endif 206 | 207 | measureWire :: Config -> IO Result 208 | #ifdef mingw32_HOST_OS 209 | measureWire = error "postgres-wire can run on only UNIX-like environments" 210 | #elif MIN_VERSION_base(4,13,0) 211 | measureWire = error "postgres-wire is not compatible with base >= 4.13.0" 212 | #else 213 | measureWire config@Config { host } = do 214 | let 215 | wireConfig = 216 | W.defaultConnectionSettings 217 | { W.settingsUser = "postgres" 218 | , W.settingsDatabase = "tiny_tpcc" 219 | , W.settingsHost = BSU.fromString host 220 | , W.settingsPort = 5432 221 | } 222 | doMeasure 223 | config 224 | (either (error . show) id <$> W.connect wireConfig) 225 | W.close 226 | $ \conn -> do 227 | W.sendBatchAndSync conn [W.Query query [] W.Binary W.Binary W.AlwaysCache] 228 | rows <- either (error . show) id <$> W.readNextData conn 229 | let 230 | decoder = do 231 | void WD.decodeHeader 232 | void WD.getInt16BE 233 | (,,,,,,,,,,,,) 234 | <$> WD.getNonNullable WD.int4 235 | <*> WD.getNonNullable WD.int8 236 | <*> WD.getNonNullable WD.numeric 237 | <*> WD.getNonNullable WD.float4 238 | <*> WD.getNonNullable WD.float8 239 | <*> WD.getNonNullable WD.bsText 240 | <*> WD.getNonNullable WD.bsText 241 | <*> WD.getNonNullable WD.bytea 242 | <*> WD.getNonNullable WD.timestamp 243 | <*> WD.getNonNullable WD.timestamptz 244 | <*> WD.getNonNullable WD.date 245 | <*> WD.getNonNullable WD.time 246 | <*> WD.getNonNullable WD.bool 247 | records = W.decodeManyRows decoder rows 248 | deepseq records $ pure () 249 | either (error . show) id <$> W.waitReadyForQuery conn 250 | #endif 251 | 252 | doMeasure :: Config -> IO conn -> (conn -> IO ()) -> (conn -> IO ())-> IO Result 253 | doMeasure Config { concurrency, period } makeConn disposeConn target = do 254 | time <- timeCurrentP -- nanoseconds 255 | cpuTime <- getCPUTime -- picoseconds 256 | pool <- 257 | Pool.start 258 | concurrency 259 | ( do 260 | conn <- makeConn 261 | pure (conn, 0 :: Word) 262 | ) 263 | ( \(conn, count) -> 264 | catchJust 265 | (\e -> if e == ThreadKilled then Just e else Nothing) 266 | (target conn $> (conn, count + 1)) 267 | (\e -> disposeConn conn *> throwIO e) 268 | ) 269 | threadDelay $ fromIntegral period * 1000 * 1000 -- microseconds 270 | time' <- timeCurrentP 271 | cpuTime' <- getCPUTime 272 | (_, counts) <- unzip <$> Pool.kill pool 273 | let 274 | count = sum counts 275 | actualPeriod@(ElapsedP (Elapsed (Seconds apSecs)) (NanoSeconds apNanosecs)) = time' - time 276 | cpuPeriod = cpuTime' - cpuTime 277 | (cpuSecs, cpuPicosecs) = cpuPeriod `divMod` (1000 ^ (4 :: Int)) 278 | tps' = fromIntegral count / (fromIntegral apSecs + fromIntegral apNanosecs / 1000 ^ (3 :: Int)) :: Double 279 | putStrLn $ "measurement period: " <> show actualPeriod 280 | putStrLn $ "CPU time: " <> show cpuSecs <> "s " <> show cpuPicosecs <> "ps" 281 | putStrLn $ "transactions per second: " <> show tps' 282 | pure $ Result cpuPeriod tps' 283 | 284 | data Config = 285 | Config 286 | { concurrency :: Word -- ^ the number of threads 287 | , period :: Word -- ^ measurement period in second 288 | , host :: String 289 | } deriving (Show, Read, Eq) 290 | 291 | data ResultRecord = 292 | ResultRecord 293 | { methodName :: String 294 | , concurrency :: Word 295 | , nth :: Word 296 | , cpuTime :: Integer 297 | , tps :: Double 298 | } 299 | deriving (Show, Read, Generic) 300 | 301 | data Result = Result { cpuTime :: Integer, tps :: Double } deriving (Show, Read, Eq) 302 | 303 | instance Csv.FromNamedRecord ResultRecord 304 | instance Csv.ToNamedRecord ResultRecord 305 | instance Csv.DefaultOrdered ResultRecord 306 | 307 | getEnvDef :: String -> String -> IO String 308 | getEnvDef name value = fromMaybe value <$> lookupEnv name 309 | 310 | readEnvDef :: Read a => String -> a -> IO a 311 | readEnvDef name value = maybe value read <$> lookupEnv name 312 | 313 | parseEnvDef :: String -> a -> AP.Parser a -> IO a 314 | parseEnvDef name value parser = do 315 | mstr <- lookupEnv name 316 | case mstr of 317 | Nothing -> pure value 318 | Just str -> 319 | case AP.parseOnly parser $ BSC.pack str of 320 | Left e -> error $ "parseEnv " <> name <> ": " <> e 321 | Right a -> pure a 322 | 323 | timeFormat :: TimeFormatString 324 | timeFormat = 325 | TimeFormatString 326 | [ Format_Year, dash, Format_Month2, dash, Format_Day2 -- date 327 | , Format_Text 'T' 328 | , Format_Hour, dash, Format_Minute, dash, Format_Second -- time 329 | , Format_TzHM 330 | ] 331 | where 332 | dash = Format_Text '-' 333 | 334 | instance 335 | (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5, NFData a6, NFData a7, NFData a8, NFData a9, NFData a10, NFData a11, NFData a12, NFData a13) 336 | => NFData ((,,,,,,,,,,,,) a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13) where 337 | rnf (x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` rnf x7 `seq` rnf x8 `seq` rnf x9 `seq` rnf x10 `seq` rnf x11 `seq` rnf x12 `seq` rnf x13 338 | 339 | #if !MIN_VERSION_postgresql_simple(0,6,0) 340 | -- 13-tuple 341 | instance 342 | ( S.FromField a, S.FromField b, S.FromField c, S.FromField d, S.FromField e, S.FromField f, S.FromField g 343 | , S.FromField h, S.FromField i, S.FromField j, S.FromField k, S.FromField l, S.FromField m) 344 | => S.FromRow (a, b, c, d, e, f, g, h, i, j, k, l, m) where 345 | fromRow = (,,,,,,,,,,,,) <$> S.field <*> S.field <*> S.field <*> S.field <*> S.field <*> S.field <*> S.field 346 | <*> S.field <*> S.field <*> S.field <*> S.field <*> S.field <*> S.field 347 | #endif 348 | -------------------------------------------------------------------------------- /benchmark/requests-per-second.hs: -------------------------------------------------------------------------------- 1 | {- original: https://github.com/postgres-haskell/postgres-wire/blob/master/bench/Bench.hs -} 2 | 3 | {-# LANGUAGE BangPatterns #-} 4 | {-# LANGUAGE CPP #-} 5 | {-# LANGUAGE DataKinds #-} 6 | {-# LANGUAGE LambdaCase #-} 7 | {-# LANGUAGE NamedFieldPuns #-} 8 | {-# LANGUAGE OverloadedStrings #-} 9 | 10 | {-# OPTIONS_GHC -Wno-orphans#-} 11 | 12 | import Control.Concurrent 13 | import Control.DeepSeq (NFData, deepseq, rnf) 14 | import Control.Monad 15 | import Data.ByteString (ByteString) 16 | import qualified Data.ByteString as B 17 | import qualified Data.ByteString.Char8 as BC 18 | import Data.Default.Class (def) 19 | import Data.Foldable 20 | import Data.Int 21 | import Data.IORef 22 | import Data.Maybe 23 | import Data.Proxy 24 | import Data.Scientific (Scientific) 25 | import Data.Time (Day, DiffTime, LocalTime, TimeOfDay, TimeZone, UTCTime) 26 | import Data.Tuple.Homotuple.Only () 27 | import Data.Tuple.Only 28 | import Options.Applicative 29 | import System.Clock 30 | import System.Environment (lookupEnv) 31 | 32 | import qualified Database.PostgreSQL.LibPQ as LibPQ 33 | 34 | import qualified Database.PostgreSQL.Pure as Pure 35 | import qualified Database.PostgreSQL.Pure.Oid as Pure 36 | 37 | #ifndef mingw32_HOST_OS 38 | #if !MIN_VERSION_base(4,13,0) 39 | import qualified Data.ByteString.Lazy as BL 40 | 41 | import Database.PostgreSQL.Driver 42 | import qualified Database.PostgreSQL.Protocol.Codecs.Decoders as WD 43 | import Database.PostgreSQL.Protocol.DataRows 44 | import qualified Database.PostgreSQL.Protocol.Decoders as WD 45 | import qualified Database.PostgreSQL.Protocol.Store.Decode as WD 46 | import Database.PostgreSQL.Protocol.Types 47 | #endif 48 | #endif 49 | 50 | {- 51 | CREATE TABLE _bytes_100_of_1k(b bytea); 52 | CREATE TABLE _bytes_400_of_200(b bytea); 53 | CREATE TABLE _bytes_10_of_20k(b bytea); 54 | CREATE TABLE _bytes_1_of_200(b bytea); 55 | CREATE TABLE _bytes_300_of_100(b bytea); 56 | 57 | INSERT INTO _bytes_100_of_1k(b) 58 | (SELECT repeat('a', 1000)::bytea FROM generate_series(1, 100)); 59 | 60 | INSERT INTO _bytes_400_of_200(b) 61 | (SELECT repeat('a', 200)::bytea FROM generate_series(1, 400)); 62 | 63 | INSERT INTO _bytes_10_of_20k(b) 64 | (SELECT repeat('a', 20000)::bytea FROM generate_series(1, 10)); 65 | 66 | INSERT INTO _bytes_1_of_200(b) VALUES(repeat('a', 200)::bytea); 67 | 68 | INSERT INTO _bytes_300_of_100(b) 69 | (SELECT repeat('a', 100)::bytea FROM generate_series(1, 300)); 70 | -} 71 | 72 | data Action 73 | = BenchPW RowsType 74 | | BenchPure RowsType 75 | | BenchLibPQ RowsType 76 | | BenchLoop 77 | deriving (Show, Eq) 78 | 79 | data RowsType 80 | = Bytes100_1k 81 | | Bytes400_200 82 | | Bytes10_20k 83 | | Bytes1_200 84 | | Bytes300_100 85 | | Constant 86 | deriving (Show, Eq) 87 | 88 | data Config = 89 | Config 90 | { host :: String 91 | , database :: String 92 | , user :: String 93 | , password :: String 94 | } 95 | deriving (Show, Read, Eq) 96 | 97 | cli :: Parser Action 98 | cli = hsubparser $ 99 | cmd "pw" "benchmark postgres-wire" (BenchPW <$> rowTypeParser) 100 | <> cmd "pure" "benchmark postgresql-pure" (BenchPure <$> rowTypeParser) 101 | <> cmd "libpq" "benchmark libpq" (BenchLibPQ <$> rowTypeParser) 102 | <> cmd "loop" "benchmark datarows decoding loop" (pure BenchLoop) 103 | where 104 | cmd c h p = command c (info (helper <*> p) $ header h) 105 | rowTypeParser = hsubparser $ 106 | cmd "b100_1k" "100 rows of 1k bytes" (pure Bytes100_1k) 107 | <> cmd "b400_200" "400 rows of 200 bytes" (pure Bytes400_200) 108 | <> cmd "b10_20k" "10 rows of 20k bytes" (pure Bytes10_20k) 109 | <> cmd "b1_200" "1 row of 200 bytes" (pure Bytes1_200) 110 | <> cmd "b300_100" "300 rows of 100 bytes" (pure Bytes300_100) 111 | <> cmd "constant" "constant values" (pure Constant) 112 | 113 | main :: IO () 114 | main = do 115 | host <- getEnvDef "PB_HOST" "localhost" 116 | database <- getEnvDef "PB_DB" "postgres" 117 | user <- getEnvDef "PB_USER" "postgres" 118 | password <- getEnvDef "PB_PASSWORD" "" 119 | act <- execParser (info (helper <*> cli) $ header "Postgres-wire benchmark") 120 | execAction Config { host, database, user, password } act 121 | 122 | execAction :: Config -> Action -> IO () 123 | execAction config (BenchPW rows) = benchPw config rows 124 | execAction config (BenchPure rows) = benchPure config rows 125 | execAction config (BenchLibPQ rows) = benchLibpq config rows 126 | execAction config BenchLoop = benchLoop config 127 | 128 | queryStatement :: RowsType -> B.ByteString 129 | queryStatement = \case 130 | Bytes100_1k -> "SELECT * from _bytes_100_of_1k" 131 | Bytes400_200 -> "SELECT * from _bytes_400_of_200" 132 | Bytes10_20k -> "SELECT * from _bytes_10_of_20k" 133 | Bytes1_200 -> "SELECT * from _bytes_1_of_200" 134 | Bytes300_100 -> "SELECT * from _bytes_300_of_100" 135 | Constant -> "SELECT 2147483647 :: int4, 9223372036854775807 :: int8, 1234567890.0123456789 :: numeric, 0.015625 :: float4, 0.00024414062 :: float8, 'hello' :: varchar, 'hello' :: text, '\\xDEADBEEF' :: bytea, '1000-01-01 00:00:00.000001' :: timestamp, '2000-01-01 00:00:00.000001+14:30' :: timestamptz, '0001-01-01 BC' :: date, '24:00:00' :: time, '00:00:00+1459' :: timetz, '177999 millenniums 0.999999 sec' :: interval, true :: bool;" 136 | 137 | benchPw :: Config -> RowsType -> IO () 138 | #ifdef mingw32_HOST_OS 139 | benchPw = error "postgres-wire can run on only UNIX-like environments" 140 | #elif MIN_VERSION_base(4,13,0) 141 | benchPw = error "postgres-wire is not compatible with base >= 4.13.0" 142 | #else 143 | benchPw Config { host, database, user, password } rowsType = 144 | benchRequests createConnection $ \c -> 145 | case rowsType of 146 | Constant -> do 147 | sendBatchAndSync c [q] 148 | rows <- either (error . show) id <$> readNextData c 149 | let 150 | decoder = do 151 | void WD.decodeHeader 152 | void WD.getInt16BE 153 | (,,,,,,,,,,,,,,) 154 | <$> WD.getNonNullable WD.int4 155 | <*> WD.getNonNullable WD.int8 156 | <*> WD.getNonNullable WD.numeric 157 | <*> WD.getNonNullable WD.float4 158 | <*> WD.getNonNullable WD.float8 159 | <*> WD.getNonNullable WD.bsText 160 | <*> WD.getNonNullable WD.bsText 161 | <*> WD.getNonNullable WD.bytea 162 | <*> WD.getNonNullable WD.timestamp 163 | <*> WD.getNonNullable WD.timestamptz 164 | <*> WD.getNonNullable WD.date 165 | <*> WD.getNonNullable WD.time 166 | <*> WD.getNonNullable WD.timetz 167 | <*> WD.getNonNullable WD.interval 168 | <*> WD.getNonNullable WD.bool 169 | records = decodeManyRows decoder rows 170 | deepseq records $ pure () 171 | waitReadyForQuery c 172 | _ -> do 173 | sendBatchAndSync c [q] 174 | void $ readNextData c 175 | waitReadyForQuery c 176 | where 177 | statement = queryStatement rowsType 178 | q = Query statement [] Binary Binary AlwaysCache 179 | createConnection = connect defaultSettings >>= 180 | either (error . ("Connection error " <>) . show) pure 181 | 182 | defaultSettings = defaultConnectionSettings 183 | { settingsHost = BC.pack host 184 | , settingsDatabase = BC.pack database 185 | , settingsUser = BC.pack user 186 | , settingsPassword = BC.pack password 187 | } 188 | #endif 189 | 190 | benchPure :: Config -> RowsType -> IO () 191 | benchPure Config { host, database, user, password } rowsType = 192 | case rowsType of 193 | Constant -> 194 | benchRequests ((,) <$> connect <*> newIORef Nothing) $ \(c, psRef) -> do 195 | mps <- readIORef psRef 196 | case mps of 197 | Nothing -> do 198 | let 199 | resultOids = (Pure.int4, Pure.int8, Pure.numeric, Pure.float4, Pure.float8, Pure.varchar, Pure.text, Pure.bytea, Pure.timestamp, Pure.timestamptz, Pure.date, Pure.time, Pure.timetz, Pure.interval, Pure.bool) 200 | psProc = Pure.parse "ps" (Pure.Query statement) (Just (Proxy, resultOids)) :: Pure.PreparedStatementProcedure 0 15 201 | pProc = fromJust $ Pure.bind "" Pure.BinaryFormat Pure.BinaryFormat (Pure.parameters c) (const $ fail "") () psProc :: Pure.PortalProcedure 0 15 202 | eProc = Pure.execute 0 (const $ fail "") pProc :: Pure.ExecutedProcedure 0 15 (Int32, Int64, Scientific, Float, Double, ByteString, ByteString, ByteString, LocalTime, UTCTime, Day, TimeOfDay, (TimeOfDay, TimeZone), DiffTime, Bool) 203 | ((ps, _, e, _), _) <- Pure.sync c eProc 204 | deepseq (Pure.records e) $ pure () 205 | writeIORef psRef $ Just ps 206 | Just ps -> do 207 | let 208 | pProc = fromJust $ Pure.bind "" Pure.BinaryFormat Pure.BinaryFormat (Pure.parameters c) (const $ fail "") () ps :: Pure.PortalProcedure 0 15 209 | eProc = Pure.execute 0 (const $ fail "") pProc :: Pure.ExecutedProcedure 0 15 (Int32, Int64, Scientific, Float, Double, ByteString, ByteString, ByteString, LocalTime, UTCTime, Day, TimeOfDay, (TimeOfDay, TimeZone), DiffTime, Bool) 210 | void $ Pure.sync c eProc 211 | _ -> 212 | benchRequests ((,) <$> connect <*> newIORef Nothing) $ \(c, psRef) -> do 213 | mps <- readIORef psRef 214 | case mps of 215 | Nothing -> do 216 | let 217 | psProc = Pure.parse "ps" (Pure.Query statement) (Just (Proxy, Only Pure.bytea)) :: Pure.PreparedStatementProcedure 0 1 218 | pProc = fromJust $ Pure.bind "" Pure.BinaryFormat Pure.BinaryFormat (Pure.parameters c) (const $ fail "") () psProc :: Pure.PortalProcedure 0 1 219 | eProc = Pure.execute 0 (const $ fail "") pProc :: Pure.ExecutedProcedure 0 1 (Only Pure.Raw) 220 | ((ps, _, _, _), _) <- Pure.sync c eProc 221 | writeIORef psRef $ Just ps 222 | Just ps -> do 223 | let 224 | pProc = fromJust $ Pure.bind "" Pure.BinaryFormat Pure.BinaryFormat (Pure.parameters c) (const $ fail "") () ps :: Pure.PortalProcedure 0 1 225 | eProc = Pure.execute 0 (const $ fail "") pProc :: Pure.ExecutedProcedure 0 1 (Only Pure.Raw) 226 | void $ Pure.sync c eProc 227 | where 228 | statement = queryStatement rowsType 229 | connect = 230 | Pure.connect 231 | def 232 | { Pure.user = user 233 | , Pure.password = password 234 | , Pure.database = database 235 | , Pure.address = Pure.AddressNotResolved host "5432" 236 | } 237 | 238 | benchLibpq :: Config -> RowsType -> IO () 239 | benchLibpq Config { host, database, user, password } rowsType = benchRequests libpqConnection $ \c -> do 240 | r <- fromJust <$> LibPQ.execPrepared c "" [] LibPQ.Binary 241 | rows <- LibPQ.ntuples r 242 | parseRows r (rows - 1) 243 | where 244 | statement = queryStatement rowsType 245 | libpqConnection = do 246 | conn <- LibPQ.connectdb $ "host='" <> BC.pack host <> "' user='" <> BC.pack user <> "' dbname='" <> BC.pack database <> "' password='" <> BC.pack password <> "'" 247 | Just result <- LibPQ.prepare conn "" statement Nothing 248 | status <- LibPQ.resultStatus result 249 | unless (status == LibPQ.CommandOk) $ error "prepare failed" 250 | pure conn 251 | parseRows _ (-1) = pure () 252 | parseRows r n = LibPQ.getvalue r n 0 >> parseRows r (n - 1) 253 | 254 | benchRequests :: IO c -> (c -> IO a) -> IO () 255 | benchRequests connectAction queryAction = do 256 | results <- replicateM 8 newThread 257 | threadDelay $ durationSeconds * 1000 * 1000 258 | for_ results $ \(_, _, tid) -> killThread tid 259 | s <- sum <$> traverse (\(ref, _, _) -> readIORef ref) results 260 | latency_total <- sum <$> traverse (\(_, ref, _) -> readIORef ref) results 261 | 262 | putStrLn $ "Requests per second: " ++ show (s `div` durationSeconds) 263 | putStrLn $ "Average latency [ms]: " ++ displayLatency latency_total s 264 | where 265 | durationSeconds :: Int 266 | durationSeconds = 10 267 | newThread = do 268 | ref_count <- newIORef 0 :: IO (IORef Int) 269 | ref_latency <- newIORef 0 :: IO (IORef Int64) 270 | c <- connectAction 271 | tid <- forkIO $ forever $ do 272 | t1 <- getTime Monotonic 273 | r <- queryAction c 274 | r `seq` pure () 275 | t2 <- getTime Monotonic 276 | modifyIORef' ref_latency (+ getDifference t2 t1) 277 | modifyIORef' ref_count (+1) 278 | pure (ref_count, ref_latency, tid) 279 | 280 | getDifference (TimeSpec end_s end_ns) (TimeSpec start_s start_ns) = 281 | (end_s - start_s) * 1000000000 + end_ns - start_ns 282 | 283 | displayLatency latency reqs = 284 | let a = latency `div` fromIntegral reqs 285 | (ms, ns) = a `divMod` 1000000 286 | in show ms <> "." <> show ns 287 | 288 | benchLoop :: Config -> IO () 289 | #ifdef mingw32_HOST_OS 290 | benchLoop = error "postgres-wire can run on only UNIX-like environments" 291 | #elif MIN_VERSION_base(4,13,0) 292 | benchLoop = error "postgres-wire is not compatible with base >= 4.13.0" 293 | #else 294 | benchLoop _config = do 295 | counter <- newIORef 0 :: IO (IORef Word) 296 | content <- newIORef "" :: IO (IORef BL.ByteString) 297 | -- File contains a PostgreSQL binary response on the query: 298 | -- "SELECT typname, typnamespace, typowner, typlen, typbyval, 299 | -- typcategory, typispreferred, typisdefined, typdelim, 300 | -- typrelid, typelem, typarray from pg_type" 301 | !bs <- B.readFile "bench/pg_type_rows.out" 302 | writeIORef content . BL.cycle $ BL.fromStrict bs 303 | 304 | let handler dm = case dm of 305 | DataMessage _ -> modifyIORef' counter (+1) 306 | _ -> pure () 307 | newChunk preBs = do 308 | b <- readIORef content 309 | let (nb, rest) = BL.splitAt 4096 b 310 | writeIORef content rest 311 | let res = preBs <> BL.toStrict nb 312 | res `seq` pure res 313 | tid <- forkIO . forever $ loopExtractDataRows newChunk handler 314 | threadDelay $ durationSeconds * 1000 * 1000 315 | killThread tid 316 | s <- readIORef counter 317 | putStrLn $ "Data messages parsed per second: " 318 | ++ show (s `div` fromIntegral durationSeconds) 319 | where 320 | durationSeconds :: Int 321 | durationSeconds = 10 322 | #endif 323 | 324 | getEnvDef :: String -> String -> IO String 325 | getEnvDef name val = fromMaybe val <$> lookupEnv name 326 | 327 | instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5, NFData a6, NFData a7, NFData a8, NFData a9, NFData a10, NFData a11, NFData a12, NFData a13, NFData a14, NFData a15) => 328 | NFData ((,,,,,,,,,,,,,,) a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15) where 329 | rnf (x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` rnf x7 `seq` rnf x8 `seq` rnf x9 `seq` rnf x10 `seq` rnf x11 `seq` rnf x12 `seq` rnf x13 `seq` rnf x14 `seq` rnf x15 330 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: postgresql-pure 2 | version: 0.2.2.0 3 | github: iij-ii/postgresql-pure 4 | license: BSD-3-Clause 5 | author: Kazuki Okamoto 6 | maintainer: kazukiokamoto@iij.ad.jp 7 | copyright: 2019 IIJ Innovation Institute Inc. 8 | category: Database 9 | 10 | extra-source-files: 11 | - README.md 12 | - ChangeLog.md 13 | - template/Builder.hs 14 | - template/BuilderItem.hs 15 | - template/Parser.hs 16 | - template/ParserItem.hs 17 | - template/Length.hs 18 | - template/LengthItem.hs 19 | 20 | synopsis: pure Haskell PostgreSQL driver 21 | description: pure Haskell PostgreSQL driver 22 | 23 | flags: 24 | pure-md5: 25 | default: false 26 | manual: false 27 | 28 | dependencies: 29 | - base >= 4.7 30 | - attoparsec 31 | - base16-bytestring 32 | - containers 33 | - convertible 34 | - bytestring 35 | - data-default-class 36 | - double-conversion 37 | - HDBC 38 | - homotuple 39 | - list-tuple 40 | - memory 41 | - mtl 42 | - network 43 | - OneTuple 44 | - Only 45 | - postgresql-binary 46 | - postgresql-placeholder-converter 47 | - pretty-hex 48 | - safe-exceptions 49 | - scientific 50 | - single-tuple 51 | - text 52 | - time 53 | - utf8-string 54 | 55 | when: 56 | - condition: flag(pure-md5) 57 | then: 58 | dependencies: 59 | - pureMD5 60 | cpp-options: 61 | - -DPURE_MD5 62 | else: 63 | dependencies: 64 | - cryptohash-md5 65 | 66 | ghc-options: 67 | - -Wall 68 | - -Wcompat 69 | - -Wincomplete-uni-patterns 70 | - -Wincomplete-record-updates 71 | - -Wmonomorphism-restriction 72 | - -Wmissing-exported-signatures 73 | - -Wmissing-export-lists 74 | - -Wmissing-home-modules 75 | - -Widentities 76 | - -Wredundant-constraints 77 | - -Wpartial-fields 78 | - -Wno-name-shadowing 79 | 80 | custom-setup: 81 | dependencies: 82 | - Cabal 83 | - base 84 | - directory 85 | - filepath 86 | 87 | library: 88 | source-dirs: src 89 | ghc-options: 90 | - -Wmissing-import-lists 91 | default-extensions: 92 | - Strict 93 | other-modules: 94 | - Database.PostgreSQL.Pure.Internal.Connection 95 | - Database.PostgreSQL.Pure.Internal.Data 96 | - Database.PostgreSQL.Pure.Internal.Exception 97 | - Database.PostgreSQL.Pure.Internal.MonadFail 98 | - Database.PostgreSQL.Pure.Internal.Query 99 | - Database.PostgreSQL.Pure.Internal.SocketIO 100 | - Database.PostgreSQL.Simple.Time.Internal.Parser 101 | - Database.PostgreSQL.Simple.Time.Internal.Printer 102 | generated-other-modules: 103 | - Database.PostgreSQL.Pure.Internal.Builder 104 | - Database.PostgreSQL.Pure.Internal.Parser 105 | - Database.PostgreSQL.Pure.Internal.Length 106 | - Paths_postgresql_pure 107 | 108 | tests: 109 | original: 110 | main: Spec.hs 111 | source-dirs: test-original 112 | ghc-options: 113 | - -threaded 114 | - -rtsopts 115 | - -with-rtsopts=-N 116 | - -Wno-incomplete-uni-patterns 117 | - -Wno-missing-export-lists 118 | - -Wno-monomorphism-restriction 119 | dependencies: 120 | - postgresql-pure 121 | - hspec 122 | - hspec-core 123 | - Only 124 | 125 | hdbc-postgresql: 126 | main: runtests.hs 127 | source-dirs: 128 | - test-hdbc-postgresql 129 | - src 130 | ghc-options: 131 | - -threaded 132 | - -rtsopts 133 | - -with-rtsopts=-N 134 | - -Wno-all 135 | - -Wno-compat 136 | - -Wno-incomplete-uni-patterns 137 | - -Wno-incomplete-record-updates 138 | - -Wno-monomorphism-restriction 139 | - -Wno-missing-exported-signatures 140 | - -Wno-missing-export-lists 141 | - -Wno-missing-home-modules 142 | - -Wno-identities 143 | - -Wno-redundant-constraints 144 | - -Wno-partial-fields 145 | dependencies: 146 | - HUnit 147 | - QuickCheck 148 | - old-time 149 | default-extensions: 150 | - Strict 151 | 152 | relational-record: 153 | main: Spec.hs 154 | source-dirs: 155 | - test-relational-record 156 | ghc-options: 157 | - -threaded 158 | - -rtsopts 159 | - -with-rtsopts=-N 160 | - -Wno-all 161 | - -Wno-compat 162 | - -Wno-incomplete-uni-patterns 163 | - -Wno-incomplete-record-updates 164 | - -Wno-monomorphism-restriction 165 | - -Wno-missing-exported-signatures 166 | - -Wno-missing-export-lists 167 | - -Wno-missing-home-modules 168 | - -Wno-identities 169 | - -Wno-redundant-constraints 170 | - -Wno-partial-fields 171 | dependencies: 172 | - postgresql-pure 173 | - hspec 174 | - hspec-core 175 | - relational-record 176 | - relational-query 177 | - relational-query-HDBC 178 | - persistable-record 179 | - HDBC-session 180 | - HDBC-postgresql 181 | 182 | doctest: 183 | main: doctest.hs 184 | source-dirs: 185 | - test-doctest 186 | ghc-options: 187 | - -threaded 188 | - -rtsopts 189 | - -with-rtsopts=-N 190 | - -Wno-all 191 | - -Wno-compat 192 | - -Wno-incomplete-uni-patterns 193 | - -Wno-incomplete-record-updates 194 | - -Wno-monomorphism-restriction 195 | - -Wno-missing-exported-signatures 196 | - -Wno-missing-export-lists 197 | - -Wno-missing-home-modules 198 | - -Wno-identities 199 | - -Wno-redundant-constraints 200 | - -Wno-partial-fields 201 | dependencies: 202 | - doctest 203 | 204 | benchmarks: 205 | requests-per-second: 206 | main: requests-per-second.hs 207 | source-dirs: benchmark 208 | ghc-options: 209 | - -threaded 210 | - -rtsopts 211 | - -with-rtsopts=-N 212 | dependencies: 213 | - base >= 4.7 && < 5 214 | - bytestring 215 | - clock 216 | - data-default-class 217 | - deepseq 218 | - homotuple 219 | - Only 220 | - optparse-applicative 221 | - postgresql-libpq 222 | - postgresql-pure 223 | - vector 224 | when: 225 | - condition: '!os(windows) && impl(ghc < 8.8.0)' 226 | dependencies: 227 | - postgres-wire 228 | 229 | requests-per-second-constant: 230 | main: requests-per-second-constant.hs 231 | source-dirs: benchmark 232 | ghc-options: 233 | - -threaded 234 | - -rtsopts 235 | - -with-rtsopts=-N 236 | dependencies: 237 | - base >= 4.7 && < 5 238 | - bytestring 239 | - cassava 240 | - clock 241 | - data-default-class 242 | - deepseq 243 | - homotuple 244 | - hourglass 245 | - Only 246 | - optparse-applicative 247 | - postgresql-libpq 248 | - postgresql-pure 249 | - postgresql-simple 250 | - random-shuffle 251 | - utf8-string 252 | - vector 253 | when: 254 | - condition: '!os(windows) && impl(ghc < 8.8.0)' 255 | dependencies: 256 | - postgres-wire 257 | - condition: 'impl(ghc < 8.8.0)' 258 | dependencies: 259 | - postgresql-typed 260 | -------------------------------------------------------------------------------- /postgresql-pure.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.33.0. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: 5f059edd27ff8ab95243b3a3495424fd88f57773838ad8494cfa4c4d1816aff7 8 | 9 | name: postgresql-pure 10 | version: 0.2.2.0 11 | synopsis: pure Haskell PostgreSQL driver 12 | description: pure Haskell PostgreSQL driver 13 | category: Database 14 | homepage: https://github.com/iij-ii/postgresql-pure#readme 15 | bug-reports: https://github.com/iij-ii/postgresql-pure/issues 16 | author: Kazuki Okamoto 17 | maintainer: kazukiokamoto@iij.ad.jp 18 | copyright: 2019 IIJ Innovation Institute Inc. 19 | license: BSD-3-Clause 20 | license-file: LICENSE 21 | build-type: Custom 22 | extra-source-files: 23 | README.md 24 | ChangeLog.md 25 | template/Builder.hs 26 | template/BuilderItem.hs 27 | template/Parser.hs 28 | template/ParserItem.hs 29 | template/Length.hs 30 | template/LengthItem.hs 31 | 32 | source-repository head 33 | type: git 34 | location: https://github.com/iij-ii/postgresql-pure 35 | 36 | custom-setup 37 | setup-depends: 38 | Cabal 39 | , base 40 | , directory 41 | , filepath 42 | 43 | flag pure-md5 44 | manual: False 45 | default: False 46 | 47 | library 48 | exposed-modules: 49 | Database.HDBC.PostgreSQL.Pure 50 | Database.PostgreSQL.Pure 51 | Database.PostgreSQL.Pure.List 52 | Database.PostgreSQL.Pure.Oid 53 | Database.PostgreSQL.Pure.Parser 54 | other-modules: 55 | Database.PostgreSQL.Pure.Internal.Connection 56 | Database.PostgreSQL.Pure.Internal.Data 57 | Database.PostgreSQL.Pure.Internal.Exception 58 | Database.PostgreSQL.Pure.Internal.MonadFail 59 | Database.PostgreSQL.Pure.Internal.Query 60 | Database.PostgreSQL.Pure.Internal.SocketIO 61 | Database.PostgreSQL.Simple.Time.Internal.Parser 62 | Database.PostgreSQL.Simple.Time.Internal.Printer 63 | Database.PostgreSQL.Pure.Internal.Builder 64 | Database.PostgreSQL.Pure.Internal.Parser 65 | Database.PostgreSQL.Pure.Internal.Length 66 | Paths_postgresql_pure 67 | autogen-modules: 68 | Database.PostgreSQL.Pure.Internal.Builder 69 | Database.PostgreSQL.Pure.Internal.Parser 70 | Database.PostgreSQL.Pure.Internal.Length 71 | Paths_postgresql_pure 72 | hs-source-dirs: 73 | src 74 | default-extensions: Strict 75 | ghc-options: -Wall -Wcompat -Wincomplete-uni-patterns -Wincomplete-record-updates -Wmonomorphism-restriction -Wmissing-exported-signatures -Wmissing-export-lists -Wmissing-home-modules -Widentities -Wredundant-constraints -Wpartial-fields -Wno-name-shadowing -Wmissing-import-lists 76 | build-depends: 77 | HDBC 78 | , OneTuple 79 | , Only 80 | , attoparsec 81 | , base >=4.7 82 | , base16-bytestring 83 | , bytestring 84 | , containers 85 | , convertible 86 | , data-default-class 87 | , double-conversion 88 | , homotuple 89 | , list-tuple 90 | , memory 91 | , mtl 92 | , network 93 | , postgresql-binary 94 | , postgresql-placeholder-converter 95 | , pretty-hex 96 | , safe-exceptions 97 | , scientific 98 | , single-tuple 99 | , text 100 | , time 101 | , utf8-string 102 | if flag(pure-md5) 103 | cpp-options: -DPURE_MD5 104 | build-depends: 105 | pureMD5 106 | else 107 | build-depends: 108 | cryptohash-md5 109 | default-language: Haskell2010 110 | 111 | test-suite doctest 112 | type: exitcode-stdio-1.0 113 | main-is: doctest.hs 114 | other-modules: 115 | Paths_postgresql_pure 116 | hs-source-dirs: 117 | test-doctest 118 | ghc-options: -Wall -Wcompat -Wincomplete-uni-patterns -Wincomplete-record-updates -Wmonomorphism-restriction -Wmissing-exported-signatures -Wmissing-export-lists -Wmissing-home-modules -Widentities -Wredundant-constraints -Wpartial-fields -Wno-name-shadowing -threaded -rtsopts -with-rtsopts=-N -Wno-all -Wno-compat -Wno-incomplete-uni-patterns -Wno-incomplete-record-updates -Wno-monomorphism-restriction -Wno-missing-exported-signatures -Wno-missing-export-lists -Wno-missing-home-modules -Wno-identities -Wno-redundant-constraints -Wno-partial-fields 119 | build-depends: 120 | HDBC 121 | , OneTuple 122 | , Only 123 | , attoparsec 124 | , base >=4.7 125 | , base16-bytestring 126 | , bytestring 127 | , containers 128 | , convertible 129 | , data-default-class 130 | , doctest 131 | , double-conversion 132 | , homotuple 133 | , list-tuple 134 | , memory 135 | , mtl 136 | , network 137 | , postgresql-binary 138 | , postgresql-placeholder-converter 139 | , pretty-hex 140 | , safe-exceptions 141 | , scientific 142 | , single-tuple 143 | , text 144 | , time 145 | , utf8-string 146 | if flag(pure-md5) 147 | cpp-options: -DPURE_MD5 148 | build-depends: 149 | pureMD5 150 | else 151 | build-depends: 152 | cryptohash-md5 153 | default-language: Haskell2010 154 | 155 | test-suite hdbc-postgresql 156 | type: exitcode-stdio-1.0 157 | main-is: runtests.hs 158 | other-modules: 159 | SpecificDB 160 | SpecificDBTests 161 | Testbasics 162 | TestMisc 163 | Tests 164 | TestSbasics 165 | TestTime 166 | TestUtils 167 | Database.HDBC.PostgreSQL.Pure 168 | Database.PostgreSQL.Pure 169 | Database.PostgreSQL.Pure.Internal.Builder 170 | Database.PostgreSQL.Pure.Internal.Connection 171 | Database.PostgreSQL.Pure.Internal.Data 172 | Database.PostgreSQL.Pure.Internal.Exception 173 | Database.PostgreSQL.Pure.Internal.Length 174 | Database.PostgreSQL.Pure.Internal.MonadFail 175 | Database.PostgreSQL.Pure.Internal.Parser 176 | Database.PostgreSQL.Pure.Internal.Query 177 | Database.PostgreSQL.Pure.Internal.SocketIO 178 | Database.PostgreSQL.Pure.List 179 | Database.PostgreSQL.Pure.Oid 180 | Database.PostgreSQL.Pure.Parser 181 | Database.PostgreSQL.Simple.Time.Internal.Parser 182 | Database.PostgreSQL.Simple.Time.Internal.Printer 183 | Paths_postgresql_pure 184 | hs-source-dirs: 185 | test-hdbc-postgresql 186 | src 187 | default-extensions: Strict 188 | ghc-options: -Wall -Wcompat -Wincomplete-uni-patterns -Wincomplete-record-updates -Wmonomorphism-restriction -Wmissing-exported-signatures -Wmissing-export-lists -Wmissing-home-modules -Widentities -Wredundant-constraints -Wpartial-fields -Wno-name-shadowing -threaded -rtsopts -with-rtsopts=-N -Wno-all -Wno-compat -Wno-incomplete-uni-patterns -Wno-incomplete-record-updates -Wno-monomorphism-restriction -Wno-missing-exported-signatures -Wno-missing-export-lists -Wno-missing-home-modules -Wno-identities -Wno-redundant-constraints -Wno-partial-fields 189 | build-depends: 190 | HDBC 191 | , HUnit 192 | , OneTuple 193 | , Only 194 | , QuickCheck 195 | , attoparsec 196 | , base >=4.7 197 | , base16-bytestring 198 | , bytestring 199 | , containers 200 | , convertible 201 | , data-default-class 202 | , double-conversion 203 | , homotuple 204 | , list-tuple 205 | , memory 206 | , mtl 207 | , network 208 | , old-time 209 | , postgresql-binary 210 | , postgresql-placeholder-converter 211 | , pretty-hex 212 | , safe-exceptions 213 | , scientific 214 | , single-tuple 215 | , text 216 | , time 217 | , utf8-string 218 | if flag(pure-md5) 219 | cpp-options: -DPURE_MD5 220 | build-depends: 221 | pureMD5 222 | else 223 | build-depends: 224 | cryptohash-md5 225 | default-language: Haskell2010 226 | 227 | test-suite original 228 | type: exitcode-stdio-1.0 229 | main-is: Spec.hs 230 | other-modules: 231 | Database.HDBC.PostgreSQL.PureSpec 232 | Database.PostgreSQL.Pure.ListSpec 233 | Database.PostgreSQL.PureSpec 234 | Test.Hspec.Core.Hooks.Extra 235 | Paths_postgresql_pure 236 | hs-source-dirs: 237 | test-original 238 | ghc-options: -Wall -Wcompat -Wincomplete-uni-patterns -Wincomplete-record-updates -Wmonomorphism-restriction -Wmissing-exported-signatures -Wmissing-export-lists -Wmissing-home-modules -Widentities -Wredundant-constraints -Wpartial-fields -Wno-name-shadowing -threaded -rtsopts -with-rtsopts=-N -Wno-incomplete-uni-patterns -Wno-missing-export-lists -Wno-monomorphism-restriction 239 | build-depends: 240 | HDBC 241 | , OneTuple 242 | , Only 243 | , attoparsec 244 | , base >=4.7 245 | , base16-bytestring 246 | , bytestring 247 | , containers 248 | , convertible 249 | , data-default-class 250 | , double-conversion 251 | , homotuple 252 | , hspec 253 | , hspec-core 254 | , list-tuple 255 | , memory 256 | , mtl 257 | , network 258 | , postgresql-binary 259 | , postgresql-placeholder-converter 260 | , postgresql-pure 261 | , pretty-hex 262 | , safe-exceptions 263 | , scientific 264 | , single-tuple 265 | , text 266 | , time 267 | , utf8-string 268 | if flag(pure-md5) 269 | cpp-options: -DPURE_MD5 270 | build-depends: 271 | pureMD5 272 | else 273 | build-depends: 274 | cryptohash-md5 275 | default-language: Haskell2010 276 | 277 | test-suite relational-record 278 | type: exitcode-stdio-1.0 279 | main-is: Spec.hs 280 | other-modules: 281 | DataSource 282 | DataSource.Pure 283 | Relation.Person 284 | Relation.Pure.Person 285 | Paths_postgresql_pure 286 | hs-source-dirs: 287 | test-relational-record 288 | ghc-options: -Wall -Wcompat -Wincomplete-uni-patterns -Wincomplete-record-updates -Wmonomorphism-restriction -Wmissing-exported-signatures -Wmissing-export-lists -Wmissing-home-modules -Widentities -Wredundant-constraints -Wpartial-fields -Wno-name-shadowing -threaded -rtsopts -with-rtsopts=-N -Wno-all -Wno-compat -Wno-incomplete-uni-patterns -Wno-incomplete-record-updates -Wno-monomorphism-restriction -Wno-missing-exported-signatures -Wno-missing-export-lists -Wno-missing-home-modules -Wno-identities -Wno-redundant-constraints -Wno-partial-fields 289 | build-depends: 290 | HDBC 291 | , HDBC-postgresql 292 | , HDBC-session 293 | , OneTuple 294 | , Only 295 | , attoparsec 296 | , base >=4.7 297 | , base16-bytestring 298 | , bytestring 299 | , containers 300 | , convertible 301 | , data-default-class 302 | , double-conversion 303 | , homotuple 304 | , hspec 305 | , hspec-core 306 | , list-tuple 307 | , memory 308 | , mtl 309 | , network 310 | , persistable-record 311 | , postgresql-binary 312 | , postgresql-placeholder-converter 313 | , postgresql-pure 314 | , pretty-hex 315 | , relational-query 316 | , relational-query-HDBC 317 | , relational-record 318 | , safe-exceptions 319 | , scientific 320 | , single-tuple 321 | , text 322 | , time 323 | , utf8-string 324 | if flag(pure-md5) 325 | cpp-options: -DPURE_MD5 326 | build-depends: 327 | pureMD5 328 | else 329 | build-depends: 330 | cryptohash-md5 331 | default-language: Haskell2010 332 | 333 | benchmark requests-per-second 334 | type: exitcode-stdio-1.0 335 | main-is: requests-per-second.hs 336 | other-modules: 337 | RepeatThreadPool 338 | Paths_postgresql_pure 339 | hs-source-dirs: 340 | benchmark 341 | ghc-options: -Wall -Wcompat -Wincomplete-uni-patterns -Wincomplete-record-updates -Wmonomorphism-restriction -Wmissing-exported-signatures -Wmissing-export-lists -Wmissing-home-modules -Widentities -Wredundant-constraints -Wpartial-fields -Wno-name-shadowing -threaded -rtsopts -with-rtsopts=-N 342 | build-depends: 343 | HDBC 344 | , OneTuple 345 | , Only 346 | , attoparsec 347 | , base >=4.7 && <5 348 | , base16-bytestring 349 | , bytestring 350 | , clock 351 | , containers 352 | , convertible 353 | , data-default-class 354 | , deepseq 355 | , double-conversion 356 | , homotuple 357 | , list-tuple 358 | , memory 359 | , mtl 360 | , network 361 | , optparse-applicative 362 | , postgresql-binary 363 | , postgresql-libpq 364 | , postgresql-placeholder-converter 365 | , postgresql-pure 366 | , pretty-hex 367 | , safe-exceptions 368 | , scientific 369 | , single-tuple 370 | , text 371 | , time 372 | , utf8-string 373 | , vector 374 | if flag(pure-md5) 375 | cpp-options: -DPURE_MD5 376 | build-depends: 377 | pureMD5 378 | else 379 | build-depends: 380 | cryptohash-md5 381 | if !os(windows) && impl(ghc < 8.8.0) 382 | build-depends: 383 | postgres-wire 384 | default-language: Haskell2010 385 | 386 | benchmark requests-per-second-constant 387 | type: exitcode-stdio-1.0 388 | main-is: requests-per-second-constant.hs 389 | other-modules: 390 | RepeatThreadPool 391 | Paths_postgresql_pure 392 | hs-source-dirs: 393 | benchmark 394 | ghc-options: -Wall -Wcompat -Wincomplete-uni-patterns -Wincomplete-record-updates -Wmonomorphism-restriction -Wmissing-exported-signatures -Wmissing-export-lists -Wmissing-home-modules -Widentities -Wredundant-constraints -Wpartial-fields -Wno-name-shadowing -threaded -rtsopts -with-rtsopts=-N 395 | build-depends: 396 | HDBC 397 | , OneTuple 398 | , Only 399 | , attoparsec 400 | , base >=4.7 && <5 401 | , base16-bytestring 402 | , bytestring 403 | , cassava 404 | , clock 405 | , containers 406 | , convertible 407 | , data-default-class 408 | , deepseq 409 | , double-conversion 410 | , homotuple 411 | , hourglass 412 | , list-tuple 413 | , memory 414 | , mtl 415 | , network 416 | , optparse-applicative 417 | , postgresql-binary 418 | , postgresql-libpq 419 | , postgresql-placeholder-converter 420 | , postgresql-pure 421 | , postgresql-simple 422 | , pretty-hex 423 | , random-shuffle 424 | , safe-exceptions 425 | , scientific 426 | , single-tuple 427 | , text 428 | , time 429 | , utf8-string 430 | , vector 431 | if flag(pure-md5) 432 | cpp-options: -DPURE_MD5 433 | build-depends: 434 | pureMD5 435 | else 436 | build-depends: 437 | cryptohash-md5 438 | if !os(windows) && impl(ghc < 8.8.0) 439 | build-depends: 440 | postgres-wire 441 | if impl(ghc < 8.8.0) 442 | build-depends: 443 | postgresql-typed 444 | default-language: Haskell2010 445 | -------------------------------------------------------------------------------- /src/Database/PostgreSQL/Pure.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE DefaultSignatures #-} 5 | {-# LANGUAGE DerivingStrategies #-} 6 | {-# LANGUAGE DuplicateRecordFields #-} 7 | {-# LANGUAGE FlexibleContexts #-} 8 | {-# LANGUAGE FlexibleInstances #-} 9 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 10 | {-# LANGUAGE InstanceSigs #-} 11 | {-# LANGUAGE MultiParamTypeClasses #-} 12 | {-# LANGUAGE NamedFieldPuns #-} 13 | {-# LANGUAGE OverloadedLabels #-} 14 | {-# LANGUAGE ScopedTypeVariables #-} 15 | {-# LANGUAGE TypeApplications #-} 16 | {-# LANGUAGE TypeFamilies #-} 17 | {-# LANGUAGE UndecidableInstances #-} 18 | 19 | {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- These warnings are raised, although constraints are necessary. 20 | {-# OPTIONS_GHC -Wno-unused-top-binds #-} -- These warnings are raised, although "builder", "parser" fields are necessary for IsLabel instances. 21 | 22 | -- | 23 | -- This is a client library for PostgreSQL Database which has following features. 24 | -- 25 | -- - faster and less CPU load 26 | -- 27 | -- - especially on multi-core environments 28 | -- 29 | -- - pure Haskell implementations 30 | -- 31 | -- - no libpq dependency 32 | -- - easy to build even on Windows 33 | -- 34 | -- - implements extended query protocol 35 | -- 36 | -- - about extended query protocol, see 37 | -- 38 | -- = Typical Example 39 | -- 40 | -- Prepare a following table. 41 | -- 42 | -- @ 43 | -- CREATE TABLE person ( 44 | -- id serial PRIMARY KEY, 45 | -- name varchar(255) NOT NULL 46 | -- ); 47 | -- INSERT INTO person (name) VALUES (\'Ada\'); 48 | -- @ 49 | -- 50 | -- You can run like following to get the record whose ID is 1. 51 | -- 52 | -- >>> :set -XOverloadedStrings 53 | -- >>> :set -XFlexibleContexts 54 | -- >>> :set -XDataKinds 55 | -- >>> :set -XTypeFamilies 56 | -- >>> :set -XTypeApplications 57 | -- >>> 58 | -- >>> import Database.PostgreSQL.Pure 59 | -- >>> import Data.Default.Class (def) 60 | -- >>> import Data.Int (Int32) 61 | -- >>> import Data.ByteString (ByteString) 62 | -- >>> import Data.Tuple.Only (Only (Only)) 63 | -- >>> import Data.Tuple.Homotuple.Only () 64 | -- >>> import Data.Maybe (fromMaybe) 65 | -- >>> import System.Environment (lookupEnv) 66 | -- >>> 67 | -- >>> getEnvDef name value = fromMaybe value <$> lookupEnv name 68 | -- >>> 69 | -- >>> host' <- getEnvDef "PURE_HOST" "127.0.0.1" 70 | -- >>> port' <- getEnvDef "PURE_PORT" "5432" 71 | -- >>> user' <- getEnvDef "PURE_USER" "postgres" 72 | -- >>> password' <- getEnvDef "PURE_PASSWORD" "" 73 | -- >>> database' <- getEnvDef "PURE_DATABASE" "postgres" 74 | -- >>> 75 | -- >>> conn <- connect def { address = AddressNotResolved host' port', user = user', password = password', database = database' } 76 | -- >>> preparedStatementProcedure = parse "" "SELECT id, name FROM person WHERE id = $1" Nothing 77 | -- >>> portalProcedure <- bind @_ @2 @_ @_ "" BinaryFormat BinaryFormat (parameters conn) (const $ fail "") (Only (1 :: Int32)) preparedStatementProcedure 78 | -- >>> executedProcedure = execute @_ @_ @(Int32, ByteString) 0 (const $ fail "") portalProcedure 79 | -- >>> ((_, _, e, _), _) <- sync conn executedProcedure 80 | -- >>> records e 81 | -- [(1,"Ada")] 82 | module Database.PostgreSQL.Pure 83 | ( -- * Connection 84 | Config (..) 85 | , Connection 86 | , pid 87 | , parameters 88 | , config 89 | , Address (..) 90 | , BackendParameters 91 | , Pid 92 | , withConnection 93 | , connect 94 | , disconnect 95 | -- * Extended Query 96 | , parse 97 | , bind 98 | , execute 99 | , flush 100 | , sync 101 | , close 102 | , PreparedStatement 103 | , PreparedStatementProcedure 104 | , PreparedStatementName (..) 105 | , Portal 106 | , PortalProcedure 107 | , PortalName (..) 108 | , Executed 109 | , ExecutedProcedure 110 | , ExecuteResult (..) 111 | , CloseProcedure 112 | , CommandTag (..) 113 | , Query (..) 114 | , FormatCode (..) 115 | , ColumnInfo 116 | , Message 117 | , MessageResult 118 | , Bind 119 | , Execute 120 | , Close 121 | , StringEncoder 122 | , StringDecoder 123 | , HasName 124 | , Name 125 | , HasParameterOids 126 | , name 127 | , parameterOids 128 | , resultInfos 129 | , result 130 | , records 131 | -- * Transaction 132 | , begin 133 | , commit 134 | , rollback 135 | , TransactionState (..) 136 | -- * Record 137 | , FromField (..) 138 | , FromRecord (..) 139 | , ToField (..) 140 | , ToRecord (..) 141 | , Raw (..) 142 | , Length 143 | -- * Exception 144 | , Exception.Exception (..) 145 | , Exception.ErrorResponse (..) 146 | , Exception.ResponseParsingFailed (..) 147 | -- * OID 148 | , Oid 149 | ) where 150 | 151 | import Database.PostgreSQL.Pure.Internal.Connection (connect, disconnect, withConnection) 152 | import Database.PostgreSQL.Pure.Internal.Data (Address (AddressNotResolved, AddressResolved), 153 | BackendParameters, CloseProcedure, ColumnInfo, 154 | CommandTag (BeginTag, CommitTag, CopyTag, CreateTableTag, DeleteTag, DropTableTag, FetchTag, InsertTag, MoveTag, RollbackTag, SelectTag, UpdateTag), 155 | Config (Config, address, database, password, receptionBufferSize, sendingBufferSize, user), 156 | Connection (config, parameters, pid), ErrorFields, 157 | ExecuteResult (ExecuteComplete, ExecuteEmptyQuery, ExecuteSuspended), 158 | FormatCode (BinaryFormat, TextFormat), 159 | FromField (fromField), FromRecord (fromRecord), 160 | MessageResult, Oid, Pid, PortalName (PortalName), 161 | PreparedStatementName (PreparedStatementName), 162 | Query (Query), Raw (Null, Value), StringDecoder, 163 | StringEncoder, ToField (toField), ToRecord (toRecord), 164 | TransactionState) 165 | import qualified Database.PostgreSQL.Pure.Internal.Data as Data 166 | import qualified Database.PostgreSQL.Pure.Internal.Exception as Exception 167 | import Database.PostgreSQL.Pure.Internal.Length (Length) 168 | import Database.PostgreSQL.Pure.Internal.Query (Close, Message, close, flush, sync) 169 | import qualified Database.PostgreSQL.Pure.Internal.Query as Query 170 | 171 | import Data.Bifunctor (bimap) 172 | import Data.Kind (Type) 173 | import Data.Proxy (Proxy (Proxy)) 174 | import Data.Tuple.Homotuple (Homotuple, IsHomolisttuple, IsHomotupleItem) 175 | import qualified Data.Tuple.List as Tuple 176 | import GHC.Exts (IsList (Item, fromList, toList)) 177 | import GHC.Records (HasField (getField)) 178 | import GHC.TypeLits (KnownNat, Nat, natVal) 179 | 180 | #if !MIN_VERSION_base(4,13,0) 181 | import Control.Monad.Fail (MonadFail) 182 | #endif 183 | 184 | -- | This represents a prepared statement which is already processed by a server. 185 | -- 186 | -- @parameterLength@ is the number of columns of the parameter and @resultLength@ is the number of columns of the results. 187 | -- This is the same with 'PreparedStatementProcedure', 'Portal', 'PortalProcedure', 'Executed' and 'ExecutedProcedure'. 188 | newtype PreparedStatement (parameterLength :: Nat) (resultLength :: Nat) = 189 | PreparedStatement Data.PreparedStatement 190 | deriving newtype (Show, Eq, Close) 191 | 192 | instance HasField "name" (PreparedStatement n m) PreparedStatementName where 193 | getField (PreparedStatement Data.PreparedStatement { name }) = name 194 | 195 | instance (oids ~ Homotuple n Oid, Item oids ~ Oid, IsList oids) => HasField "parameterOids" (PreparedStatement n m) oids where 196 | getField (PreparedStatement Data.PreparedStatement { parameterOids }) = fromList parameterOids 197 | 198 | -- | To get a list of column infos of the result record. 199 | resultInfos :: (IsHomolisttuple m ColumnInfo, IsHomotupleItem m ColumnInfo) => PreparedStatement n m -> Homotuple m ColumnInfo 200 | resultInfos (PreparedStatement Data.PreparedStatement { resultInfos }) = fromList resultInfos 201 | 202 | -- | This represents a prepared statement which is not yet processed by a server. 203 | newtype PreparedStatementProcedure (parameterLength :: Nat) (resultLength :: Nat) = 204 | PreparedStatementProcedure Data.PreparedStatementProcedure 205 | deriving newtype (Show, Message) 206 | 207 | instance HasField "name" (PreparedStatementProcedure n m) PreparedStatementName where 208 | getField (PreparedStatementProcedure Data.PreparedStatementProcedure { name }) = name 209 | 210 | instance (oids ~ Homotuple n Oid, Item oids ~ Oid, IsList oids) => HasField "parameterOids" (PreparedStatementProcedure n m) (Maybe oids) where 211 | getField (PreparedStatementProcedure Data.PreparedStatementProcedure { parameterOids }) = fromList <$> parameterOids 212 | 213 | type instance MessageResult (PreparedStatementProcedure n m) = (PreparedStatement n m) 214 | 215 | -- | This represents a portal which is already processed by a server. 216 | newtype Portal (parameterLength :: Nat) (resultLength :: Nat) = 217 | Portal Data.Portal 218 | deriving newtype (Show, Eq, Close) 219 | 220 | instance HasField "name" (Portal n m) PortalName where 221 | getField (Portal Data.Portal { name }) = name 222 | 223 | -- | This represents a portal which is not yet processed by a server. 224 | newtype PortalProcedure (parameterLength :: Nat) (resultLength :: Nat) = 225 | PortalProcedure Data.PortalProcedure 226 | deriving newtype (Show, Message) 227 | 228 | instance HasField "name" (PortalProcedure n m) PortalName where 229 | getField (PortalProcedure Data.PortalProcedure { name }) = name 230 | 231 | type instance MessageResult (PortalProcedure n m) = (PreparedStatement n m, Portal n m) 232 | 233 | -- | This represents a result of a "Execute" message which is already processed by a server. 234 | newtype Executed (parameterLength :: Nat) (resultLength :: Nat) r = 235 | Executed (Data.Executed r) 236 | deriving newtype (Show, Eq) 237 | 238 | -- | To get the result of 'Executed'. 239 | result :: Executed n m r -> ExecuteResult 240 | result (Executed Data.Executed { result }) = result 241 | 242 | -- | To get the records of 'Executed'. 243 | records :: Executed n m r -> [r] 244 | records (Executed Data.Executed { records }) = records 245 | 246 | -- | This represents a result of a "Execute" message which is not yet processed by a server. 247 | newtype ExecutedProcedure (parameterLength :: Nat) (resultLength :: Nat) r = 248 | ExecutedProcedure (Data.ExecutedProcedure r) 249 | deriving newtype (Show, Message) 250 | 251 | type instance MessageResult (ExecutedProcedure n m r) = (PreparedStatement n m, Portal n m, Executed n m r, Maybe ErrorFields) -- TODO don't error fields themselves 252 | 253 | -- | This means that @r@ has a 'name' accesser. 254 | class HasName r where 255 | -- | Type of name of @r@. 256 | type Name r :: Type 257 | 258 | -- | To get a name of @r@. 259 | name :: r -> Name r 260 | default name :: HasField "name" r (Name r) => r -> Name r 261 | name = getField @"name" 262 | 263 | instance HasName (PreparedStatement n m) where 264 | type Name (PreparedStatement n m) = PreparedStatementName 265 | 266 | instance HasName (PreparedStatementProcedure n m) where 267 | type Name (PreparedStatementProcedure n m) = PreparedStatementName 268 | 269 | instance HasName (Portal n m) where 270 | type Name (Portal n m) = PortalName 271 | 272 | instance HasName (PortalProcedure n m) where 273 | type Name (PortalProcedure n m) = PortalName 274 | 275 | -- | This means that @r@ has a 'parameterOids' accesser. 276 | class HasParameterOids r a where 277 | -- | To get OIDs of a parameter. 278 | parameterOids :: r -> a 279 | default parameterOids :: HasField "parameterOids" r a => r -> a 280 | parameterOids = getField @"parameterOids" 281 | 282 | instance (oids ~ Homotuple n Oid, Item oids ~ Oid, IsList oids) => HasParameterOids (PreparedStatement n m) oids 283 | 284 | instance (oids ~ Homotuple n Oid, Item oids ~ Oid, IsList oids) => HasParameterOids (PreparedStatementProcedure n m) (Maybe oids) 285 | 286 | -- Values 287 | 288 | -- | To get the procedure to build the message of parsing SQL query and to parse its response. 289 | parse 290 | :: forall plen rlen. 291 | ( KnownNat plen 292 | , KnownNat rlen 293 | , IsHomotupleItem plen Oid 294 | , IsHomotupleItem rlen ColumnInfo 295 | , IsHomotupleItem rlen Oid 296 | , IsHomolisttuple rlen Oid 297 | , IsHomolisttuple plen Oid 298 | , IsHomolisttuple rlen ColumnInfo 299 | ) 300 | => PreparedStatementName -- ^ A new name of prepared statement. 301 | -> Query -- ^ SQL whose placeoholder style is dollar style. 302 | -> Maybe (Homotuple plen Oid, Homotuple rlen Oid) -- ^ On 'Nothing' an additional pair of a request and a resposne is necessary. 303 | -- If concrete OIDs are given, it will be pass over. 304 | -> PreparedStatementProcedure plen rlen 305 | parse name query oids = 306 | let 307 | lensOrOids = 308 | case oids of 309 | Nothing -> Left (fromInteger $ natVal (Proxy :: Proxy plen), fromInteger $ natVal (Proxy :: Proxy rlen)) 310 | Just v -> Right $ bimap toList toList v 311 | in 312 | PreparedStatementProcedure $ Query.parse name query lensOrOids 313 | 314 | -- | This means that @ps@ is a objective of 'bind'. 315 | class Bind ps where 316 | -- | To get the procedure to build the message of binding the parameter and to parse its response. 317 | bind 318 | :: forall rlen param m. 319 | ( ToRecord param 320 | , KnownNat rlen 321 | , Tuple.HasLength (Homotuple rlen ColumnInfo) 322 | , MonadFail m 323 | ) 324 | => PortalName -- ^ A new name of portal. 325 | -> FormatCode -- ^ Binary format or text format for the parameter. 326 | -> FormatCode -- ^ Binary format or text format for the results. 327 | -> BackendParameters -- ^ The set of the server parameters. 328 | -> StringEncoder -- ^ How to encode strings. 329 | -> param -- ^ Parameter for this query. 330 | -> ps (Length param) rlen -- ^ Prepared statement. 331 | -> m (PortalProcedure (Length param) rlen) 332 | 333 | instance Bind PreparedStatement where 334 | bind 335 | :: forall rlen param m. 336 | ( ToRecord param 337 | , Tuple.HasLength (Homotuple rlen ColumnInfo) 338 | , MonadFail m 339 | ) 340 | => PortalName -> FormatCode -> FormatCode -> BackendParameters -> StringEncoder -> param -> PreparedStatement (Length param) rlen -> m (PortalProcedure (Length param) rlen) 341 | bind name parameterFormat resultFormat backendParams encode parameters (PreparedStatement ps) = PortalProcedure <$> Query.bind name parameterFormat resultFormat backendParams encode parameters ps 342 | 343 | instance Bind PreparedStatementProcedure where 344 | bind 345 | :: forall rlen param m. 346 | ( ToRecord param 347 | , KnownNat rlen 348 | , MonadFail m 349 | ) 350 | => PortalName -> FormatCode -> FormatCode -> BackendParameters -> StringEncoder -> param -> PreparedStatementProcedure (Length param) rlen -> m (PortalProcedure (Length param) rlen) 351 | bind name parameterFormat resultFormat backendParams encode parameters (PreparedStatementProcedure psProc) = PortalProcedure <$> Query.bind name parameterFormat resultFormat backendParams encode parameters psProc 352 | 353 | -- | This means that @p@ is a objective of 'execute'. 354 | class Execute p where 355 | -- | To get the procedure to build the message of execution and to parse its response. 356 | execute 357 | :: forall plen result. 358 | ( FromRecord result 359 | , IsHomotupleItem (Length result) ColumnInfo 360 | , IsHomolisttuple (Length result) ColumnInfo 361 | ) 362 | => Word -- ^ How many records to get. "0" means unlimited. 363 | -> StringDecoder -- ^ How to decode strings. 364 | -> p plen (Length result) -- ^ Portal. 365 | -> ExecutedProcedure plen (Length result) result 366 | 367 | instance Execute Portal where 368 | execute rowLimit decode (Portal p) = ExecutedProcedure $ Query.execute rowLimit decode p 369 | 370 | instance Execute PortalProcedure where 371 | execute rowLimit decode (PortalProcedure pProc) = ExecutedProcedure $ Query.execute rowLimit decode pProc 372 | 373 | -- | To send @BEGIN@ SQL statement. 374 | begin :: ExecutedProcedure 0 0 () 375 | begin = ExecutedProcedure Query.begin 376 | 377 | -- | To send @COMMIT@ SQL statement. 378 | commit :: ExecutedProcedure 0 0 () 379 | commit = ExecutedProcedure Query.commit 380 | 381 | -- | To send @ROLLBACK@ SQL statement. 382 | rollback :: ExecutedProcedure 0 0 () 383 | rollback = ExecutedProcedure Query.rollback 384 | -------------------------------------------------------------------------------- /src/Database/PostgreSQL/Pure/Internal/Connection.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE NamedFieldPuns #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | module Database.PostgreSQL.Pure.Internal.Connection 6 | ( connect 7 | , disconnect 8 | , withConnection 9 | ) where 10 | 11 | import qualified Database.PostgreSQL.Pure.Internal.Builder as Builder 12 | import Database.PostgreSQL.Pure.Internal.Data (Address (AddressNotResolved, AddressResolved), 13 | AuthenticationMD5Password (AuthenticationMD5Password), 14 | AuthenticationResponse (AuthenticationCleartextPasswordResponse, AuthenticationMD5PasswordResponse, AuthenticationOkResponse), 15 | BackendKey, BackendKeyData (BackendKeyData), 16 | BackendParameters, Buffer (Buffer), 17 | Config (Config, address, database, password, receptionBufferSize, sendingBufferSize, user), 18 | Connection (Connection, config, receptionBuffer, sendingBuffer, socket), 19 | ParameterStatus (ParameterStatus), Pid, 20 | ReadyForQuery (ReadyForQuery), Salt, 21 | TransactionState (Idle)) 22 | import qualified Database.PostgreSQL.Pure.Internal.Exception as Exception 23 | import qualified Database.PostgreSQL.Pure.Internal.Parser as Parser 24 | import Database.PostgreSQL.Pure.Internal.SocketIO (SocketIO, buildAndSend, receive, runSocketIO, send) 25 | 26 | import Control.Exception.Safe (assert, bracket) 27 | import Control.Monad (void) 28 | import Control.Monad.Reader (ask) 29 | import qualified Data.Attoparsec.ByteString as AP 30 | import qualified Data.ByteString as BS 31 | import qualified Data.ByteString.Base16 as B16 32 | import qualified Data.ByteString.Internal as BSI 33 | import qualified Data.ByteString.UTF8 as BSU 34 | import qualified Data.Map.Strict as Map 35 | import qualified Network.Socket as NS 36 | 37 | #ifdef PURE_MD5 38 | import qualified Data.Digest.Pure.MD5 as MD5 39 | #else 40 | import qualified Crypto.Hash.MD5 as MD5 41 | #endif 42 | 43 | -- | Bracket function for a connection. 44 | withConnection :: Config -> (Connection -> IO a) -> IO a 45 | withConnection config@Config { address } f = 46 | Exception.convert $ do 47 | addr <- 48 | case address of 49 | AddressResolved a -> pure $ addrInfo a 50 | AddressNotResolved h s -> resolve h s 51 | bracket (open addr) NS.close $ \sock -> do 52 | conn <- connect' sock config 53 | f conn 54 | 55 | -- | To connect to the server. 56 | connect :: Config -> IO Connection 57 | connect config@Config { address } = 58 | Exception.convert $ do 59 | addr <- 60 | case address of 61 | AddressResolved a -> pure $ addrInfo a 62 | AddressNotResolved h s -> resolve h s 63 | sock <- open addr 64 | connect' sock config 65 | 66 | connect' :: NS.Socket -> Config -> IO Connection 67 | connect' sock config@Config { sendingBufferSize, receptionBufferSize } = do 68 | sBuff <- flip Buffer sendingBufferSize <$> BSI.mallocByteString sendingBufferSize 69 | rBuff <- flip Buffer receptionBufferSize <$> BSI.mallocByteString receptionBufferSize 70 | runSocketIO sock sBuff rBuff config initializeConnection 71 | 72 | -- | To disconnect to the server. 73 | disconnect :: Connection -> IO () 74 | disconnect Connection { socket, sendingBuffer, receptionBuffer, config } = 75 | Exception.convert $ do 76 | runSocketIO socket sendingBuffer receptionBuffer config terminate 77 | NS.close socket 78 | 79 | addrInfoHints :: NS.AddrInfo 80 | addrInfoHints = 81 | NS.defaultHints 82 | { NS.addrSocketType = NS.Stream 83 | , NS.addrProtocol = 6 -- TCP 84 | , NS.addrFlags = [NS.AI_ADDRCONFIG] 85 | } 86 | 87 | addrInfo :: NS.SockAddr -> NS.AddrInfo 88 | addrInfo address = 89 | addrInfoHints 90 | { NS.addrAddress = address 91 | , NS.addrFamily = 92 | case address of 93 | NS.SockAddrInet {} -> NS.AF_INET 94 | NS.SockAddrInet6 {} -> NS.AF_INET6 95 | NS.SockAddrUnix {} -> NS.AF_UNIX 96 | #if !MIN_VERSION_network(3,0,0) 97 | _ -> NS.AF_UNSPEC 98 | #endif 99 | } 100 | 101 | resolve :: NS.HostName -> NS.ServiceName -> IO NS.AddrInfo 102 | resolve host service = do 103 | addrs <- NS.getAddrInfo (Just addrInfoHints) (Just host) (Just service) 104 | case addrs of 105 | addr:_ -> return addr 106 | [] -> Exception.cantReachHere 107 | 108 | open :: NS.AddrInfo -> IO NS.Socket 109 | open addr = do 110 | sock <- NS.socket (NS.addrFamily addr) (NS.addrSocketType addr) (NS.addrProtocol addr) 111 | NS.connect sock $ NS.addrAddress addr 112 | return sock 113 | 114 | initializeConnection :: SocketIO Connection 115 | initializeConnection = do 116 | response <- startup 117 | (bps, pid, bk) <- authenticate response 118 | (sock, sBuff, rBuff, config) <- ask 119 | pure $ Connection sock pid bk bps sBuff rBuff config 120 | 121 | startup :: SocketIO AuthenticationResponse 122 | startup = do 123 | (_, _, _, Config { user, database }) <- ask 124 | buildAndSend $ Builder.startup user database 125 | receive Parser.authentication 126 | 127 | authenticate :: AuthenticationResponse -> SocketIO (BackendParameters, Pid, BackendKey) 128 | authenticate response = do 129 | (_, _, _, Config { user, password }) <- ask 130 | case response of 131 | AuthenticationOkResponse -> pure () 132 | AuthenticationCleartextPasswordResponse -> auth $ BSU.fromString password 133 | AuthenticationMD5PasswordResponse (AuthenticationMD5Password salt) -> auth $ hashMD5 user password salt 134 | (bps, pid, bk) <- 135 | receive $ do 136 | bps <- Map.fromList . ((\(ParameterStatus k v) -> (k, v)) <$>) <$> AP.many' Parser.parameterStatus 137 | BackendKeyData pid bk <- Parser.backendKeyData 138 | ReadyForQuery ts <- Parser.readyForQuery 139 | assert (ts == Idle) $ pure (bps, pid, bk) 140 | pure (bps, pid, bk) 141 | where 142 | auth pw = do 143 | buildAndSend $ Builder.password pw 144 | void $ receive Parser.authenticationOk 145 | 146 | terminate :: SocketIO () 147 | terminate = send Builder.terminate 148 | 149 | hashMD5 :: String -> String -> Salt -> BS.ByteString 150 | hashMD5 user password salt = 151 | let 152 | user' = BSU.fromString user 153 | password' = BSU.fromString password 154 | #ifdef PURE_MD5 155 | hash = B16.encode . MD5.md5DigestBytes . MD5.hash' 156 | #else 157 | hash = B16.encode . MD5.hash 158 | #endif 159 | in 160 | "md5" <> hash (hash (password' <> user') <> salt) 161 | -------------------------------------------------------------------------------- /src/Database/PostgreSQL/Pure/Internal/Exception.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification #-} 2 | {-# LANGUAGE NamedFieldPuns #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | module Database.PostgreSQL.Pure.Internal.Exception 6 | ( Exception (..) 7 | , ErrorResponse (..) 8 | , ResponseParsingFailed (..) 9 | , InternalException (..) 10 | , convert 11 | , cantReachHere 12 | ) where 13 | 14 | import Database.PostgreSQL.Pure.Internal.Data (ErrorFields (ErrorFields), Pretty (pretty), TransactionState) 15 | 16 | import Control.Exception.Safe (displayException, fromException, throw, toException, try) 17 | import qualified Control.Exception.Safe as E 18 | import qualified Data.ByteString as BS 19 | import qualified Data.ByteString.Short as BSS 20 | import qualified Data.ByteString.UTF8 as BSU 21 | import Data.Typeable (Typeable, cast) 22 | import GHC.Stack (HasCallStack) 23 | 24 | -- | Root exception. 25 | -- 26 | -- @ 27 | -- 'Exception' 28 | -- ├ 'ErrorResponse' 29 | -- └ 'ResponseParsingFailed' 30 | -- @ 31 | data Exception = forall e. E.Exception e => Exception e deriving (Typeable) 32 | 33 | instance Show Exception where 34 | show (Exception e) = show e 35 | 36 | instance E.Exception Exception where 37 | displayException (Exception e) = displayException e 38 | 39 | -- | This means that the server responds an error. 40 | data ErrorResponse = 41 | ErrorResponse { severity :: BS.ByteString, code :: BS.ByteString, message :: BS.ByteString, transactionState :: Maybe TransactionState } 42 | deriving (Show, Read, Eq, Typeable) 43 | 44 | instance E.Exception ErrorResponse where 45 | toException = toException . Exception 46 | fromException = ((\(Exception e) -> cast e) =<<) . fromException 47 | displayException = pretty 48 | 49 | instance Pretty ErrorResponse where 50 | pretty ErrorResponse { severity, code, message, transactionState } = 51 | "error response:\n" 52 | <> "\tseverity: " <> BSU.toString severity -- only supports UTF-8 53 | <> "\n\tcode: " <> BSU.toString code 54 | <> "\n\tmessage: " <> BSU.toString message 55 | <> case transactionState of 56 | Just ts -> "\n\ttransaction state: " <> pretty ts 57 | Nothing -> mempty 58 | 59 | -- | This means that the server responds an unknown message. 60 | newtype ResponseParsingFailed = 61 | ResponseParsingFailed { causedBy :: String } 62 | deriving (Show, Typeable) 63 | 64 | instance E.Exception ResponseParsingFailed where 65 | toException = toException . Exception 66 | fromException = ((\(Exception e) -> cast e) =<<) . fromException 67 | displayException = pretty 68 | 69 | instance Pretty ResponseParsingFailed where 70 | pretty (ResponseParsingFailed c) = "response parsing failed:\n\tcaused by " <> c 71 | 72 | data InternalException 73 | = InternalResponseParsingFailed String BS.ByteString 74 | | InternalErrorResponse ErrorFields (Maybe TransactionState) BS.ByteString 75 | | InternalExtraData BS.ByteString 76 | deriving (Show, Read, Eq, Typeable) 77 | 78 | instance E.Exception InternalException 79 | 80 | internalExcepionToExposedException :: InternalException -> Exception 81 | internalExcepionToExposedException e@InternalResponseParsingFailed {} = Exception $ ResponseParsingFailed $ displayException e 82 | internalExcepionToExposedException (InternalErrorResponse (ErrorFields fields) transactionState _) = 83 | Exception ErrorResponse { severity, code, message, transactionState } 84 | where 85 | (severity, code, message) = map3 BSS.fromShort $ foldr go ("", "", "") fields 86 | go ('S', largeS) (_, largeC, largeM) = (largeS, largeC, largeM) 87 | go ('C', largeC) (largeS, _, largeM) = (largeS, largeC, largeM) 88 | go ('M', largeM) (largeS, largeC, _) = (largeS, largeC, largeM) 89 | go _ a = a 90 | map3 f (v1, v2, v3) = (f v1, f v2, f v3) 91 | internalExcepionToExposedException e@InternalExtraData {} = Exception $ ResponseParsingFailed $ displayException e 92 | 93 | convert :: IO a -> IO a 94 | convert a = do 95 | r <- try a 96 | case r of 97 | Right r -> pure r 98 | Left e -> throw $ internalExcepionToExposedException e 99 | 100 | cantReachHere :: HasCallStack => a 101 | cantReachHere = error "can't reach here" 102 | -------------------------------------------------------------------------------- /src/Database/PostgreSQL/Pure/Internal/MonadFail.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | 3 | {-# OPTIONS_GHC -Wno-orphans #-} 4 | 5 | module Database.PostgreSQL.Pure.Internal.MonadFail 6 | ( fromEither 7 | ) where 8 | 9 | import Prelude (Either (Left, Right), String, pure) 10 | 11 | import Control.Monad.Fail (MonadFail (fail)) 12 | 13 | instance MonadFail (Either String) where 14 | fail = Left 15 | 16 | fromEither :: MonadFail m => Either String a -> m a 17 | fromEither (Right a) = pure a 18 | fromEither (Left e) = fail e 19 | -------------------------------------------------------------------------------- /src/Database/PostgreSQL/Pure/Internal/Query.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE DefaultSignatures #-} 4 | {-# LANGUAGE DerivingStrategies #-} 5 | {-# LANGUAGE DuplicateRecordFields #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE NamedFieldPuns #-} 8 | {-# LANGUAGE OverloadedLabels #-} 9 | {-# LANGUAGE OverloadedStrings #-} 10 | {-# LANGUAGE ScopedTypeVariables #-} 11 | {-# LANGUAGE TypeApplications #-} 12 | {-# LANGUAGE TypeFamilies #-} 13 | 14 | module Database.PostgreSQL.Pure.Internal.Query 15 | ( -- * Extended Query 16 | parse 17 | , Bind (..) 18 | , Execute (..) 19 | , flush 20 | , sync 21 | , Message (..) 22 | , Close (..) 23 | -- * Transaction 24 | , begin 25 | , commit 26 | , rollback 27 | ) where 28 | 29 | import qualified Database.PostgreSQL.Pure.Internal.Builder as Builder 30 | import Database.PostgreSQL.Pure.Internal.Data (BackendParameters, 31 | BindParameterFormatCodes (BindParameterFormatCodesAll), 32 | BindResultFormatCodes (BindResultFormatCodesEach), 33 | CloseProcedure (CloseProcedure), 34 | ColumnInfo (ColumnInfo, formatCode), 35 | CommandComplete (CommandComplete), 36 | Connection (Connection, config, receptionBuffer, sendingBuffer, socket), 37 | DataRow (DataRow), ErrorFields, 38 | ExecuteResult (ExecuteComplete, ExecuteEmptyQuery, ExecuteSuspended), 39 | Executed (Executed), 40 | ExecutedProcedure (ExecutedProcedure), 41 | FormatCode (BinaryFormat), FromRecord, MessageResult, 42 | Notice (Notice), Oid, 43 | ParameterDescription (ParameterDescription), 44 | Portal (Portal), PortalName, 45 | PortalProcedure (PortalProcedure), 46 | PreparedStatement (PreparedStatement), 47 | PreparedStatementName, 48 | PreparedStatementProcedure (PreparedStatementProcedure), 49 | Query, ReadyForQuery (ReadyForQuery), 50 | RowDescription (RowDescription), StringDecoder, 51 | StringEncoder, ToRecord (toRecord), TransactionState, 52 | TypeLength (FixedLength)) 53 | import qualified Database.PostgreSQL.Pure.Internal.Data as Data 54 | import qualified Database.PostgreSQL.Pure.Internal.Exception as Exception 55 | import qualified Database.PostgreSQL.Pure.Internal.Parser as Parser 56 | import Database.PostgreSQL.Pure.Internal.SocketIO (buildAndSend, receive, runSocketIO, send) 57 | 58 | import Control.Applicative ((<|>)) 59 | import Control.Exception.Safe (throw, try) 60 | import Control.Monad (void, when) 61 | import Control.Monad.State.Strict (put) 62 | import qualified Data.Attoparsec.ByteString as AP 63 | import qualified Data.Attoparsec.Combinator as AP 64 | import qualified Data.ByteString.Builder as BSB 65 | import qualified Data.ByteString.Char8 as BSC 66 | import Data.Functor (($>)) 67 | import Data.List (genericLength) 68 | import GHC.Records (HasField (getField)) 69 | 70 | #if !MIN_VERSION_base(4,13,0) 71 | import Control.Monad.Fail (MonadFail) 72 | #endif 73 | 74 | -- | To get the procedure to build the message of parsing SQL query and to parse its response. 75 | parse 76 | :: PreparedStatementName -- ^ A new name of prepared statement. 77 | -> Query -- ^ SQL whose placeoholder style is dollar style. 78 | -> Either (Word, Word) ([Oid], [Oid]) -- ^ A pair of the number of columns of the parameter and the result, 79 | -- or a pair of the list of OIDs of the parameter and the result. 80 | -- On 'Left' an additional pair of a request and a resposne is necessary. 81 | -> PreparedStatementProcedure 82 | parse name query (Left (parameterLength, resultLength)) = parse' name query parameterLength resultLength Nothing 83 | parse name query (Right oids@(parameterOids, resultOids)) = parse' name query (genericLength parameterOids) (genericLength resultOids) (Just oids) 84 | 85 | parse' :: PreparedStatementName -> Query -> Word -> Word -> Maybe ([Oid], [Oid]) -> PreparedStatementProcedure 86 | parse' name query parameterLength resultLength oids = 87 | let 88 | inaneColumnInfo oid = ColumnInfo "" 0 0 oid (FixedLength 0) 0 BinaryFormat 89 | parameterOids = fst <$> oids 90 | builder = 91 | case oids of 92 | Just (parameterOids, _) -> Builder.parse name query parameterOids 93 | _ -> Builder.parse name query [] <> Builder.describePreparedStatement name 94 | parser = do 95 | Parser.parseComplete 96 | (parameterOids, resultInfos) <- 97 | case oids of 98 | Just (parameterOids, resultOids) -> pure (parameterOids, inaneColumnInfo <$> resultOids) 99 | _ -> do 100 | ParameterDescription parameterOids <- Parser.parameterDescription 101 | resultInfos <- 102 | AP.choice 103 | [ do 104 | RowDescription infos <- Parser.rowDescription 105 | pure infos 106 | , Parser.noData $> [] 107 | ] 108 | pure (parameterOids, resultInfos) 109 | pure $ PreparedStatement name parameterOids resultInfos 110 | in PreparedStatementProcedure name parameterLength resultLength parameterOids builder parser 111 | 112 | -- | This means that @ps@ is a objective of 'bind'. 113 | class Bind ps where 114 | -- | To get the procedure to build the message of binding the parameter and to parse its response. 115 | bind 116 | :: (ToRecord param, MonadFail m) 117 | => PortalName -- ^ A new name of portal. 118 | -> FormatCode -- ^ Binary format or text format for the parameter. 119 | -> FormatCode -- ^ Binary format or text format for the results. 120 | -> BackendParameters -- ^ The set of the server parameters. 121 | -> StringEncoder -- ^ How to encode strings. 122 | -> param -- ^ Parameter for this query. 123 | -> ps -- ^ Prepared statement. 124 | -> m PortalProcedure 125 | 126 | instance Bind PreparedStatement where 127 | bind name parameterFormat resultFormat backendParams encode parameters ps@(PreparedStatement psName psParameterOids psResultInfos) = do 128 | record <- toRecord backendParams encode (Just psParameterOids) (replicate (length psParameterOids) parameterFormat) parameters 129 | let 130 | builder = Builder.bind name psName (BindParameterFormatCodesAll parameterFormat) record (BindResultFormatCodesEach $ replicate (length psResultInfos) resultFormat) 131 | parser = do 132 | Parser.bindComplete 133 | pure (ps, Portal name ((\i -> i { formatCode = resultFormat }) <$> psResultInfos) ps) 134 | pure $ PortalProcedure name resultFormat builder parser 135 | 136 | instance Bind PreparedStatementProcedure where 137 | bind name parameterFormat resultFormat backendParams encode parameters (PreparedStatementProcedure psName psParameterLength psResultLength psParameterOids psBuilder psParser) = do 138 | record <- toRecord backendParams encode psParameterOids (replicate (fromIntegral psParameterLength) parameterFormat) parameters 139 | let 140 | builder = 141 | psBuilder 142 | <> Builder.bind name psName (BindParameterFormatCodesAll parameterFormat) record (BindResultFormatCodesEach $ replicate (fromIntegral psResultLength) resultFormat) 143 | parser = do 144 | ps@PreparedStatement { resultInfos } <- psParser 145 | Parser.bindComplete 146 | pure (ps, Portal name ((\i -> i { formatCode = resultFormat }) <$> resultInfos) ps) 147 | pure $ PortalProcedure name resultFormat builder parser 148 | 149 | -- | This means that @p@ is a objective of 'execute'. 150 | class Execute p where 151 | -- | To get the procedure to build the message of execution and to parse its response. 152 | execute 153 | :: FromRecord result 154 | => Word -- ^ How many records to get. “0” means unlimited. 155 | -> StringDecoder -- ^ How to decode strings. 156 | -> p -- ^ Portal. 157 | -> ExecutedProcedure result 158 | 159 | instance Execute Portal where 160 | execute rowLimit decode p@(Portal pName pInfos ps@PreparedStatement {}) = 161 | let 162 | builder = Builder.execute pName $ fromIntegral rowLimit 163 | parser = executeParser ps p pInfos decode 164 | in ExecutedProcedure builder parser 165 | 166 | instance Execute PortalProcedure where 167 | execute rowLimit decode (PortalProcedure pName pFormat pBuilder pParser) = 168 | let 169 | builder = pBuilder <> Builder.execute pName (fromIntegral rowLimit) 170 | parser = do 171 | (ps@(PreparedStatement _ _ psInfos), p) <- pParser 172 | executeParser ps p ((\i -> i { formatCode = pFormat }) <$> psInfos) decode 173 | in ExecutedProcedure builder parser 174 | 175 | executeParser :: forall r. FromRecord r => PreparedStatement -> Portal -> [ColumnInfo] -> StringDecoder -> AP.Parser (PreparedStatement, Portal, Executed r, Maybe ErrorFields) 176 | executeParser ps p infos decode = do 177 | records <- ((\(DataRow d) -> d) <$>) <$> AP.many' (Parser.dataRow decode infos) 178 | when (null records) $ do 179 | -- detect whether no "data row" responses or value parsing failure 180 | r <- AP.option False $ AP.lookAhead Parser.dataRowRaw >> pure True 181 | when r $ do 182 | -- get detailed error 183 | void (Parser.dataRow decode infos :: AP.Parser (DataRow r)) 184 | fail "can't reach here" 185 | err <- AP.option Nothing $ (\(Notice err) -> Just err) <$> Parser.notice 186 | result <- 187 | ((\(CommandComplete tag) -> ExecuteComplete tag) <$> Parser.commandComplete) 188 | <|> (Parser.emptyQuery >> pure ExecuteEmptyQuery) 189 | <|> (Parser.portalSuspended >> pure ExecuteSuspended) 190 | pure (ps, p, Executed result records p, err) 191 | 192 | -- | This means that @p@ is a objective of 'close'. 193 | class Close p where 194 | -- | To build and send the “Close” message and to receive and parse its response. 195 | close :: p -> CloseProcedure 196 | 197 | instance Close PreparedStatement where 198 | close p = CloseProcedure (Builder.closePreparedStatement $ getField @"name" p) Parser.closeComplete 199 | 200 | instance Close Portal where 201 | close p = CloseProcedure (Builder.closePortal $ getField @"name" p) Parser.closeComplete 202 | 203 | -- | This means that @r@ is a objective of 'flush' and 'sync'. 204 | class Message m where 205 | builder :: m -> BSB.Builder 206 | default builder :: HasField "builder" m BSB.Builder => m -> BSB.Builder 207 | builder = getField @"builder" 208 | 209 | parser :: m -> AP.Parser (MessageResult m) 210 | default parser :: HasField "parser" m (AP.Parser (MessageResult m)) => m -> AP.Parser (MessageResult m) 211 | parser = getField @"parser" 212 | 213 | instance Message PreparedStatementProcedure 214 | 215 | instance Message PortalProcedure 216 | 217 | instance Message (ExecutedProcedure r) 218 | 219 | instance Message CloseProcedure 220 | 221 | instance Message () where 222 | builder _ = mempty 223 | parser _ = pure () 224 | 225 | type instance MessageResult () = () 226 | 227 | instance (Message m0, Message m1) => Message (m0, m1) where 228 | builder (m0, m1) = builder m0 <> builder m1 229 | parser (m0, m1) = (,) <$> parser m0 <*> parser m1 230 | 231 | type instance MessageResult (m0, m1) = (MessageResult m0, MessageResult m1) 232 | 233 | instance (Message m0, Message m1, Message m2) => Message (m0, m1, m2) where 234 | builder (m0, m1, m2) = builder m0 <> builder m1 <> builder m2 235 | parser (m0, m1, m2) = (,,) <$> parser m0 <*> parser m1 <*> parser m2 236 | 237 | type instance MessageResult (m0, m1, m2) = (MessageResult m0, MessageResult m1, MessageResult m2) 238 | 239 | instance (Message m0, Message m1, Message m2, Message m3) => Message (m0, m1, m2, m3) where 240 | builder (m0, m1, m2, m3) = builder m0 <> builder m1 <> builder m2 <> builder m3 241 | parser (m0, m1, m2, m3) = (,,,) <$> parser m0 <*> parser m1 <*> parser m2 <*> parser m3 242 | 243 | type instance MessageResult (m0, m1, m2, m3) = (MessageResult m0, MessageResult m1, MessageResult m2, MessageResult m3) 244 | 245 | instance Message m => Message [m] where 246 | builder = mconcat . (builder <$>) 247 | parser = sequence . (parser <$>) 248 | 249 | type instance MessageResult [m] = [MessageResult m] 250 | 251 | -- | To build and send the given message and a “Flush” message and to receive and parse those responses. 252 | flush :: Message m => Connection -> m -> IO (MessageResult m) 253 | flush Connection { socket, sendingBuffer, receptionBuffer, config } m = 254 | Exception.convert $ 255 | runSocketIO socket sendingBuffer receptionBuffer config $ do 256 | r <- try $ do 257 | buildAndSend $ builder m <> BSB.byteString Builder.flush 258 | receive $ parser m 259 | case r of 260 | Right r -> pure r 261 | Left (Exception.InternalErrorResponse fields _ _) -> do 262 | ReadyForQuery ts <- do 263 | put mempty 264 | send Builder.sync 265 | receive Parser.readyForQuery 266 | throw $ Exception.InternalErrorResponse fields (Just ts) mempty 267 | Left e -> throw e 268 | 269 | -- | To build and send the given message and a “Sync” message and to receive and parse those responses. 270 | sync :: Message m => Connection -> m -> IO (MessageResult m, TransactionState) 271 | sync Connection { socket, sendingBuffer, receptionBuffer, config } m = 272 | Exception.convert $ 273 | runSocketIO socket sendingBuffer receptionBuffer config $ do 274 | r <- 275 | try $ do 276 | buildAndSend $ builder m <> BSB.byteString Builder.sync 277 | (r, ReadyForQuery ts) <- receive $ (,) <$> parser m <*> Parser.readyForQuery 278 | pure (r, ts) 279 | case r of 280 | Right r -> pure r 281 | Left (Exception.InternalErrorResponse fields _ rest) -> do 282 | put rest 283 | ReadyForQuery ts <- receive Parser.readyForQuery 284 | throw $ Exception.InternalErrorResponse fields (Just ts) mempty 285 | Left e -> throw e 286 | 287 | -- | To send @BEGIN@ SQL statement. 288 | begin :: ExecutedProcedure () 289 | begin = transact "BEGIN" 290 | 291 | -- | To send @COMMIT@ SQL statement. 292 | commit :: ExecutedProcedure () 293 | commit = transact "COMMIT" 294 | 295 | -- | To send @ROLLBACK@ SQL statement. 296 | rollback :: ExecutedProcedure () 297 | rollback = transact "ROLLBACK" 298 | 299 | transact :: Query -> ExecutedProcedure () 300 | transact q = 301 | let 302 | psProc = parse "" q (Right ([], [])) 303 | in 304 | case bind "" BinaryFormat BinaryFormat mempty (pure . BSC.pack) () psProc of -- mempty (backend parameters) and BSC.pack (string encoder) are not used. 305 | Right pProc -> execute 1 (pure . BSC.unpack) pProc 306 | Left err -> error err 307 | -------------------------------------------------------------------------------- /src/Database/PostgreSQL/Pure/Internal/SocketIO.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | module Database.PostgreSQL.Pure.Internal.SocketIO 4 | ( SocketIO 5 | , runSocketIO 6 | , send 7 | , buildAndSend 8 | , receive 9 | ) where 10 | 11 | import Database.PostgreSQL.Pure.Internal.Data (Buffer (Buffer), Carry, Config, Error (Error)) 12 | import qualified Database.PostgreSQL.Pure.Internal.Exception as Exception 13 | import qualified Database.PostgreSQL.Pure.Internal.Parser as Parser 14 | 15 | import Control.Concurrent (yield) 16 | import Control.Monad.IO.Class (liftIO) 17 | import Control.Monad.Reader (ReaderT, ask, runReaderT) 18 | import Control.Monad.State.Strict (StateT, get, put, runStateT) 19 | import qualified Data.Attoparsec.ByteString as AP 20 | import qualified Data.ByteString as BS 21 | import qualified Data.ByteString.Builder as BSB 22 | import qualified Data.ByteString.Builder.Extra as BSB 23 | import qualified Data.ByteString.Internal as BSI 24 | import Data.List (intercalate) 25 | import Data.Word (Word8) 26 | import Foreign (ForeignPtr, Ptr, withForeignPtr) 27 | import qualified Network.Socket as NS 28 | import qualified Network.Socket.ByteString as NSB 29 | 30 | #if MIN_VERSION_base(4,13,0) 31 | import Control.Exception.Safe (throw, try) 32 | import Control.Monad (unless) 33 | #else 34 | import Control.Exception.Safe (throw, try, tryJust) 35 | import Control.Monad (guard, unless) 36 | import System.IO.Error (isEOFError) 37 | #endif 38 | 39 | type SocketIO = StateT Carry (ReaderT (NS.Socket, Buffer, Buffer, Config) IO) 40 | 41 | runSocketIO :: NS.Socket -> Buffer -> Buffer -> Config -> SocketIO a -> IO a 42 | runSocketIO s sb rb c m = 43 | flip runReaderT (s, sb, rb, c) $ do 44 | (a, carry) <- runStateT m BS.empty 45 | unless (BS.null carry) $ throw $ Exception.InternalExtraData carry 46 | pure a 47 | 48 | send :: BS.ByteString -> SocketIO () 49 | send message = do 50 | (sock, _, _, _) <- ask 51 | liftIO $ do 52 | NSB.sendAll sock message 53 | yield 54 | 55 | buildAndSend :: BSB.Builder -> SocketIO () 56 | buildAndSend builder = do 57 | (_, Buffer fp len, _, _) <- ask 58 | go fp len $ BSB.runBuilder builder 59 | where 60 | go :: ForeignPtr Word8 -> Int -> BSB.BufferWriter -> SocketIO () 61 | go bfp blen writer = do 62 | (wc, next) <- liftIO $ withForeignPtr bfp $ \ptr -> writer ptr blen 63 | send $ BSI.PS bfp 0 wc 64 | case next of 65 | BSB.Done -> pure () 66 | BSB.More newLen w 67 | | newLen <= blen -> go bfp blen w 68 | | otherwise -> do 69 | newFPtr <- liftIO $ BSI.mallocByteString newLen 70 | go newFPtr newLen w 71 | BSB.Chunk bs w -> do 72 | send bs 73 | go bfp blen w 74 | 75 | recvAndParse :: NS.Socket -> Buffer -> Carry -> AP.Parser response -> IO (response, Carry) 76 | recvAndParse sock (Buffer bfptr blen) carry parser = 77 | withForeignPtr bfptr $ \bptr -> do 78 | let 79 | recv :: IO BS.ByteString 80 | recv = do 81 | len <- recvBuf sock bptr blen 82 | case len of 83 | 0 -> pure BS.empty -- EOF 84 | _ -> pure $ BS.copy $ BSI.PS bfptr 0 len 85 | result <- AP.parseWith recv parser carry 86 | case result of 87 | AP.Done rest response -> pure (response, rest) 88 | AP.Fail rest [] msg -> throw $ Exception.InternalResponseParsingFailed msg rest 89 | AP.Fail rest ctxs msg -> throw $ Exception.InternalResponseParsingFailed (intercalate " > " ctxs <> ": " <> msg) rest 90 | AP.Partial _ -> Exception.cantReachHere 91 | 92 | receiveJust :: AP.Parser response -> SocketIO response 93 | receiveJust parser = do 94 | carry <- get 95 | (sock, _, buff, _) <- ask 96 | (response, carry') <- liftIO $ recvAndParse sock buff carry parser 97 | put carry' 98 | pure response 99 | 100 | receive :: AP.Parser response -> SocketIO response 101 | receive parser = do 102 | r <- try $ receiveJust parser 103 | case r of 104 | Right r -> pure r 105 | Left e@(Exception.InternalResponseParsingFailed _ raw) -> 106 | case AP.parse Parser.skipUntilError raw of 107 | AP.Done rest (Error fields) -> throw $ Exception.InternalErrorResponse fields Nothing rest 108 | AP.Fail {} -> throw e 109 | AP.Partial _ -> throw e 110 | Left e -> throw e 111 | 112 | -- Before network 3.0.0.0, recvBuf raises error on EOF. Otherwise it returns 0 on EOF. 113 | recvBuf :: NS.Socket -> Ptr Word8 -> Int -> IO Int 114 | #if MIN_VERSION_network(3, 0, 0) 115 | recvBuf s ptr nbytes = NS.recvBuf s ptr nbytes 116 | #else 117 | recvBuf s ptr nbytes = do 118 | r <- tryJust (guard . isEOFError) $ NS.recvBuf s ptr nbytes 119 | case r of 120 | Left _ -> pure 0 121 | Right l -> pure l 122 | #endif 123 | -------------------------------------------------------------------------------- /src/Database/PostgreSQL/Pure/List.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DerivingStrategies #-} 3 | {-# LANGUAGE DuplicateRecordFields #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE OverloadedLabels #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | 9 | -- | 10 | -- This is a list interface version of @Database.PostgreSQL.Pure@. 11 | -- 12 | -- = Typical Example 13 | -- 14 | -- Prepare a following table. 15 | -- 16 | -- @ 17 | -- CREATE TABLE person ( 18 | -- id serial PRIMARY KEY, 19 | -- name varchar(255) NOT NULL 20 | -- ); 21 | -- INSERT INTO person (name) VALUES (\'Ada\'); 22 | -- @ 23 | -- 24 | -- You can run like following to get the record whose ID is 1. 25 | -- 26 | -- >>> :set -XOverloadedStrings 27 | -- >>> :set -XFlexibleContexts 28 | -- >>> :set -XTypeApplications 29 | -- >>> 30 | -- >>> import Database.PostgreSQL.Pure.List 31 | -- >>> import Data.Default.Class (def) 32 | -- >>> import Data.Int (Int32) 33 | -- >>> import Data.ByteString (ByteString) 34 | -- >>> import Data.Tuple.Only (Only (Only)) 35 | -- >>> import Data.Maybe (fromMaybe) 36 | -- >>> import System.Environment (lookupEnv) 37 | -- >>> 38 | -- >>> getEnvDef name value = fromMaybe value <$> lookupEnv name 39 | -- >>> 40 | -- >>> host' <- getEnvDef "PURE_HOST" "127.0.0.1" 41 | -- >>> port' <- getEnvDef "PURE_PORT" "5432" 42 | -- >>> user' <- getEnvDef "PURE_USER" "postgres" 43 | -- >>> password' <- getEnvDef "PURE_PASSWORD" "" 44 | -- >>> database' <- getEnvDef "PURE_DATABASE" "postgres" 45 | -- >>> 46 | -- >>> conn <- connect def { address = AddressNotResolved host' port', user = user', password = password', database = database' } 47 | -- >>> preparedStatementProcedure = parse "" "SELECT id, name FROM person WHERE id = $1" (Left (1, 2)) 48 | -- >>> portalProcedure <- bind "" BinaryFormat BinaryFormat (parameters conn) (const $ fail "") (Only (1 :: Int32)) preparedStatementProcedure 49 | -- >>> executedProcedure = execute @_ @(Int32, ByteString) 0 (const $ fail "") portalProcedure 50 | -- >>> ((_, _, e, _), _) <- sync conn executedProcedure 51 | -- >>> records e 52 | -- [(1,"Ada")] 53 | module Database.PostgreSQL.Pure.List 54 | ( -- * Connection 55 | Config (..) 56 | , Connection 57 | , pid 58 | , parameters 59 | , config 60 | , Address (..) 61 | , BackendParameters 62 | , Pid 63 | , withConnection 64 | , connect 65 | , disconnect 66 | -- * Extended Query 67 | , parse 68 | , bind 69 | , execute 70 | , flush 71 | , sync 72 | , close 73 | , PreparedStatement (name, parameterOids, resultInfos) 74 | , PreparedStatementProcedure (name, parameterOids) 75 | , PreparedStatementName (..) 76 | , Portal (name) 77 | , PortalProcedure (name) 78 | , PortalName (..) 79 | , Executed (result, records) 80 | , ExecutedProcedure 81 | , ExecuteResult (..) 82 | , CommandTag (..) 83 | , Query (..) 84 | , FormatCode (..) 85 | , ColumnInfo 86 | , Message 87 | , MessageResult 88 | , Bind 89 | , Execute 90 | , Close 91 | , StringEncoder 92 | , StringDecoder 93 | -- * Transaction 94 | , begin 95 | , commit 96 | , rollback 97 | , TransactionState (..) 98 | -- * Record 99 | , FromField (..) 100 | , FromRecord (..) 101 | , ToField (..) 102 | , ToRecord (..) 103 | , Raw (..) 104 | -- * Exception 105 | , Exception.Exception (..) 106 | , Exception.ErrorResponse (..) 107 | , Exception.ResponseParsingFailed (..) 108 | -- * OID 109 | , Oid 110 | ) where 111 | 112 | import Database.PostgreSQL.Pure.Internal.Connection (connect, disconnect, withConnection) 113 | import Database.PostgreSQL.Pure.Internal.Data (Address (AddressNotResolved, AddressResolved), 114 | BackendParameters, ColumnInfo, 115 | CommandTag (BeginTag, CommitTag, CopyTag, CreateTableTag, DeleteTag, DropTableTag, FetchTag, InsertTag, MoveTag, RollbackTag, SelectTag, UpdateTag), 116 | Config (Config, address, database, password, receptionBufferSize, sendingBufferSize, user), 117 | Connection (config, parameters, pid), 118 | ExecuteResult (ExecuteComplete, ExecuteEmptyQuery, ExecuteSuspended), 119 | Executed, ExecutedProcedure, 120 | FormatCode (BinaryFormat, TextFormat), 121 | FromField (fromField), FromRecord (fromRecord), 122 | MessageResult, Oid, Pid, Portal, PortalName (PortalName), 123 | PortalProcedure, PreparedStatement, 124 | PreparedStatementName (PreparedStatementName), 125 | PreparedStatementProcedure, Query (Query), 126 | Raw (Null, Value), StringDecoder, StringEncoder, 127 | ToField (toField), ToRecord (toRecord), 128 | TransactionState (Block, Failed, Idle)) 129 | import qualified Database.PostgreSQL.Pure.Internal.Data as Data 130 | import qualified Database.PostgreSQL.Pure.Internal.Exception as Exception 131 | import Database.PostgreSQL.Pure.Internal.Query (Bind (bind), Close (close), Execute (execute), Message, 132 | begin, commit, flush, parse, rollback, sync) 133 | -------------------------------------------------------------------------------- /src/Database/PostgreSQL/Pure/Parser.hs: -------------------------------------------------------------------------------- 1 | module Database.PostgreSQL.Pure.Parser 2 | ( column 3 | ) where 4 | 5 | import Database.PostgreSQL.Pure.Internal.Parser (column) 6 | -------------------------------------------------------------------------------- /src/Database/PostgreSQL/Simple/Time/Internal/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, BangPatterns, ScopedTypeVariables #-} 2 | 3 | -- | 4 | -- Module: Database.PostgreSQL.Simple.Time.Internal.Parser 5 | -- Copyright: (c) 2012-2015 Leon P Smith 6 | -- (c) 2015 Bryan O'Sullivan 7 | -- License: BSD3 8 | -- Maintainer: Leon P Smith 9 | -- Stability: experimental 10 | -- 11 | -- Parsers for parsing dates and times. 12 | 13 | module Database.PostgreSQL.Simple.Time.Internal.Parser 14 | ( 15 | day 16 | , localTime 17 | , timeOfDay 18 | , timeZone 19 | , UTCOffsetHMS(..) 20 | , timeZoneHMS 21 | , localToUTCTimeOfDayHMS 22 | , utcTime 23 | , zonedTime 24 | , diffTime 25 | ) where 26 | 27 | import Data.Attoparsec.ByteString.Char8 (Parser, peekChar, anyChar, satisfy, option, digit, isDigit, char, takeWhile1, decimal) 28 | import Data.Bits ((.&.)) 29 | import Data.Char (ord) 30 | import Data.Fixed (Fixed (MkFixed), Pico) 31 | import Data.Int (Int64) 32 | import Data.Maybe (fromMaybe) 33 | import Data.Time.Calendar (Day, fromGregorianValid, addDays) 34 | import Data.Time.Clock (UTCTime(UTCTime), DiffTime, picosecondsToDiffTime) 35 | import qualified Data.ByteString.Char8 as B8 36 | import qualified Data.Time.LocalTime as Local 37 | 38 | #if !MIN_VERSION_base(4,13,0) 39 | import Control.Applicative ((<$>), (<*>), (<*), (*>)) 40 | #endif 41 | 42 | -- | Parse a date of the form @YYYY-MM-DD@. 43 | day :: Parser Day 44 | day = do 45 | y <- decimal <* char '-' 46 | m <- twoDigits <* char '-' 47 | d <- twoDigits 48 | maybe (fail "invalid date") return (fromGregorianValid y m d) 49 | 50 | -- | Parse a two-digit integer (e.g. day of month, hour). 51 | twoDigits :: Parser Int 52 | twoDigits = do 53 | a <- digit 54 | b <- digit 55 | return $! c2d a * 10 + c2d b 56 | 57 | -- | Parse a time of the form @HH:MM[:SS[.SSS]]@. 58 | timeOfDay :: Parser Local.TimeOfDay 59 | timeOfDay = do 60 | h <- twoDigits <* char ':' 61 | m <- twoDigits 62 | mc <- peekChar 63 | s <- case mc of 64 | Just ':' -> anyChar *> seconds 65 | _ -> return 0 66 | if h < 24 && m < 60 && s <= 60 67 | then return (Local.TimeOfDay h m s) 68 | else fail "invalid time" 69 | 70 | -- | Parse a count of seconds, with the integer part being two digits 71 | -- long. 72 | seconds :: Parser Pico 73 | seconds = do 74 | real <- twoDigits 75 | mc <- peekChar 76 | case mc of 77 | Just '.' -> do 78 | t <- anyChar *> takeWhile1 isDigit 79 | return $! parsePicos (fromIntegral real) t 80 | _ -> return $! fromIntegral real 81 | where 82 | parsePicos :: Int64 -> B8.ByteString -> Pico 83 | parsePicos a0 t = toPico (fromIntegral (t' * 10^n)) 84 | where n = max 0 (12 - B8.length t) 85 | t' = B8.foldl' (\a c -> 10 * a + fromIntegral (ord c .&. 15)) a0 86 | (B8.take 12 t) 87 | 88 | -- TODO to check minus values, values which is smaller than an hour and so on 89 | diffTime :: Parser DiffTime 90 | diffTime = do 91 | h <- digits <* char ':' 92 | m <- toInteger <$> twoDigits <* char ':' 93 | MkFixed ps <- seconds 94 | return $ picosecondsToDiffTime $ (h * 60 + m) * 60 * 10 ^ (12 :: Int) + ps 95 | where 96 | digits = 97 | go 0 98 | where 99 | go acc = do 100 | md <- option Nothing $ Just . toInteger . c2d <$> digit 101 | case md of 102 | Just d -> go $ d + acc * 10 103 | Nothing -> return acc 104 | 105 | -- | Parse a time zone, and return 'Nothing' if the offset from UTC is 106 | -- zero. (This makes some speedups possible.) 107 | timeZone :: Parser (Maybe Local.TimeZone) 108 | timeZone = do 109 | ch <- satisfy $ \c -> c == '+' || c == '-' || c == 'Z' 110 | if ch == 'Z' 111 | then return Nothing 112 | else do 113 | h <- twoDigits 114 | mm <- peekChar 115 | m <- case mm of 116 | Just ':' -> anyChar *> twoDigits 117 | _ -> return 0 118 | let off | ch == '-' = negate off0 119 | | otherwise = off0 120 | off0 = h * 60 + m 121 | case () of 122 | _ | off == 0 -> 123 | return Nothing 124 | | h > 23 || m > 59 -> 125 | fail "invalid time zone offset" 126 | | otherwise -> 127 | let !tz = Local.minutesToTimeZone off 128 | in return (Just tz) 129 | 130 | data UTCOffsetHMS = UTCOffsetHMS {-# UNPACK #-} !Int {-# UNPACK #-} !Int {-# UNPACK #-} !Int 131 | 132 | -- | Parse a time zone, and return 'Nothing' if the offset from UTC is 133 | -- zero. (This makes some speedups possible.) 134 | timeZoneHMS :: Parser (Maybe UTCOffsetHMS) 135 | timeZoneHMS = do 136 | ch <- satisfy $ \c -> c == '+' || c == '-' || c == 'Z' 137 | if ch == 'Z' 138 | then return Nothing 139 | else do 140 | h <- twoDigits 141 | m <- maybeTwoDigits 142 | s <- maybeTwoDigits 143 | case () of 144 | _ | h == 0 && m == 0 && s == 0 -> 145 | return Nothing 146 | | h > 23 || m >= 60 || s >= 60 -> 147 | fail "invalid time zone offset" 148 | | otherwise -> 149 | if ch == '+' 150 | then let !tz = UTCOffsetHMS h m s 151 | in return (Just tz) 152 | else let !tz = UTCOffsetHMS (-h) (-m) (-s) 153 | in return (Just tz) 154 | where 155 | maybeTwoDigits = do 156 | ch <- peekChar 157 | case ch of 158 | Just ':' -> anyChar *> twoDigits 159 | _ -> return 0 160 | 161 | localToUTCTimeOfDayHMS :: UTCOffsetHMS -> Local.TimeOfDay -> (Integer, Local.TimeOfDay) 162 | localToUTCTimeOfDayHMS (UTCOffsetHMS dh dm ds) (Local.TimeOfDay h m s) = 163 | (\ !a !b -> (a,b)) dday (Local.TimeOfDay h'' m'' s'') 164 | where 165 | s' = s - fromIntegral ds 166 | (!s'', m') 167 | | s' < 0 = (s' + 60, m - dm - 1) 168 | | s' >= 60 = (s' - 60, m - dm + 1) 169 | | otherwise = (s' , m - dm ) 170 | (!m'', h') 171 | | m' < 0 = (m' + 60, h - dh - 1) 172 | | m' >= 60 = (m' - 60, h - dh + 1) 173 | | otherwise = (m' , h - dh ) 174 | h'' :: Int 175 | dday :: Integer 176 | (!h'', dday) 177 | | h' < 0 = (h' + 24, -1) 178 | | h' >= 24 = (h' - 24, 1) 179 | | otherwise = (h' , 0) 180 | 181 | 182 | -- | Parse a date and time, of the form @YYYY-MM-DD HH:MM:SS@. 183 | -- The space may be replaced with a @T@. The number of seconds may be 184 | -- followed by a fractional component. 185 | localTime :: Parser Local.LocalTime 186 | localTime = Local.LocalTime <$> day <* daySep <*> timeOfDay 187 | where daySep = satisfy (\c -> c == ' ' || c == 'T') 188 | 189 | -- | Behaves as 'zonedTime', but converts any time zone offset into a 190 | -- UTC time. 191 | utcTime :: Parser UTCTime 192 | utcTime = do 193 | (Local.LocalTime d t) <- localTime 194 | mtz <- timeZoneHMS 195 | case mtz of 196 | Nothing -> let !tt = Local.timeOfDayToTime t 197 | in return (UTCTime d tt) 198 | Just tz -> let !(dd,t') = localToUTCTimeOfDayHMS tz t 199 | !d' = addDays dd d 200 | !tt = Local.timeOfDayToTime t' 201 | in return (UTCTime d' tt) 202 | 203 | -- | Parse a date with time zone info. Acceptable formats: 204 | -- 205 | -- @YYYY-MM-DD HH:MM:SS Z@ 206 | -- 207 | -- The first space may instead be a @T@, and the second space is 208 | -- optional. The @Z@ represents UTC. The @Z@ may be replaced with a 209 | -- time zone offset of the form @+0000@ or @-08:00@, where the first 210 | -- two digits are hours, the @:@ is optional and the second two digits 211 | -- (also optional) are minutes. 212 | zonedTime :: Parser Local.ZonedTime 213 | zonedTime = Local.ZonedTime <$> localTime <*> (fromMaybe utc <$> timeZone) 214 | 215 | c2d :: Char -> Int 216 | c2d c = ord c .&. 15 217 | 218 | utc :: Local.TimeZone 219 | utc = Local.TimeZone 0 False "" 220 | 221 | toPico :: Integer -> Pico 222 | toPico = MkFixed 223 | -------------------------------------------------------------------------------- /src/Database/PostgreSQL/Simple/Time/Internal/Printer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns, ViewPatterns #-} 2 | 3 | ------------------------------------------------------------------------------ 4 | -- Module: Database.PostgreSQL.Pure.Time.Internal.Printer 5 | -- Copyright: (c) 2012-2015 Leon P Smith 6 | -- License: BSD3 7 | -- Maintainer: Leon P Smith 8 | -- Stability: experimental 9 | ------------------------------------------------------------------------------ 10 | 11 | module Database.PostgreSQL.Simple.Time.Internal.Printer 12 | ( 13 | day 14 | , timeOfDay 15 | , timeZone 16 | , utcTime 17 | , localTime 18 | , zonedTime 19 | , nominalDiffTime 20 | ) where 21 | 22 | import Control.Arrow ((>>>)) 23 | import Data.ByteString.Builder (Builder, integerDec) 24 | import Data.ByteString.Builder.Prim 25 | ( liftFixedToBounded, (>$<), (>*<) 26 | , BoundedPrim, primBounded, condB, emptyB, FixedPrim, char8, int32Dec) 27 | import Data.Char ( chr ) 28 | import Data.Fixed (Fixed (MkFixed), Pico) 29 | import Data.Int ( Int32, Int64 ) 30 | import Data.Time 31 | ( UTCTime(UTCTime), ZonedTime(ZonedTime), LocalTime(LocalTime), NominalDiffTime 32 | , Day, toGregorian, TimeOfDay(TimeOfDay), timeToTimeOfDay 33 | , TimeZone, timeZoneMinutes ) 34 | import Unsafe.Coerce (unsafeCoerce) 35 | 36 | liftB :: FixedPrim a -> BoundedPrim a 37 | liftB = liftFixedToBounded 38 | 39 | digit :: FixedPrim Int 40 | digit = (\x -> chr (x + 48)) >$< char8 41 | 42 | digits2 :: FixedPrim Int 43 | digits2 = (`quotRem` 10) >$< (digit >*< digit) 44 | 45 | digits3 :: FixedPrim Int 46 | digits3 = (`quotRem` 10) >$< (digits2 >*< digit) 47 | 48 | digits4 :: FixedPrim Int 49 | digits4 = (`quotRem` 10) >$< (digits3 >*< digit) 50 | 51 | frac :: BoundedPrim Int64 52 | frac = condB (== 0) emptyB ((,) '.' >$< (liftB char8 >*< trunc12)) 53 | where 54 | trunc12 :: BoundedPrim Int64 55 | trunc12 = (`quotRem` 1000000) >$< 56 | condB (\(_,y) -> y == 0) 57 | (fst >$< trunc6) 58 | (liftB digits6 >*< trunc6) 59 | 60 | digitB = liftB digit 61 | 62 | digits6 :: FixedPrim Int64 63 | digits6 = (fromIntegral >>> (`quotRem` 10)) >$< (digits5 >*< digit) 64 | digits5 = (`quotRem` 10) >$< (digits4 >*< digit) 65 | 66 | trunc6 :: BoundedPrim Int64 67 | trunc6 = (fromIntegral >>> (`quotRem` 100000)) >$< (digitB >*< trunc5) 68 | trunc5 = condB (== 0) emptyB ((`quotRem` 10000) >$< (digitB >*< trunc4)) 69 | trunc4 = condB (== 0) emptyB ((`quotRem` 1000) >$< (digitB >*< trunc3)) 70 | trunc3 = condB (== 0) emptyB ((`quotRem` 100) >$< (digitB >*< trunc2)) 71 | trunc2 = condB (== 0) emptyB ((`quotRem` 10) >$< (digitB >*< trunc1)) 72 | trunc1 = condB (== 0) emptyB digitB 73 | 74 | 75 | year :: BoundedPrim Int32 76 | year = condB (>= 10000) int32Dec (checkBCE >$< liftB digits4) 77 | where 78 | checkBCE :: Int32 -> Int 79 | checkBCE y 80 | | y > 0 = fromIntegral y 81 | | otherwise = error msg 82 | 83 | msg :: String 84 | msg = "Database.PostgreSQL.Simple.Time.Printer.year: years BCE not supported" 85 | 86 | day :: BoundedPrim Day 87 | day = toYMD >$< (year >*< liftB (char8 >*< digits2 >*< char8 >*< digits2)) 88 | where 89 | toYMD (toGregorian -> (fromIntegral -> !y, !m,!d)) = (y,('-',(m,('-',d)))) 90 | 91 | timeOfDay :: BoundedPrim TimeOfDay 92 | timeOfDay = f >$< (hh_mm_ >*< ss) 93 | where 94 | f (TimeOfDay h m s) = ((h,(':',(m,':'))),s) 95 | 96 | hh_mm_ = liftB (digits2 >*< char8 >*< digits2 >*< char8) 97 | 98 | ss = (\s -> fromIntegral (fromPico s) `quotRem` 1000000000000) >$< 99 | (liftB (fromIntegral >$< digits2) >*< frac) 100 | 101 | timeZone :: BoundedPrim TimeZone 102 | timeZone = timeZoneMinutes >$< tz 103 | where 104 | tz = condB (>= 0) ((,) '+' >$< tzh) ((,) '-' . negate >$< tzh) 105 | 106 | tzh = liftB char8 >*< ((`quotRem` 60) >$< (liftB digits2 >*< tzm)) 107 | 108 | tzm = condB (==0) emptyB ((,) ':' >$< liftB (char8 >*< digits2)) 109 | 110 | utcTime :: BoundedPrim UTCTime 111 | utcTime = f >$< (day >*< liftB char8 >*< timeOfDay >*< liftB char8) 112 | where f (UTCTime d (timeToTimeOfDay -> tod)) = (d,(' ',(tod,'Z'))) 113 | 114 | localTime :: BoundedPrim LocalTime 115 | localTime = f >$< (day >*< liftB char8 >*< timeOfDay) 116 | where f (LocalTime d tod) = (d, (' ', tod)) 117 | 118 | zonedTime :: BoundedPrim ZonedTime 119 | zonedTime = f >$< (localTime >*< timeZone) 120 | where f (ZonedTime lt tz) = (lt, tz) 121 | 122 | 123 | nominalDiffTime :: NominalDiffTime -> Builder 124 | nominalDiffTime xy = integerDec x <> primBounded frac (abs (fromIntegral y)) 125 | where 126 | (x,y) = fromPico (unsafeCoerce xy) `quotRem` 1000000000000 127 | 128 | fromPico :: Pico -> Integer 129 | fromPico (MkFixed i) = i 130 | -------------------------------------------------------------------------------- /stack-ghc-8.4.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-12.26 2 | 3 | packages: 4 | - . 5 | 6 | extra-deps: 7 | - homotuple-0.1.2.1@rev:0 8 | - list-tuple-0.1.3.0@rev:0 9 | - single-tuple-0.1.1.0@rev:0 10 | - postgresql-placeholder-converter-0.1.0.0@rev:1 11 | 12 | - HDBC-postgresql-2.3.2.7@rev:0 13 | - socket-0.8.2.0@sha256:77a3fb851d1dba7f3fd979773174d62cdbb59b5ad927cc9d00779a3eb2e859e9 14 | - socket-unix-0.2.0.0@sha256:8cecd07268b14ba47b13e7855f9862f3ce34a7079ccf21ea97057f6bd4f6fb66 15 | - github: postgres-haskell/postgres-wire 16 | commit: fda5e3b70c3cc0bab8365b4b872991d50da0348c 17 | -------------------------------------------------------------------------------- /stack-ghc-8.4.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: 7 | - completed: 8 | hackage: homotuple-0.1.2.1@sha256:845e9a1a3b14f2ad058729d8ebbe8fb3583d14f9a485bff717e866e5df6bc76d,1952 9 | pantry-tree: 10 | size: 605 11 | sha256: 23c1fefddde7355bc136766ca71844ca56c9f93250356b1527ff99a16290cafa 12 | original: 13 | hackage: homotuple-0.1.2.1@rev:0 14 | - completed: 15 | hackage: list-tuple-0.1.3.0@sha256:01ee6cb392c810ae6799672fc2c1c9722bcd96f8f79a1d01dd02ad20f153396f,2520 16 | pantry-tree: 17 | size: 840 18 | sha256: 3920f878eb8160fb09a777053ba5c70ad00bcd323f2f3d94e61e84f3f755c857 19 | original: 20 | hackage: list-tuple-0.1.3.0@rev:0 21 | - completed: 22 | hackage: single-tuple-0.1.1.0@sha256:8dde826850b01f6b7ac053645e97e52e905e6e98cfbfec115c822ab7eb7e6dc5,1938 23 | pantry-tree: 24 | size: 441 25 | sha256: 83d204053a79ac4620f4e411830b869766912a8dd1ade5f20bbce7e8de0f817c 26 | original: 27 | hackage: single-tuple-0.1.1.0@rev:0 28 | - completed: 29 | hackage: postgresql-placeholder-converter-0.1.0.0@sha256:cc5ae9483bd8c965fd7db8a3e8e406d75b446318abecfdce5f2330bf220b8a56,2340 30 | pantry-tree: 31 | size: 608 32 | sha256: 1a22ef9e412ed295f139f904f556f64317e43afcf2f66092ca8feed9bb2984c7 33 | original: 34 | hackage: postgresql-placeholder-converter-0.1.0.0@rev:1 35 | - completed: 36 | hackage: HDBC-postgresql-2.3.2.7@sha256:93d8e3c3d2dc9291a10f28ae3f8d0604a55ef47298ed43003a4d16f3d9905bae,3228 37 | pantry-tree: 38 | size: 1740 39 | sha256: 07bfba988402849f447025b324f2993ea88ac0ec4f7dd4b86942644e2e239d45 40 | original: 41 | hackage: HDBC-postgresql-2.3.2.7@rev:0 42 | - completed: 43 | hackage: socket-0.8.2.0@sha256:77a3fb851d1dba7f3fd979773174d62cdbb59b5ad927cc9d00779a3eb2e859e9,3584 44 | pantry-tree: 45 | size: 2064 46 | sha256: 509f0ff14c42362e5ecbe4cc1b3eb9a753cae2e98d09063664d7493d4853c1f8 47 | original: 48 | hackage: socket-0.8.2.0@sha256:77a3fb851d1dba7f3fd979773174d62cdbb59b5ad927cc9d00779a3eb2e859e9 49 | - completed: 50 | hackage: socket-unix-0.2.0.0@sha256:8cecd07268b14ba47b13e7855f9862f3ce34a7079ccf21ea97057f6bd4f6fb66,3058 51 | pantry-tree: 52 | size: 796 53 | sha256: f1f06f8afdbb4686786b3af522965ecc800dc7d4aefb44aca5e35cfd6d72e939 54 | original: 55 | hackage: socket-unix-0.2.0.0@sha256:8cecd07268b14ba47b13e7855f9862f3ce34a7079ccf21ea97057f6bd4f6fb66 56 | - completed: 57 | size: 55178 58 | url: https://github.com/postgres-haskell/postgres-wire/archive/fda5e3b70c3cc0bab8365b4b872991d50da0348c.tar.gz 59 | name: postgres-wire 60 | version: 0.1.0.0 61 | sha256: 009043547cdfa6a22ec851a24c6c599f66e2dc2af92314179066754b0e847ad1 62 | pantry-tree: 63 | size: 3113 64 | sha256: 6370f61d722444eec2432a405d9498792eb1c472ee8dd529514cade9a48bd059 65 | original: 66 | url: https://github.com/postgres-haskell/postgres-wire/archive/fda5e3b70c3cc0bab8365b4b872991d50da0348c.tar.gz 67 | snapshots: 68 | - completed: 69 | size: 509471 70 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/12/26.yaml 71 | sha256: 95f014df58d0679b1c4a2b7bf2b652b61da8d30de5f571abb0d59015ef678646 72 | original: lts-12.26 73 | -------------------------------------------------------------------------------- /stack-ghc-8.6.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.27 2 | 3 | packages: 4 | - . 5 | 6 | extra-deps: 7 | - homotuple-0.1.2.1@rev:0 8 | - list-tuple-0.1.3.0@rev:0 9 | - single-tuple-0.1.1.0@rev:0 10 | - postgresql-placeholder-converter-0.1.0.0@rev:1 11 | 12 | - HDBC-postgresql-2.3.2.7@rev:0 13 | - socket-0.8.2.0@sha256:77a3fb851d1dba7f3fd979773174d62cdbb59b5ad927cc9d00779a3eb2e859e9 14 | - socket-unix-0.2.0.0@sha256:8cecd07268b14ba47b13e7855f9862f3ce34a7079ccf21ea97057f6bd4f6fb66 15 | - github: postgres-haskell/postgres-wire 16 | commit: fda5e3b70c3cc0bab8365b4b872991d50da0348c 17 | - github: dylex/postgresql-typed 18 | commit: 4ef29b9357d749fc0c07d25b70dada85ea7afde0 19 | -------------------------------------------------------------------------------- /stack-ghc-8.6.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: 7 | - completed: 8 | hackage: homotuple-0.1.2.1@sha256:845e9a1a3b14f2ad058729d8ebbe8fb3583d14f9a485bff717e866e5df6bc76d,1952 9 | pantry-tree: 10 | size: 605 11 | sha256: 23c1fefddde7355bc136766ca71844ca56c9f93250356b1527ff99a16290cafa 12 | original: 13 | hackage: homotuple-0.1.2.1@rev:0 14 | - completed: 15 | hackage: list-tuple-0.1.3.0@sha256:01ee6cb392c810ae6799672fc2c1c9722bcd96f8f79a1d01dd02ad20f153396f,2520 16 | pantry-tree: 17 | size: 840 18 | sha256: 3920f878eb8160fb09a777053ba5c70ad00bcd323f2f3d94e61e84f3f755c857 19 | original: 20 | hackage: list-tuple-0.1.3.0@rev:0 21 | - completed: 22 | hackage: single-tuple-0.1.1.0@sha256:8dde826850b01f6b7ac053645e97e52e905e6e98cfbfec115c822ab7eb7e6dc5,1938 23 | pantry-tree: 24 | size: 441 25 | sha256: 83d204053a79ac4620f4e411830b869766912a8dd1ade5f20bbce7e8de0f817c 26 | original: 27 | hackage: single-tuple-0.1.1.0@rev:0 28 | - completed: 29 | hackage: postgresql-placeholder-converter-0.1.0.0@sha256:cc5ae9483bd8c965fd7db8a3e8e406d75b446318abecfdce5f2330bf220b8a56,2340 30 | pantry-tree: 31 | size: 608 32 | sha256: 1a22ef9e412ed295f139f904f556f64317e43afcf2f66092ca8feed9bb2984c7 33 | original: 34 | hackage: postgresql-placeholder-converter-0.1.0.0@rev:1 35 | - completed: 36 | hackage: HDBC-postgresql-2.3.2.7@sha256:93d8e3c3d2dc9291a10f28ae3f8d0604a55ef47298ed43003a4d16f3d9905bae,3228 37 | pantry-tree: 38 | size: 1740 39 | sha256: 07bfba988402849f447025b324f2993ea88ac0ec4f7dd4b86942644e2e239d45 40 | original: 41 | hackage: HDBC-postgresql-2.3.2.7@rev:0 42 | - completed: 43 | hackage: socket-0.8.2.0@sha256:77a3fb851d1dba7f3fd979773174d62cdbb59b5ad927cc9d00779a3eb2e859e9,3584 44 | pantry-tree: 45 | size: 2064 46 | sha256: 509f0ff14c42362e5ecbe4cc1b3eb9a753cae2e98d09063664d7493d4853c1f8 47 | original: 48 | hackage: socket-0.8.2.0@sha256:77a3fb851d1dba7f3fd979773174d62cdbb59b5ad927cc9d00779a3eb2e859e9 49 | - completed: 50 | hackage: socket-unix-0.2.0.0@sha256:8cecd07268b14ba47b13e7855f9862f3ce34a7079ccf21ea97057f6bd4f6fb66,3058 51 | pantry-tree: 52 | size: 796 53 | sha256: f1f06f8afdbb4686786b3af522965ecc800dc7d4aefb44aca5e35cfd6d72e939 54 | original: 55 | hackage: socket-unix-0.2.0.0@sha256:8cecd07268b14ba47b13e7855f9862f3ce34a7079ccf21ea97057f6bd4f6fb66 56 | - completed: 57 | size: 55178 58 | url: https://github.com/postgres-haskell/postgres-wire/archive/fda5e3b70c3cc0bab8365b4b872991d50da0348c.tar.gz 59 | name: postgres-wire 60 | version: 0.1.0.0 61 | sha256: 009043547cdfa6a22ec851a24c6c599f66e2dc2af92314179066754b0e847ad1 62 | pantry-tree: 63 | size: 3113 64 | sha256: 6370f61d722444eec2432a405d9498792eb1c472ee8dd529514cade9a48bd059 65 | original: 66 | url: https://github.com/postgres-haskell/postgres-wire/archive/fda5e3b70c3cc0bab8365b4b872991d50da0348c.tar.gz 67 | - completed: 68 | size: 81313 69 | url: https://github.com/dylex/postgresql-typed/archive/4ef29b9357d749fc0c07d25b70dada85ea7afde0.tar.gz 70 | name: postgresql-typed 71 | version: 0.6.1.0 72 | sha256: 1a1555bd0f1503aea2e13b25bd6a720978b1391050131e06d1f62779a297b27e 73 | pantry-tree: 74 | size: 2577 75 | sha256: a271159e91a8a35fbed01f0be98bad17c2352d81c48e16f58327e552d59ac0d5 76 | original: 77 | url: https://github.com/dylex/postgresql-typed/archive/4ef29b9357d749fc0c07d25b70dada85ea7afde0.tar.gz 78 | snapshots: 79 | - completed: 80 | size: 524996 81 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/14/27.yaml 82 | sha256: 7ea31a280c56bf36ff591a7397cc384d0dff622e7f9e4225b47d8980f019a0f0 83 | original: lts-14.27 84 | -------------------------------------------------------------------------------- /stack-ghc-8.8.yaml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/iijlab/postgresql-pure/2a640f102f3e3540aedbcf4cfb5d1ed10310f773/stack-ghc-8.8.yaml -------------------------------------------------------------------------------- /stack-ghc-8.8.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: 7 | - completed: 8 | hackage: homotuple-0.1.2.1@sha256:845e9a1a3b14f2ad058729d8ebbe8fb3583d14f9a485bff717e866e5df6bc76d,1952 9 | pantry-tree: 10 | size: 605 11 | sha256: 23c1fefddde7355bc136766ca71844ca56c9f93250356b1527ff99a16290cafa 12 | original: 13 | hackage: homotuple-0.1.2.1@rev:0 14 | - completed: 15 | hackage: list-tuple-0.1.3.0@sha256:01ee6cb392c810ae6799672fc2c1c9722bcd96f8f79a1d01dd02ad20f153396f,2520 16 | pantry-tree: 17 | size: 840 18 | sha256: 3920f878eb8160fb09a777053ba5c70ad00bcd323f2f3d94e61e84f3f755c857 19 | original: 20 | hackage: list-tuple-0.1.3.0@rev:0 21 | - completed: 22 | hackage: single-tuple-0.1.1.0@sha256:8dde826850b01f6b7ac053645e97e52e905e6e98cfbfec115c822ab7eb7e6dc5,1938 23 | pantry-tree: 24 | size: 441 25 | sha256: 83d204053a79ac4620f4e411830b869766912a8dd1ade5f20bbce7e8de0f817c 26 | original: 27 | hackage: single-tuple-0.1.1.0@rev:0 28 | - completed: 29 | hackage: postgresql-placeholder-converter-0.1.0.0@sha256:cc5ae9483bd8c965fd7db8a3e8e406d75b446318abecfdce5f2330bf220b8a56,2340 30 | pantry-tree: 31 | size: 608 32 | sha256: 1a22ef9e412ed295f139f904f556f64317e43afcf2f66092ca8feed9bb2984c7 33 | original: 34 | hackage: postgresql-placeholder-converter-0.1.0.0@rev:1 35 | - completed: 36 | hackage: HDBC-postgresql-2.3.2.7@sha256:93d8e3c3d2dc9291a10f28ae3f8d0604a55ef47298ed43003a4d16f3d9905bae,3228 37 | pantry-tree: 38 | size: 1740 39 | sha256: 07bfba988402849f447025b324f2993ea88ac0ec4f7dd4b86942644e2e239d45 40 | original: 41 | hackage: HDBC-postgresql-2.3.2.7@rev:0 42 | - completed: 43 | hackage: socket-0.8.2.0@sha256:77a3fb851d1dba7f3fd979773174d62cdbb59b5ad927cc9d00779a3eb2e859e9,3584 44 | pantry-tree: 45 | size: 2064 46 | sha256: 509f0ff14c42362e5ecbe4cc1b3eb9a753cae2e98d09063664d7493d4853c1f8 47 | original: 48 | hackage: socket-0.8.2.0@sha256:77a3fb851d1dba7f3fd979773174d62cdbb59b5ad927cc9d00779a3eb2e859e9 49 | - completed: 50 | hackage: socket-unix-0.2.0.0@sha256:8cecd07268b14ba47b13e7855f9862f3ce34a7079ccf21ea97057f6bd4f6fb66,3058 51 | pantry-tree: 52 | size: 796 53 | sha256: f1f06f8afdbb4686786b3af522965ecc800dc7d4aefb44aca5e35cfd6d72e939 54 | original: 55 | hackage: socket-unix-0.2.0.0@sha256:8cecd07268b14ba47b13e7855f9862f3ce34a7079ccf21ea97057f6bd4f6fb66 56 | snapshots: 57 | - completed: 58 | size: 496112 59 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/15/15.yaml 60 | sha256: 86169722ad0056ffc9eacc157ef80ee21d7024f92c0d2961c89ccf432db230a3 61 | original: lts-15.15 62 | -------------------------------------------------------------------------------- /stack-nightly.yaml: -------------------------------------------------------------------------------- 1 | resolver: nightly-2020-07-09 2 | 3 | packages: 4 | - . 5 | 6 | extra-deps: 7 | - homotuple-0.1.2.1@rev:0 8 | - list-tuple-0.1.3.0@rev:0 9 | - single-tuple-0.1.1.0@rev:0 10 | - postgresql-placeholder-converter-0.1.0.0@rev:1 11 | 12 | - github: tfausak/hdbc-postgresql 13 | commit: 90372d22e4ec416faa00b18a715303027fa1128e 14 | -------------------------------------------------------------------------------- /stack-nightly.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: 7 | - completed: 8 | hackage: homotuple-0.1.2.1@sha256:845e9a1a3b14f2ad058729d8ebbe8fb3583d14f9a485bff717e866e5df6bc76d,1952 9 | pantry-tree: 10 | size: 605 11 | sha256: 23c1fefddde7355bc136766ca71844ca56c9f93250356b1527ff99a16290cafa 12 | original: 13 | hackage: homotuple-0.1.2.1@rev:0 14 | - completed: 15 | hackage: list-tuple-0.1.3.0@sha256:01ee6cb392c810ae6799672fc2c1c9722bcd96f8f79a1d01dd02ad20f153396f,2520 16 | pantry-tree: 17 | size: 840 18 | sha256: 3920f878eb8160fb09a777053ba5c70ad00bcd323f2f3d94e61e84f3f755c857 19 | original: 20 | hackage: list-tuple-0.1.3.0@rev:0 21 | - completed: 22 | hackage: single-tuple-0.1.1.0@sha256:8dde826850b01f6b7ac053645e97e52e905e6e98cfbfec115c822ab7eb7e6dc5,1938 23 | pantry-tree: 24 | size: 441 25 | sha256: 83d204053a79ac4620f4e411830b869766912a8dd1ade5f20bbce7e8de0f817c 26 | original: 27 | hackage: single-tuple-0.1.1.0@rev:0 28 | - completed: 29 | hackage: postgresql-placeholder-converter-0.1.0.0@sha256:cc5ae9483bd8c965fd7db8a3e8e406d75b446318abecfdce5f2330bf220b8a56,2340 30 | pantry-tree: 31 | size: 608 32 | sha256: 1a22ef9e412ed295f139f904f556f64317e43afcf2f66092ca8feed9bb2984c7 33 | original: 34 | hackage: postgresql-placeholder-converter-0.1.0.0@rev:1 35 | - completed: 36 | size: 25744 37 | url: https://github.com/tfausak/hdbc-postgresql/archive/90372d22e4ec416faa00b18a715303027fa1128e.tar.gz 38 | name: HDBC-postgresql 39 | version: 2.3.2.7 40 | sha256: c6a76948a8272e5e48948a433cde76e0a5a04a8681b8564cf4b166df13d2b5cb 41 | pantry-tree: 42 | size: 1789 43 | sha256: 692b60c49e24e6700a654a1ce67d12cfa9d8e6ab49be9771f9bca27a630155d2 44 | original: 45 | url: https://github.com/tfausak/hdbc-postgresql/archive/90372d22e4ec416faa00b18a715303027fa1128e.tar.gz 46 | snapshots: 47 | - completed: 48 | size: 508765 49 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2020/7/9.yaml 50 | sha256: b7d7a78a6eb58419c0332655eb21100430f1e983d1c7cfca00092943750bbad8 51 | original: nightly-2020-07-09 52 | -------------------------------------------------------------------------------- /template/BuilderItem.hs: -------------------------------------------------------------------------------- 1 | -- -tuple 2 | instance => ToRecord where 3 | toRecord backendParams encode Nothing = 4 | sequence 5 | toRecord backendParams encode (Just ) = 6 | sequence 7 | toRecord _ _ (Just os) _ _ = 8 | fail $ "the number of OIDs must be , actually " <> show (length os) 9 | toRecord _ _ _ fs _ = 10 | fail $ "the number of format codes must be , actually " <> show (length fs) 11 | -------------------------------------------------------------------------------- /template/Length.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DefaultSignatures #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | {-# LANGUAGE UndecidableInstances #-} 8 | 9 | module Database.PostgreSQL.Pure.Internal.Length 10 | (Length) where 11 | 12 | import qualified Data.ByteString as BS 13 | import Data.Functor.Identity (Identity) 14 | import Data.Int (Int16, Int32, Int64) 15 | import Data.Proxy (Proxy) 16 | import Data.Scientific (Scientific) 17 | import Data.Time (Day, DiffTime, LocalTime, TimeOfDay, UTCTime) 18 | import Data.Tuple.OneTuple (OneTuple) 19 | import Data.Tuple.Only (Only) 20 | import Database.PostgreSQL.Pure.Internal.Data (Oid, Raw, SqlIdentifier, TimeOfDayWithTimeZone) 21 | import GHC.TypeLits (Nat) 22 | 23 | -- | The number of columns. 24 | type family Length a :: Nat 25 | 26 | type instance Length Bool = 1 27 | 28 | type instance Length Int = 1 29 | 30 | type instance Length Int16 = 1 31 | 32 | type instance Length Int32 = 1 33 | 34 | type instance Length Int64 = 1 35 | 36 | type instance Length Scientific = 1 37 | 38 | type instance Length Float = 1 39 | 40 | type instance Length Double = 1 41 | 42 | type instance Length Oid = 1 43 | 44 | type instance Length Char = 1 45 | 46 | type instance Length String = 1 47 | 48 | type instance Length BS.ByteString = 1 49 | 50 | type instance Length Day = 1 51 | 52 | type instance Length TimeOfDay = 1 53 | 54 | type instance Length TimeOfDayWithTimeZone = 1 55 | 56 | type instance Length LocalTime = 1 57 | 58 | type instance Length UTCTime = 1 59 | 60 | type instance Length DiffTime = 1 61 | 62 | type instance Length SqlIdentifier = 1 63 | 64 | type instance Length Raw = 1 65 | 66 | type instance Length (Maybe a) = 1 67 | 68 | -- 0 tuple 69 | type instance Length () = 0 70 | 71 | type instance Length (Proxy a) = 0 72 | 73 | -- 1 tuple 74 | type instance Length (Identity a) = 1 75 | 76 | type instance Length (OneTuple a) = 1 77 | 78 | type instance Length (Only a) = 1 79 | 80 | ---- embed 2 81 | 82 | ---- embed 3 83 | 84 | ---- embed 4 85 | 86 | ---- embed 5 87 | 88 | ---- embed 6 89 | 90 | ---- embed 7 91 | 92 | ---- embed 8 93 | 94 | ---- embed 9 95 | 96 | ---- embed 10 97 | 98 | ---- embed 11 99 | 100 | ---- embed 12 101 | 102 | ---- embed 13 103 | 104 | ---- embed 14 105 | 106 | ---- embed 15 107 | 108 | ---- embed 16 109 | 110 | ---- embed 17 111 | 112 | ---- embed 18 113 | 114 | ---- embed 19 115 | 116 | ---- embed 20 117 | 118 | ---- embed 21 119 | 120 | ---- embed 22 121 | 122 | ---- embed 23 123 | 124 | ---- embed 24 125 | 126 | ---- embed 25 127 | 128 | ---- embed 26 129 | 130 | ---- embed 27 131 | 132 | ---- embed 28 133 | 134 | ---- embed 29 135 | 136 | ---- embed 30 137 | 138 | ---- embed 31 139 | 140 | ---- embed 32 141 | 142 | ---- embed 33 143 | 144 | ---- embed 34 145 | 146 | ---- embed 35 147 | 148 | ---- embed 36 149 | 150 | ---- embed 37 151 | 152 | ---- embed 38 153 | 154 | ---- embed 39 155 | 156 | ---- embed 40 157 | 158 | ---- embed 41 159 | 160 | ---- embed 42 161 | 162 | ---- embed 43 163 | 164 | ---- embed 44 165 | 166 | ---- embed 45 167 | 168 | ---- embed 46 169 | 170 | ---- embed 47 171 | 172 | ---- embed 48 173 | 174 | ---- embed 49 175 | 176 | ---- embed 50 177 | 178 | ---- embed 51 179 | 180 | ---- embed 52 181 | 182 | ---- embed 53 183 | 184 | ---- embed 54 185 | 186 | ---- embed 55 187 | 188 | ---- embed 56 189 | 190 | ---- embed 57 191 | 192 | ---- embed 58 193 | 194 | ---- embed 59 195 | 196 | ---- embed 60 197 | 198 | ---- embed 61 199 | 200 | ---- embed 62 201 | -------------------------------------------------------------------------------- /template/LengthItem.hs: -------------------------------------------------------------------------------- 1 | -- -tuple 2 | type instance Length = 3 | -------------------------------------------------------------------------------- /template/ParserItem.hs: -------------------------------------------------------------------------------- 1 | -- -tuple 2 | instance => FromRecord where 3 | fromRecord decode = 4 | <$> 5 | fromRecord _ is = fail $ "length mismatch: expected : actual: " <> show (length is) 6 | -------------------------------------------------------------------------------- /test-asset/create-tables.sql: -------------------------------------------------------------------------------- 1 | CREATE TABLE person ( 2 | id serial PRIMARY KEY, 3 | name varchar(255) NOT NULL 4 | ); 5 | -------------------------------------------------------------------------------- /test-asset/insert.sql: -------------------------------------------------------------------------------- 1 | INSERT INTO person (name) VALUES 2 | ('Ada'), 3 | ('Bob'), 4 | ('Carl'), 5 | ('Don'), 6 | ('Emily'), 7 | ('Fay'); 8 | -------------------------------------------------------------------------------- /test-doctest/doctest.hs: -------------------------------------------------------------------------------- 1 | import Test.DocTest (doctest) 2 | 3 | main :: IO () 4 | main = 5 | doctest ["-isrc", "src"] 6 | -------------------------------------------------------------------------------- /test-hdbc-postgresql/SpecificDB.hs: -------------------------------------------------------------------------------- 1 | module SpecificDB where 2 | import Database.HDBC 3 | import Database.HDBC.PostgreSQL.Pure 4 | import Test.HUnit 5 | import Data.Default.Class(Default(def)) 6 | import Data.Maybe(fromMaybe) 7 | import System.Environment(lookupEnv) 8 | 9 | connectDB = 10 | handleSqlError (do host <- getEnvDef "PURE_HOST" "127.0.0.1" 11 | port <- getEnvDef "PURE_PORT" "5432" 12 | user <- getEnvDef "PURE_USER" "postgres" 13 | password <- getEnvDef "PURE_PASSWORD" "" 14 | database <- getEnvDef "PURE_DATABASE" "postgres" 15 | let 16 | config = 17 | def 18 | { address = AddressNotResolved host port 19 | , user = user 20 | , password = password 21 | , database = database 22 | } 23 | dbh <- connect config 24 | run dbh "SET client_min_messages=WARNING" [] 25 | return dbh) 26 | 27 | dateTimeTypeOfSqlValue :: SqlValue -> String 28 | dateTimeTypeOfSqlValue (SqlLocalDate _) = "date" 29 | dateTimeTypeOfSqlValue (SqlLocalTimeOfDay _) = "time without time zone" 30 | dateTimeTypeOfSqlValue (SqlZonedLocalTimeOfDay _ _) = "time with time zone" 31 | dateTimeTypeOfSqlValue (SqlLocalTime _) = "timestamp without time zone" 32 | dateTimeTypeOfSqlValue (SqlZonedTime _) = "timestamp with time zone" 33 | dateTimeTypeOfSqlValue (SqlUTCTime _) = "timestamp with time zone" 34 | dateTimeTypeOfSqlValue (SqlDiffTime _) = "interval" 35 | dateTimeTypeOfSqlValue (SqlPOSIXTime _) = "numeric" 36 | dateTimeTypeOfSqlValue (SqlEpochTime _) = "integer" 37 | dateTimeTypeOfSqlValue (SqlTimeDiff _) = "interval" 38 | dateTimeTypeOfSqlValue _ = "text" 39 | 40 | supportsFracTime = True 41 | 42 | getEnvDef :: String -> String -> IO String 43 | getEnvDef name value = fromMaybe value <$> lookupEnv name 44 | -------------------------------------------------------------------------------- /test-hdbc-postgresql/SpecificDBTests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module SpecificDBTests where 4 | import Database.HDBC 5 | import Database.HDBC.PostgreSQL.Pure 6 | import Database.PostgreSQL.Placeholder.Convert (convertQuestionMarkStyleToDollarSignStyle) 7 | import Test.HUnit 8 | 9 | testp inp exp = TestCase $ 10 | case convertQuestionMarkStyleToDollarSignStyle inp of 11 | Right x -> assertEqual "" exp x 12 | Left y -> assertFailure $ show y 13 | 14 | tests = TestList 15 | [TestLabel "empty" (testp "" ""), 16 | TestLabel "simple" (testp "SELECT a from b WHERE c = ?" 17 | "SELECT a from b WHERE c = $1"), 18 | TestLabel "multi" (testp "INSERT INTO foo VALUES (?,?)" 19 | "INSERT INTO foo VALUES ($1,$2)"), 20 | TestLabel "literal" (testp "INSERT INTO foo VALUES ('?', '''?')" 21 | "INSERT INTO foo VALUES ('?', '''?')"), 22 | TestLabel "torture" 23 | (testp "-- really?\n-- yes'?\nINSERT INTO ? VALUES ('', ?, \"?asd\", '?\\'?', '?''?', /* foo? */ /* foo /* bar */ ? */ ?)" 24 | "-- really?\n-- yes'?\nINSERT INTO $1 VALUES ('', $2, \"?asd\", '?\\'?', '?''?', /* foo? */ /* foo /* bar */ ? */ $3)") 25 | ] 26 | -------------------------------------------------------------------------------- /test-hdbc-postgresql/TestMisc.hs: -------------------------------------------------------------------------------- 1 | module TestMisc(tests, setup) where 2 | import Test.HUnit 3 | import Database.HDBC 4 | import TestUtils 5 | import System.IO 6 | import Control.Exception 7 | import Data.Char 8 | import Control.Monad 9 | import qualified Data.Map as Map 10 | 11 | rowdata = 12 | [[SqlInt32 0, toSql "Testing", SqlNull], 13 | [SqlInt32 1, toSql "Foo", SqlInt32 5], 14 | [SqlInt32 2, toSql "Bar", SqlInt32 9]] 15 | 16 | colnames = ["testid", "teststring", "testint"] 17 | alrows :: [[(String, SqlValue)]] 18 | alrows = map (zip colnames) rowdata 19 | 20 | setup f = dbTestCase $ \dbh -> 21 | do run dbh "CREATE TABLE hdbctest2 (testid INTEGER PRIMARY KEY NOT NULL, teststring TEXT, testint INTEGER)" [] 22 | sth <- prepare dbh "INSERT INTO hdbctest2 VALUES (?, ?, ?)" 23 | executeMany sth rowdata 24 | commit dbh 25 | finally (f dbh) 26 | (do run dbh "DROP TABLE hdbctest2" [] 27 | commit dbh 28 | ) 29 | 30 | cloneTest dbh a = 31 | do dbh2 <- clone dbh 32 | finally (handleSqlError (a dbh2)) 33 | (handleSqlError (disconnect dbh2)) 34 | 35 | testgetColumnNames = setup $ \dbh -> 36 | do sth <- prepare dbh "SELECT * from hdbctest2" 37 | execute sth [] 38 | cols <- getColumnNames sth 39 | finish sth 40 | ["testid", "teststring", "testint"] @=? map (map toLower) cols 41 | 42 | testdescribeResult = setup $ \dbh -> when (not ((hdbcDriverName dbh) `elem` 43 | ["sqlite3"])) $ 44 | do sth <- prepare dbh "SELECT * from hdbctest2" 45 | execute sth [] 46 | cols <- describeResult sth 47 | ["testid", "teststring", "testint"] @=? map (map toLower . fst) cols 48 | let coldata = map snd cols 49 | assertBool "r0 type" (colType (coldata !! 0) `elem` 50 | [SqlBigIntT, SqlIntegerT]) 51 | assertBool "r1 type" (colType (coldata !! 1) `elem` 52 | [SqlVarCharT, SqlLongVarCharT]) 53 | assertBool "r2 type" (colType (coldata !! 2) `elem` 54 | [SqlBigIntT, SqlIntegerT]) 55 | finish sth 56 | 57 | testdescribeTable = setup $ \dbh -> when (not ((hdbcDriverName dbh) `elem` 58 | ["sqlite3"])) $ 59 | do cols <- describeTable dbh "hdbctest2" 60 | ["testid", "teststring", "testint"] @=? map (map toLower . fst) cols 61 | let coldata = map snd cols 62 | assertBool "r0 type" (colType (coldata !! 0) `elem` 63 | [SqlBigIntT, SqlIntegerT]) 64 | assertEqual "r0 nullable" (Just False) (colNullable (coldata !! 0)) 65 | assertBool "r1 type" (colType (coldata !! 1) `elem` 66 | [SqlVarCharT, SqlLongVarCharT]) 67 | assertEqual "r1 nullable" (Just True) (colNullable (coldata !! 1)) 68 | assertBool "r2 type" (colType (coldata !! 2) `elem` 69 | [SqlBigIntT, SqlIntegerT]) 70 | assertEqual "r2 nullable" (Just True) (colNullable (coldata !! 2)) 71 | 72 | testquickQuery = setup $ \dbh -> 73 | do results <- quickQuery dbh "SELECT * from hdbctest2 ORDER BY testid" [] 74 | rowdata @=? results 75 | 76 | testfetchRowAL = setup $ \dbh -> 77 | do sth <- prepare dbh "SELECT * from hdbctest2 ORDER BY testid" 78 | execute sth [] 79 | fetchRowAL sth >>= (Just (head alrows) @=?) 80 | fetchRowAL sth >>= (Just (alrows !! 1) @=?) 81 | fetchRowAL sth >>= (Just (alrows !! 2) @=?) 82 | fetchRowAL sth >>= (Nothing @=?) 83 | finish sth 84 | 85 | testfetchRowMap = setup $ \dbh -> 86 | do sth <- prepare dbh "SELECT * from hdbctest2 ORDER BY testid" 87 | execute sth [] 88 | fetchRowMap sth >>= (Just (Map.fromList $ head alrows) @=?) 89 | fetchRowMap sth >>= (Just (Map.fromList $ alrows !! 1) @=?) 90 | fetchRowMap sth >>= (Just (Map.fromList $ alrows !! 2) @=?) 91 | fetchRowMap sth >>= (Nothing @=?) 92 | finish sth 93 | 94 | testfetchAllRowsAL = setup $ \dbh -> 95 | do sth <- prepare dbh "SELECT * from hdbctest2 ORDER BY testid" 96 | execute sth [] 97 | fetchAllRowsAL sth >>= (alrows @=?) 98 | 99 | testfetchAllRowsMap = setup $ \dbh -> 100 | do sth <- prepare dbh "SELECT * from hdbctest2 ORDER BY testid" 101 | execute sth [] 102 | fetchAllRowsMap sth >>= (map (Map.fromList) alrows @=?) 103 | 104 | testexception = setup $ \dbh -> 105 | catchSql (do sth <- prepare dbh "SELECT invalidcol FROM hdbctest2" 106 | execute sth [] 107 | assertFailure "No exception was raised" 108 | ) 109 | (\e -> commit dbh) 110 | 111 | testrowcount = setup $ \dbh -> 112 | do r <- run dbh "UPDATE hdbctest2 SET testint = 25 WHERE testid = 20" [] 113 | assertEqual "UPDATE with no change" 0 r 114 | r <- run dbh "UPDATE hdbctest2 SET testint = 26 WHERE testid = 0" [] 115 | assertEqual "UPDATE with 1 change" 1 r 116 | r <- run dbh "UPDATE hdbctest2 SET testint = 27 WHERE testid <> 0" [] 117 | assertEqual "UPDATE with 2 changes" 2 r 118 | commit dbh 119 | res <- quickQuery dbh "SELECT * from hdbctest2 ORDER BY testid" [] 120 | assertEqual "final results" 121 | [[SqlInt32 0, toSql "Testing", SqlInt32 26], 122 | [SqlInt32 1, toSql "Foo", SqlInt32 27], 123 | [SqlInt32 2, toSql "Bar", SqlInt32 27]] res 124 | 125 | {- Since we might be running against a live DB, we can't look at a specific 126 | list here (though a SpecificDB test case may be able to). We can ensure 127 | that our test table is, or is not, present, as appropriate. -} 128 | 129 | testgetTables1 = setup $ \dbh -> 130 | do r <- getTables dbh 131 | True @=? "hdbctest2" `elem` r 132 | 133 | testgetTables2 = dbTestCase $ \dbh -> 134 | do r <- getTables dbh 135 | False @=? "hdbctest2" `elem` r 136 | 137 | testclone = setup $ \dbho -> cloneTest dbho $ \dbh -> 138 | do results <- quickQuery dbh "SELECT * from hdbctest2 ORDER BY testid" [] 139 | rowdata @=? results 140 | 141 | testnulls = setup $ \dbh -> 142 | do let dn = hdbcDriverName dbh 143 | when (not (dn `elem` ["postgresql", "odbc"])) ( 144 | do sth <- prepare dbh "INSERT INTO hdbctest2 VALUES (?, ?, ?)" 145 | executeMany sth rows 146 | finish sth 147 | res <- quickQuery dbh "SELECT * from hdbctest2 WHERE testid > 99 ORDER BY testid" [] 148 | seq (length res) rows @=? res 149 | ) 150 | where rows = [[SqlInt32 100, SqlString "foo\NULbar", SqlNull], 151 | [SqlInt32 101, SqlString "bar\NUL", SqlNull], 152 | [SqlInt32 102, SqlString "\NUL", SqlNull], 153 | [SqlInt32 103, SqlString "\xFF", SqlNull], 154 | [SqlInt32 104, SqlString "regular", SqlNull]] 155 | 156 | testunicode = setup $ \dbh -> 157 | do sth <- prepare dbh "INSERT INTO hdbctest2 VALUES (?, ?, ?)" 158 | executeMany sth rows 159 | finish sth 160 | res <- quickQuery dbh "SELECT * from hdbctest2 WHERE testid > 99 ORDER BY testid" [] 161 | seq (length res) rows @=? res 162 | where rows = [[SqlInt32 100, SqlString "foo\x263a", SqlNull], 163 | [SqlInt32 101, SqlString "bar\x00A3", SqlNull], 164 | [SqlInt32 102, SqlString (take 263 (repeat 'a')), SqlNull]] 165 | 166 | tests = TestList [TestLabel "getColumnNames" testgetColumnNames, 167 | TestLabel "describeResult" testdescribeResult, 168 | TestLabel "describeTable" testdescribeTable, 169 | TestLabel "quickQuery" testquickQuery, 170 | TestLabel "fetchRowAL" testfetchRowAL, 171 | TestLabel "fetchRowMap" testfetchRowMap, 172 | TestLabel "fetchAllRowsAL" testfetchAllRowsAL, 173 | TestLabel "fetchAllRowsMap" testfetchAllRowsMap, 174 | TestLabel "sql exception" testexception, 175 | TestLabel "clone" testclone, 176 | TestLabel "update rowcount" testrowcount, 177 | TestLabel "get tables1" testgetTables1, 178 | TestLabel "get tables2" testgetTables2, 179 | TestLabel "nulls" testnulls, 180 | TestLabel "unicode" testunicode] 181 | -------------------------------------------------------------------------------- /test-hdbc-postgresql/TestSbasics.hs: -------------------------------------------------------------------------------- 1 | module TestSbasics(tests) where 2 | import Test.HUnit 3 | import Data.List 4 | import Database.HDBC 5 | import TestUtils 6 | import System.IO 7 | import Control.Exception 8 | 9 | openClosedb = sqlTestCase $ 10 | do dbh <- connectDB 11 | disconnect dbh 12 | 13 | multiFinish = dbTestCase (\dbh -> 14 | do sth <- prepare dbh "SELECT 1 + 1" 15 | sExecute sth [] 16 | finish sth 17 | finish sth 18 | finish sth 19 | ) 20 | 21 | runRawTest = dbTestCase (\dbh -> 22 | do runRaw dbh "CREATE TABLE valid1 (a int); CREATE TABLE valid2 (a int)" 23 | tables <- getTables dbh 24 | assertBool "valid1 table not created!" ("valid1" `elem` tables) 25 | assertBool "valid2 table not created!" ("valid2" `elem` tables) 26 | ) 27 | 28 | runRawErrorTest = dbTestCase (\dbh -> 29 | let expected = "syntax error at or near \"INVALID\"" 30 | in do err <- (runRaw dbh "CREATE TABLE valid1 (a int); INVALID" >> return "No error") `catchSql` 31 | (return . seErrorMsg) 32 | assertBool "Error message inappropriate" (expected `isInfixOf` err) 33 | rollback dbh 34 | tables <- getTables dbh 35 | assertBool "valid1 table created!" (not $ "valid1" `elem` tables) 36 | ) 37 | 38 | 39 | basicQueries = dbTestCase (\dbh -> 40 | do sth <- prepare dbh "SELECT 1 + 1" 41 | sExecute sth [] 42 | sFetchRow sth >>= (assertEqual "row 1" (Just [Just "2"])) 43 | sFetchRow sth >>= (assertEqual "last row" Nothing) 44 | ) 45 | 46 | createTable = dbTestCase (\dbh -> 47 | do sRun dbh "CREATE TABLE hdbctest1 (testname VARCHAR(20), testid INTEGER, testint INTEGER, testtext TEXT)" [] 48 | commit dbh 49 | ) 50 | 51 | dropTable = dbTestCase (\dbh -> 52 | do sRun dbh "DROP TABLE hdbctest1" [] 53 | commit dbh 54 | ) 55 | 56 | runReplace = dbTestCase (\dbh -> 57 | do sRun dbh "INSERT INTO hdbctest1 VALUES (?, ?, ?, ?)" r1 58 | sRun dbh "INSERT INTO hdbctest1 VALUES (?, ?, 2, ?)" r2 59 | commit dbh 60 | sth <- prepare dbh "SELECT * FROM hdbctest1 WHERE testname = 'runReplace' ORDER BY testid" 61 | sExecute sth [] 62 | sFetchRow sth >>= (assertEqual "r1" (Just r1)) 63 | sFetchRow sth >>= (assertEqual "r2" (Just [Just "runReplace", Just "2", 64 | Just "2", Nothing])) 65 | sFetchRow sth >>= (assertEqual "lastrow" Nothing) 66 | ) 67 | where r1 = [Just "runReplace", Just "1", Just "1234", Just "testdata"] 68 | r2 = [Just "runReplace", Just "2", Nothing] 69 | 70 | executeReplace = dbTestCase (\dbh -> 71 | do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('executeReplace',?,?,?)" 72 | sExecute sth [Just "1", Just "1234", Just "Foo"] 73 | sExecute sth [Just "2", Nothing, Just "Bar"] 74 | commit dbh 75 | sth <- prepare dbh "SELECT * FROM hdbctest1 WHERE testname = ? ORDER BY testid" 76 | sExecute sth [Just "executeReplace"] 77 | sFetchRow sth >>= (assertEqual "r1" 78 | (Just $ map Just ["executeReplace", "1", "1234", 79 | "Foo"])) 80 | sFetchRow sth >>= (assertEqual "r2" 81 | (Just [Just "executeReplace", Just "2", Nothing, 82 | Just "Bar"])) 83 | sFetchRow sth >>= (assertEqual "lastrow" Nothing) 84 | ) 85 | 86 | testExecuteMany = dbTestCase (\dbh -> 87 | do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('multi',?,?,?)" 88 | sExecuteMany sth rows 89 | commit dbh 90 | sth <- prepare dbh "SELECT testid, testint, testtext FROM hdbctest1 WHERE testname = 'multi'" 91 | sExecute sth [] 92 | mapM_ (\r -> sFetchRow sth >>= (assertEqual "" (Just r))) rows 93 | sFetchRow sth >>= (assertEqual "lastrow" Nothing) 94 | ) 95 | where rows = [map Just ["1", "1234", "foo"], 96 | map Just ["2", "1341", "bar"], 97 | [Just "3", Nothing, Nothing]] 98 | 99 | testsFetchAllRows = dbTestCase (\dbh -> 100 | do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('sFetchAllRows', ?, NULL, NULL)" 101 | sExecuteMany sth rows 102 | commit dbh 103 | sth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'sFetchAllRows' ORDER BY testid" 104 | sExecute sth [] 105 | results <- sFetchAllRows sth 106 | assertEqual "" rows results 107 | ) 108 | where rows = map (\x -> [Just . show $ x]) [1..9] 109 | 110 | basicTransactions = dbTestCase (\dbh -> 111 | do assertBool "Connected database does not support transactions; skipping transaction test" (dbTransactionSupport dbh) 112 | sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('basicTransactions', ?, NULL, NULL)" 113 | sExecute sth [Just "0"] 114 | commit dbh 115 | qrysth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'basicTransactions' ORDER BY testid" 116 | sExecute qrysth [] 117 | sFetchAllRows qrysth >>= (assertEqual "initial commit" [[Just "0"]]) 118 | 119 | -- Now try a rollback 120 | sExecuteMany sth rows 121 | rollback dbh 122 | sExecute qrysth [] 123 | sFetchAllRows qrysth >>= (assertEqual "rollback" [[Just "0"]]) 124 | 125 | -- Now try another commit 126 | sExecuteMany sth rows 127 | commit dbh 128 | sExecute qrysth [] 129 | sFetchAllRows qrysth >>= (assertEqual "final commit" ([Just "0"]:rows)) 130 | ) 131 | where rows = map (\x -> [Just . show $ x]) [1..9] 132 | 133 | testWithTransaction = dbTestCase (\dbh -> 134 | do assertBool "Connected database does not support transactions; skipping transaction test" (dbTransactionSupport dbh) 135 | sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('withTransaction', ?, NULL, NULL)" 136 | sExecute sth [Just "0"] 137 | commit dbh 138 | qrysth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'withTransaction' ORDER BY testid" 139 | sExecute qrysth [] 140 | sFetchAllRows qrysth >>= (assertEqual "initial commit" [[Just "0"]]) 141 | 142 | -- Let's try a rollback. 143 | catch (withTransaction dbh (\_ -> do sExecuteMany sth rows 144 | fail "Foo")) 145 | (\SomeException{} -> return ()) 146 | sExecute qrysth [] 147 | sFetchAllRows qrysth >>= (assertEqual "rollback" [[Just "0"]]) 148 | 149 | -- And now a commit. 150 | withTransaction dbh (\_ -> sExecuteMany sth rows) 151 | sExecute qrysth [] 152 | sFetchAllRows qrysth >>= (assertEqual "final commit" ([Just "0"]:rows)) 153 | ) 154 | where rows = map (\x -> [Just . show $ x]) [1..9] 155 | 156 | tests = TestList 157 | [ 158 | TestLabel "openClosedb" openClosedb, 159 | TestLabel "multiFinish" multiFinish, 160 | TestLabel "runRawTest" runRawTest, 161 | TestLabel "runRawErrorTest" runRawErrorTest, 162 | TestLabel "basicQueries" basicQueries, 163 | TestLabel "createTable" createTable, 164 | TestLabel "runReplace" runReplace, 165 | TestLabel "executeReplace" executeReplace, 166 | TestLabel "executeMany" testExecuteMany, 167 | TestLabel "sFetchAllRows" testsFetchAllRows, 168 | TestLabel "basicTransactions" basicTransactions, 169 | TestLabel "withTransaction" testWithTransaction, 170 | TestLabel "dropTable" dropTable 171 | ] 172 | -------------------------------------------------------------------------------- /test-hdbc-postgresql/TestTime.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, CPP #-} 2 | 3 | module TestTime(tests) where 4 | import Test.HUnit 5 | import Database.HDBC 6 | import TestUtils 7 | import Control.Exception 8 | import Data.Time (UTCTime, Day, NominalDiffTime) 9 | import Data.Time.LocalTime 10 | import Data.Time.Clock.POSIX 11 | import Data.Maybe 12 | import Data.Convertible 13 | import SpecificDB 14 | #if MIN_VERSION_time(1, 5, 0) 15 | import Data.Time (parseTimeM, defaultTimeLocale) 16 | #else 17 | import Data.Time (parseTime) 18 | import System.Locale(defaultTimeLocale) 19 | #endif 20 | import Database.HDBC.Locale (iso8601DateFormat) 21 | import qualified System.Time as ST 22 | 23 | instance Eq ZonedTime where 24 | a == b = zonedTimeToUTC a == zonedTimeToUTC b 25 | 26 | testZonedTime :: ZonedTime 27 | testZonedTime = fromJust $ parseTime' defaultTimeLocale (iso8601DateFormat (Just "%T %z")) 28 | "1989-08-01 15:33:01 -0500" 29 | 30 | testZonedTimeFrac :: ZonedTime 31 | testZonedTimeFrac = fromJust $ parseTime' defaultTimeLocale (iso8601DateFormat (Just "%T%Q %z")) 32 | "1989-08-01 15:33:01.536 -0500" 33 | 34 | 35 | rowdata t = [[SqlInt32 100, toSql t, SqlNull]] 36 | 37 | testDTType :: (Convertible SqlValue a, Show b, Eq b) => 38 | a 39 | -> (a -> SqlValue) 40 | -> (a -> b) 41 | -> Test 42 | testDTType inputdata convToSqlValue toComparable = dbTestCase $ \dbh -> 43 | do run dbh ("CREATE TABLE hdbctesttime (testid INTEGER PRIMARY KEY NOT NULL, testvalue " ++ dateTimeTypeOfSqlValue value ++ ")") [] 44 | commit dbh 45 | finally (testIt dbh) (do commit dbh 46 | run dbh "DROP TABLE hdbctesttime" [] 47 | commit dbh 48 | ) 49 | where testIt dbh = 50 | do run dbh "INSERT INTO hdbctesttime (testid, testvalue) VALUES (?, ?)" 51 | [iToSql 5, value] 52 | commit dbh 53 | r <- quickQuery' dbh "SELECT testid, testvalue FROM hdbctesttime" [] 54 | case r of 55 | [[testidsv, testvaluesv]] -> 56 | do assertEqual "testid" (5::Int) (fromSql testidsv) 57 | assertEqual "testvalue" 58 | (toComparable inputdata) 59 | (toComparable$ fromSql testvaluesv) 60 | value = convToSqlValue inputdata 61 | 62 | mkTest label inputdata convfunc toComparable = 63 | TestLabel label (testDTType inputdata convfunc toComparable) 64 | 65 | tests = TestList $ 66 | ((TestLabel "Non-frac" $ testIt testZonedTime) : 67 | if supportsFracTime then [TestLabel "Frac" $ testIt testZonedTimeFrac] else []) 68 | 69 | testIt baseZonedTime = 70 | TestList [ mkTest "Day" baseDay toSql id 71 | , mkTest "TimeOfDay" baseTimeOfDay toSql id 72 | , mkTest "ZonedTimeOfDay" baseZonedTimeOfDay toSql id 73 | , mkTest "LocalTime" baseLocalTime toSql id 74 | , mkTest "ZonedTime" baseZonedTime toSql id 75 | , mkTest "UTCTime" baseUTCTime toSql id 76 | , mkTest "DiffTime" baseDiffTime toSql id 77 | , mkTest "POSIXTime" basePOSIXTime posixToSql id 78 | , mkTest "ClockTime" baseClockTime toSql id 79 | , mkTest "CalendarTime" baseCalendarTime toSql ST.toClockTime 80 | , mkTest "TimeDiff" baseTimeDiff toSql id 81 | ] 82 | where 83 | baseDay :: Day 84 | baseDay = localDay baseLocalTime 85 | 86 | baseTimeOfDay :: TimeOfDay 87 | baseTimeOfDay = localTimeOfDay baseLocalTime 88 | 89 | baseZonedTimeOfDay :: (TimeOfDay, TimeZone) 90 | baseZonedTimeOfDay = fromSql (SqlZonedTime baseZonedTime) 91 | 92 | baseLocalTime :: LocalTime 93 | baseLocalTime = zonedTimeToLocalTime baseZonedTime 94 | 95 | baseUTCTime :: UTCTime 96 | baseUTCTime = convert baseZonedTime 97 | 98 | baseDiffTime :: NominalDiffTime 99 | baseDiffTime = basePOSIXTime 100 | 101 | basePOSIXTime :: POSIXTime 102 | basePOSIXTime = convert baseZonedTime 103 | 104 | baseTimeDiff :: ST.TimeDiff 105 | baseTimeDiff = convert baseDiffTime 106 | 107 | -- No fractional parts for these two 108 | 109 | baseClockTime :: ST.ClockTime 110 | baseClockTime = convert testZonedTime 111 | 112 | baseCalendarTime :: ST.CalendarTime 113 | baseCalendarTime = convert testZonedTime 114 | 115 | #if MIN_VERSION_time(1, 5, 0) 116 | parseTime' = parseTimeM True 117 | #else 118 | parseTime' = parseTime 119 | #endif 120 | -------------------------------------------------------------------------------- /test-hdbc-postgresql/TestUtils.hs: -------------------------------------------------------------------------------- 1 | module TestUtils(connectDB, sqlTestCase, dbTestCase, printDBInfo) where 2 | import Database.HDBC 3 | import Test.HUnit 4 | import Control.Exception 5 | import SpecificDB(connectDB) 6 | 7 | sqlTestCase a = 8 | TestCase (handleSqlError a) 9 | 10 | dbTestCase a = 11 | TestCase (do dbh <- connectDB 12 | finally (handleSqlError (a dbh)) 13 | (handleSqlError (disconnect dbh)) 14 | ) 15 | 16 | printDBInfo = handleSqlError $ 17 | do dbh <- connectDB 18 | putStrLn "+-------------------------------------------------------------------------" 19 | putStrLn $ "| Testing HDBC database module: " ++ hdbcDriverName dbh ++ 20 | ", bound to client: " ++ hdbcClientVer dbh 21 | putStrLn $ "| Proxied driver: " ++ proxiedClientName dbh ++ 22 | ", bound to version: " ++ proxiedClientVer dbh 23 | putStrLn $ "| Connected to server version: " ++ dbServerVer dbh 24 | putStrLn "+-------------------------------------------------------------------------\n" 25 | disconnect dbh 26 | -------------------------------------------------------------------------------- /test-hdbc-postgresql/Testbasics.hs: -------------------------------------------------------------------------------- 1 | module Testbasics(tests) where 2 | import Test.HUnit 3 | import Database.HDBC 4 | import TestUtils 5 | import System.IO 6 | import Control.Exception 7 | 8 | openClosedb = sqlTestCase $ 9 | do dbh <- connectDB 10 | disconnect dbh 11 | 12 | multiFinish = dbTestCase (\dbh -> 13 | do sth <- prepare dbh "SELECT 1 + 1" 14 | r <- execute sth [] 15 | assertEqual "basic count" 0 r 16 | finish sth 17 | finish sth 18 | finish sth 19 | ) 20 | 21 | basicQueries = dbTestCase (\dbh -> 22 | do sth <- prepare dbh "SELECT 1 + 1" 23 | execute sth [] >>= (0 @=?) 24 | r <- fetchAllRows sth 25 | assertEqual "converted from" [["2"]] (map (map fromSql) r) 26 | assertEqual "int32 compare" [[SqlInt32 2]] r 27 | assertEqual "iToSql compare" [[iToSql 2]] r 28 | assertEqual "num compare" [[toSql (2::Int)]] r 29 | assertEqual "nToSql compare" [[nToSql (2::Int)]] r 30 | assertEqual "string compare" [[SqlString "2"]] r 31 | ) 32 | 33 | createTable = dbTestCase (\dbh -> 34 | do run dbh "CREATE TABLE hdbctest1 (testname VARCHAR(20), testid INTEGER, testint INTEGER, testtext TEXT)" [] 35 | commit dbh 36 | ) 37 | 38 | dropTable = dbTestCase (\dbh -> 39 | do run dbh "DROP TABLE hdbctest1" [] 40 | commit dbh 41 | ) 42 | 43 | runReplace = dbTestCase (\dbh -> 44 | do r <- run dbh "INSERT INTO hdbctest1 VALUES (?, ?, ?, ?)" r1 45 | assertEqual "insert retval" 1 r 46 | run dbh "INSERT INTO hdbctest1 VALUES (?, ?, ?, ?)" r2 47 | commit dbh 48 | sth <- prepare dbh "SELECT * FROM hdbctest1 WHERE testname = 'runReplace' ORDER BY testid" 49 | rv2 <- execute sth [] 50 | assertEqual "select retval" 0 rv2 51 | r <- fetchAllRows sth 52 | assertEqual "" [r1, r2] r 53 | ) 54 | where r1 = [toSql "runReplace", iToSql 1, iToSql 1234, SqlString "testdata"] 55 | r2 = [toSql "runReplace", iToSql 2, iToSql 2, SqlNull] 56 | 57 | executeReplace = dbTestCase (\dbh -> 58 | do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('executeReplace',?,?,?)" 59 | execute sth [iToSql 1, iToSql 1234, toSql "Foo"] 60 | execute sth [SqlInt32 2, SqlNull, toSql "Bar"] 61 | commit dbh 62 | sth <- prepare dbh "SELECT * FROM hdbctest1 WHERE testname = ? ORDER BY testid" 63 | execute sth [SqlString "executeReplace"] 64 | r <- fetchAllRows sth 65 | assertEqual "result" 66 | [[toSql "executeReplace", iToSql 1, toSql "1234", 67 | toSql "Foo"], 68 | [toSql "executeReplace", iToSql 2, SqlNull, 69 | toSql "Bar"]] 70 | r 71 | ) 72 | 73 | testExecuteMany = dbTestCase (\dbh -> 74 | do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('multi',?,?,?)" 75 | executeMany sth rows 76 | commit dbh 77 | sth <- prepare dbh "SELECT testid, testint, testtext FROM hdbctest1 WHERE testname = 'multi'" 78 | execute sth [] 79 | r <- fetchAllRows sth 80 | assertEqual "" rows r 81 | ) 82 | where rows = [map toSql ["1", "1234", "foo"], 83 | map toSql ["2", "1341", "bar"], 84 | [toSql "3", SqlNull, SqlNull]] 85 | 86 | testFetchAllRows = dbTestCase (\dbh -> 87 | do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('sFetchAllRows', ?, NULL, NULL)" 88 | executeMany sth rows 89 | commit dbh 90 | sth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'sFetchAllRows' ORDER BY testid" 91 | execute sth [] 92 | results <- fetchAllRows sth 93 | assertEqual "" rows results 94 | ) 95 | where rows = map (\x -> [iToSql x]) [1..9] 96 | 97 | testFetchAllRows' = dbTestCase (\dbh -> 98 | do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('sFetchAllRows2', ?, NULL, NULL)" 99 | executeMany sth rows 100 | commit dbh 101 | sth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'sFetchAllRows2' ORDER BY testid" 102 | execute sth [] 103 | results <- fetchAllRows' sth 104 | assertEqual "" rows results 105 | ) 106 | where rows = map (\x -> [iToSql x]) [1..9] 107 | 108 | basicTransactions = dbTestCase (\dbh -> 109 | do assertBool "Connected database does not support transactions; skipping transaction test" (dbTransactionSupport dbh) 110 | sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('basicTransactions', ?, NULL, NULL)" 111 | execute sth [iToSql 0] 112 | commit dbh 113 | qrysth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'basicTransactions' ORDER BY testid" 114 | execute qrysth [] 115 | fetchAllRows qrysth >>= (assertEqual "initial commit" [[toSql "0"]]) 116 | 117 | -- Now try a rollback 118 | executeMany sth rows 119 | rollback dbh 120 | execute qrysth [] 121 | fetchAllRows qrysth >>= (assertEqual "rollback" [[toSql "0"]]) 122 | 123 | -- Now try another commit 124 | executeMany sth rows 125 | commit dbh 126 | execute qrysth [] 127 | fetchAllRows qrysth >>= (assertEqual "final commit" ([SqlString "0"]:rows)) 128 | ) 129 | where rows = map (\x -> [iToSql $ x]) [1..9] 130 | 131 | testWithTransaction = dbTestCase (\dbh -> 132 | do assertBool "Connected database does not support transactions; skipping transaction test" (dbTransactionSupport dbh) 133 | sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('withTransaction', ?, NULL, NULL)" 134 | execute sth [toSql "0"] 135 | commit dbh 136 | qrysth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'withTransaction' ORDER BY testid" 137 | execute qrysth [] 138 | fetchAllRows qrysth >>= (assertEqual "initial commit" [[toSql "0"]]) 139 | 140 | -- Let's try a rollback. 141 | catch (withTransaction dbh (\_ -> do executeMany sth rows 142 | fail "Foo")) 143 | (\SomeException{} -> return ()) 144 | execute qrysth [] 145 | fetchAllRows qrysth >>= (assertEqual "rollback" [[SqlString "0"]]) 146 | 147 | -- And now a commit. 148 | withTransaction dbh (\_ -> executeMany sth rows) 149 | execute qrysth [] 150 | fetchAllRows qrysth >>= (assertEqual "final commit" ([iToSql 0]:rows)) 151 | ) 152 | where rows = map (\x -> [iToSql x]) [1..9] 153 | 154 | tests = TestList 155 | [ 156 | TestLabel "openClosedb" openClosedb, 157 | TestLabel "multiFinish" multiFinish, 158 | TestLabel "basicQueries" basicQueries, 159 | TestLabel "createTable" createTable, 160 | TestLabel "runReplace" runReplace, 161 | TestLabel "executeReplace" executeReplace, 162 | TestLabel "executeMany" testExecuteMany, 163 | TestLabel "fetchAllRows" testFetchAllRows, 164 | TestLabel "fetchAllRows'" testFetchAllRows', 165 | TestLabel "basicTransactions" basicTransactions, 166 | TestLabel "withTransaction" testWithTransaction, 167 | TestLabel "dropTable" dropTable 168 | ] 169 | -------------------------------------------------------------------------------- /test-hdbc-postgresql/Tests.hs: -------------------------------------------------------------------------------- 1 | {- arch-tag: Tests main file 2 | -} 3 | 4 | module Tests(tests) where 5 | import Test.HUnit 6 | import qualified Testbasics 7 | import qualified TestSbasics 8 | import qualified SpecificDBTests 9 | import qualified TestMisc 10 | import qualified TestTime 11 | 12 | test1 = TestCase ("x" @=? "x") 13 | 14 | tests = TestList [TestLabel "test1" test1, 15 | TestLabel "String basics" TestSbasics.tests, 16 | TestLabel "SqlValue basics" Testbasics.tests, 17 | TestLabel "SpecificDB" SpecificDBTests.tests, 18 | TestLabel "Misc tests" TestMisc.tests, 19 | TestLabel "Time tests" TestTime.tests] 20 | -------------------------------------------------------------------------------- /test-hdbc-postgresql/runtests.hs: -------------------------------------------------------------------------------- 1 | {- arch-tag: Test runner 2 | -} 3 | 4 | module Main where 5 | 6 | import Test.HUnit 7 | import Tests 8 | import TestUtils 9 | 10 | main = do printDBInfo 11 | runTestTT tests 12 | 13 | -------------------------------------------------------------------------------- /test-original/Database/HDBC/PostgreSQL/PureSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NamedFieldPuns #-} 2 | {-# LANGUAGE TypeApplications #-} 3 | 4 | module Database.HDBC.PostgreSQL.PureSpec (spec) where 5 | 6 | import Database.HDBC 7 | import Database.HDBC.PostgreSQL.Pure 8 | 9 | import Test.Hspec 10 | 11 | import Control.Exception.Safe (try) 12 | import Control.Monad (void) 13 | import Data.Default.Class (Default (def)) 14 | import Data.Maybe (fromMaybe) 15 | import System.Environment (lookupEnv) 16 | 17 | {-# ANN module ("HLint: ignore Redundant do" :: String) #-} 18 | {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} 19 | 20 | spec :: Spec 21 | spec = do 22 | beforeAll 23 | ( do 24 | host <- getEnvDef "PURE_HOST" "127.0.0.1" 25 | port <- getEnvDef "PURE_PORT" "5432" 26 | user <- getEnvDef "PURE_USER" "postgres" 27 | password <- getEnvDef "PURE_PASSWORD" "" 28 | database <- getEnvDef "PURE_DATABASE" "postgres" 29 | let 30 | config = 31 | def 32 | { address = AddressNotResolved host port 33 | , user 34 | , password 35 | , database 36 | } 37 | connect config 38 | ) 39 | $ afterAll 40 | disconnect 41 | $ do 42 | describe "CREATE TABLE/DROP TABLE" $ do 43 | it "prepare/execute" $ \conn -> do 44 | statement <- prepare conn "CREATE TABLE test (value INT NOT NULL)" 45 | n <- execute statement [] 46 | n `shouldBe` 0 47 | statement <- prepare conn "DROP TABLE IF EXISTS test" 48 | n <- execute statement [] 49 | n `shouldBe` 0 50 | commit conn 51 | pure () 52 | 53 | it "run" $ \conn -> do 54 | run conn "CREATE TABLE test (value INT NOT NULL)" [] `shouldReturn` 0 55 | run conn "DROP TABLE IF EXISTS test" [] `shouldReturn` 0 56 | commit conn 57 | 58 | it "runRaw" $ \conn -> do 59 | let 60 | query = 61 | "CREATE TABLE test (value INT NOT NULL);\ 62 | \DROP TABLE IF EXISTS test" 63 | runRaw conn query 64 | commit conn 65 | 66 | beforeWith 67 | ( \conn -> do 68 | let 69 | query = 70 | "CREATE TABLE test (value INT NOT NULL);\ 71 | \INSERT INTO test (value) VALUES (0), (1), (2)" 72 | runRaw conn query 73 | commit conn 74 | pure conn 75 | ) 76 | $ after 77 | ( \conn -> do 78 | void $ try @IO @SqlError $ do 79 | runRaw conn "DROP TABLE IF EXISTS test" 80 | commit conn 81 | ) 82 | $ do 83 | describe "table: test (value INT NOT NULL)" $ do 84 | it "DELETE FROM test WHERE value = 0" $ \conn -> do 85 | run conn "DELETE FROM test WHERE value = 0" [] `shouldReturn` 1 86 | commit conn 87 | 88 | it "UPDATE test SET value = 10 WHERE value = 1" $ \conn -> do 89 | run conn "UPDATE test SET value = 10 WHERE value = 1" [] `shouldReturn` 1 90 | commit conn 91 | 92 | it "SELECT value FROM test ORDER BY value (reuse portal)" $ \conn -> do 93 | s <- prepare conn "SELECT value FROM test ORDER BY value" 94 | executeRaw s 95 | fetchRow s `shouldReturn` Just [SqlInt32 0] 96 | fetchRow s `shouldReturn` Just [SqlInt32 1] 97 | fetchRow s `shouldReturn` Just [SqlInt32 2] 98 | fetchRow s `shouldReturn` Nothing 99 | finish s 100 | 101 | it "SELECT value FROM test WHERE value = $1 (reuse prepared statement)" $ \conn -> do 102 | s <- prepare conn "SELECT value FROM test WHERE value = ?" 103 | void $ execute s [SqlInt32 0] 104 | fetchRow s `shouldReturn` Just [SqlInt32 0] 105 | void $ execute s [SqlInt32 1] 106 | fetchRow s `shouldReturn` Just [SqlInt32 1] 107 | void $ execute s [SqlInt32 2] 108 | fetchRow s `shouldReturn` Just [SqlInt32 2] 109 | finish s 110 | 111 | it "BEGIN/ROLLBACK" $ \conn -> do 112 | begin conn 113 | rollback conn 114 | 115 | it "BEGIN/COMMIT" $ \conn -> do 116 | begin conn 117 | commit conn 118 | 119 | getEnvDef :: String -> String -> IO String 120 | getEnvDef name value = fromMaybe value <$> lookupEnv name 121 | -------------------------------------------------------------------------------- /test-original/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /test-original/Test/Hspec/Core/Hooks/Extra.hs: -------------------------------------------------------------------------------- 1 | module Test.Hspec.Core.Hooks.Extra 2 | ( beforeAllWith 3 | ) where 4 | 5 | import Test.Hspec.Core.Hooks 6 | import Test.Hspec.Core.Spec 7 | 8 | import Control.Concurrent.MVar (MVar, modifyMVar, newMVar) 9 | import Control.Exception (SomeException, throwIO, try) 10 | 11 | data Memoized a = 12 | Empty 13 | | Memoized a 14 | | Failed SomeException 15 | 16 | memoize :: MVar (Memoized a) -> IO a -> IO a 17 | memoize mvar action = do 18 | result <- modifyMVar mvar $ \ma -> case ma of 19 | Empty -> do 20 | a <- try action 21 | return (either Failed Memoized a, a) 22 | Memoized a -> return (ma, Right a) 23 | Failed _ -> throwIO (Pending Nothing (Just "exception in beforeAll-hook (see previous failure)")) 24 | either throwIO return result 25 | 26 | -- | Run a custom action befor the first spec item. 27 | beforeAllWith :: (b -> IO a) -> SpecWith a -> SpecWith b 28 | beforeAllWith action spec = do 29 | mver <- runIO (newMVar Empty) 30 | beforeWith (memoize mver . action) spec 31 | -------------------------------------------------------------------------------- /test-relational-record/DataSource.hs: -------------------------------------------------------------------------------- 1 | module DataSource (connect) where 2 | 3 | import Data.Maybe (fromMaybe) 4 | import Database.HDBC.PostgreSQL (Connection, connectPostgreSQL) 5 | import System.Environment (lookupEnv) 6 | 7 | connect :: IO Connection 8 | connect = do 9 | host <- getEnvDef "PURE_HOST" "127.0.0.1" 10 | port <- getEnvDef "PURE_PORT" "5432" 11 | user <- getEnvDef "PURE_USER" "postgres" 12 | password <- getEnvDef "PURE_PASSWORD" "" 13 | database <- getEnvDef "PURE_DATABASE" "postgres" 14 | connectPostgreSQL $ "host='" ++ host ++ "' port='" ++ port ++ "'user='" ++ user ++"' password = '" ++ password ++ "' dbname = '" ++ database ++ "'" 15 | 16 | getEnvDef :: String -> String -> IO String 17 | getEnvDef name value = fromMaybe value <$> lookupEnv name 18 | -------------------------------------------------------------------------------- /test-relational-record/DataSource/Pure.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NamedFieldPuns #-} 2 | 3 | module DataSource.Pure (connect) where 4 | 5 | import Data.Default.Class (def) 6 | import Data.Maybe (fromMaybe) 7 | import qualified Database.HDBC.PostgreSQL.Pure as Pure 8 | import System.Environment (lookupEnv) 9 | 10 | connect :: IO Pure.Connection 11 | connect = do 12 | host <- getEnvDef "PURE_HOST" "127.0.0.1" 13 | port <- getEnvDef "PURE_PORT" "5432" 14 | user <- getEnvDef "PURE_USER" "postgres" 15 | password <- getEnvDef "PURE_PASSWORD" "" 16 | database <- getEnvDef "PURE_DATABASE" "postgres" 17 | let 18 | config = 19 | def 20 | { Pure.address = Pure.AddressNotResolved host port 21 | , Pure.user 22 | , Pure.password 23 | , Pure.database 24 | } 25 | Pure.connect config 26 | 27 | getEnvDef :: String -> String -> IO String 28 | getEnvDef name value = fromMaybe value <$> lookupEnv name 29 | -------------------------------------------------------------------------------- /test-relational-record/Relation/Person.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE TemplateHaskell #-} 6 | 7 | module Relation.Person where 8 | 9 | import DataSource (connect) 10 | 11 | import Prelude (Show) 12 | 13 | import Database.HDBC.Query.TH (defineTableFromDB) 14 | import Database.HDBC.Schema.PostgreSQL (driverPostgreSQL) 15 | import GHC.Generics (Generic) 16 | 17 | defineTableFromDB connect driverPostgreSQL "public" "person" [''Show, ''Generic] 18 | -------------------------------------------------------------------------------- /test-relational-record/Relation/Pure/Person.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE TemplateHaskell #-} 6 | 7 | module Relation.Pure.Person where 8 | 9 | import DataSource.Pure (connect) 10 | 11 | import Prelude (Show) 12 | 13 | import Database.HDBC.Query.TH (defineTableFromDB) 14 | import Database.HDBC.Schema.PostgreSQL (driverPostgreSQL) 15 | import GHC.Generics (Generic) 16 | 17 | defineTableFromDB connect driverPostgreSQL "public" "person" [''Show, ''Generic] 18 | -------------------------------------------------------------------------------- /test-relational-record/Spec.hs: -------------------------------------------------------------------------------- 1 | import Database.HDBC.Record (runQuery) 2 | import Database.HDBC.Session (handleSqlError', withConnectionIO) 3 | import Database.Relational (relationalQuery) 4 | import Test.Hspec 5 | 6 | import qualified DataSource as DS 7 | import qualified DataSource.Pure as DSP 8 | import qualified Relation.Person as Person 9 | import qualified Relation.Pure.Person as PersonPure 10 | 11 | {-# ANN module "HLint: ignore Redundant do" #-} 12 | 13 | main :: IO () 14 | main = hspec $ do 15 | it "run" $ do 16 | handleSqlError' $ withConnectionIO DS.connect $ \conn -> withConnectionIO DSP.connect $ \connPure -> do 17 | persons <- ((\(Person.Person id name) -> (id, name)) <$>) <$> runQuery conn (relationalQuery Person.person) () 18 | personsPure <- ((\(PersonPure.Person id name) -> (id, name)) <$>) <$> runQuery connPure (relationalQuery PersonPure.person) () 19 | personsPure `shouldBe` persons 20 | --------------------------------------------------------------------------------