git.iko.soy/typeable/postgresql-simple
on 51e1dfc help sign in
3ac2949
swap
0 ahead, 678 behind
70 files changed+1740−10537
since splitsnapshots
unifiedsplit
.github/workflows/haskell-ci.yml−256 .github/workflows/simple.yml−58 .gitignore+1−8 CHANGES.md−746 CONTRIBUTING.md−13 CONTRIBUTORS−36 README.md−4 bench/Select.hs−32 cabal.haskell-ci−5 cabal.project−4 cabal.project.local.win−4 postgresql-simple.cabal+57−171 sdist.sh−25 src/Database/PostgreSQL/Simple.hs+362−390 src/Database/PostgreSQL/Simple.hs-boot−23 src/Database/PostgreSQL/Simple/Arrays.hs−92 src/Database/PostgreSQL/Simple/BuiltinTypes.hs+403 src/Database/PostgreSQL/Simple/Compat.hs−41 src/Database/PostgreSQL/Simple/Copy.hs−269 src/Database/PostgreSQL/Simple/Cursor.hs−98 src/Database/PostgreSQL/Simple/Errors.hs−140 src/Database/PostgreSQL/Simple/Field.hs+15 src/Database/PostgreSQL/Simple/FromField.hs+146−571 src/Database/PostgreSQL/Simple/FromField.hs-boot−11 src/Database/PostgreSQL/Simple/FromRow.hs+106−398 src/Database/PostgreSQL/Simple/FromRow.hs-boot−17 src/Database/PostgreSQL/Simple/HStore.hs−36 src/Database/PostgreSQL/Simple/HStore/Implementation.hs−210 src/Database/PostgreSQL/Simple/HStore/Internal.hs−19 src/Database/PostgreSQL/Simple/Internal.hs+66−457 src/Database/PostgreSQL/Simple/Internal/PQResultUtils.hs−123 src/Database/PostgreSQL/Simple/LargeObjects.hs+7−14 src/Database/PostgreSQL/Simple/Newtypes.hs−49 src/Database/PostgreSQL/Simple/Notification.hs+29−120 src/Database/PostgreSQL/Simple/Ok.hs+12−47 src/Database/PostgreSQL/Simple/Param.hs+206 src/Database/PostgreSQL/Simple/QueryParams.hs+85 src/Database/PostgreSQL/Simple/Range.hs−317 src/Database/PostgreSQL/Simple/SqlQQ.hs+23−37 src/Database/PostgreSQL/Simple/Time.hs−246 src/Database/PostgreSQL/Simple/Time/Implementation.hs−176 src/Database/PostgreSQL/Simple/Time/Internal.hs−27 src/Database/PostgreSQL/Simple/Time/Internal/Parser.hs−204 src/Database/PostgreSQL/Simple/Time/Internal/Printer.hs−135 src/Database/PostgreSQL/Simple/ToField.hs−393 src/Database/PostgreSQL/Simple/ToField.hs-boot−30 src/Database/PostgreSQL/Simple/ToRow.hs−219 src/Database/PostgreSQL/Simple/ToRow.hs-boot−18 src/Database/PostgreSQL/Simple/Transaction.hs−264 src/Database/PostgreSQL/Simple/TypeInfo.hs−121 src/Database/PostgreSQL/Simple/TypeInfo/Macro.hs−53 src/Database/PostgreSQL/Simple/TypeInfo/Static.hs−1802 src/Database/PostgreSQL/Simple/TypeInfo/Types.hs−56 src/Database/PostgreSQL/Simple/Types.hs+36−186 src/Database/PostgreSQL/Simple/Vector.hs−45 src/Database/PostgreSQL/Simple/Vector/Unboxed.hs−44 test/Common.hs−32 test/Exception.hs−70 test/Inspection.hs−79 test/Interval.hs−176 test/Main.hs−648 test/Notify.hs−41 test/Serializable.hs−68 test/Time.hs−119 test/WRITING-TESTS−42 test/results/malformed-input.expected−4 test/results/unique-constraint-violation.expected−5 tools/GenBuiltinTypes.hs+185 tools/GenTypeInfo.hs−381 tools/StringsQQ.hs+1−12
.github/workflows/haskell-ci.ymldeleted−256
@@ -1,256 +0,0 @@
1−# This GitHub workflow config has been generated by a script via
2−#
3−# haskell-ci 'github' 'cabal.project'
4−#
5−# To regenerate the script (for example after adjusting tested-with) run
6−#
7−# haskell-ci regenerate
8−#
9−# For more information, see https://github.com/haskell-CI/haskell-ci
10−#
11−# version: 0.17.20231110
12−#
13−# REGENDATA ("0.17.20231110",["github","cabal.project"])
14−#
15−name: Haskell-CI
16−on:
17− push:
18− branches:
19− - master
20− pull_request:
21− branches:
22− - master
23−jobs:
24− linux:
25− name: Haskell-CI - Linux - ${{ matrix.compiler }}
26− runs-on: ubuntu-20.04
27− timeout-minutes:
28− 60
29− container:
30− image: buildpack-deps:bionic
31− services:
32− postgres:
33− image: postgres:14
34− env:
35− POSTGRES_PASSWORD: postgres
36− options: --health-cmd pg_isready --health-interval 10s --health-timeout 5s --health-retries 5
37− continue-on-error: ${{ matrix.allow-failure }}
38− strategy:
39− matrix:
40− include:
41− - compiler: ghc-9.8.1
42− compilerKind: ghc
43− compilerVersion: 9.8.1
44− setup-method: ghcup
45− allow-failure: false
46− - compiler: ghc-9.6.3
47− compilerKind: ghc
48− compilerVersion: 9.6.3
49− setup-method: ghcup
50− allow-failure: false
51− - compiler: ghc-9.4.8
52− compilerKind: ghc
53− compilerVersion: 9.4.8
54− setup-method: ghcup
55− allow-failure: false
56− - compiler: ghc-9.2.8
57− compilerKind: ghc
58− compilerVersion: 9.2.8
59− setup-method: ghcup
60− allow-failure: false
61− - compiler: ghc-9.0.2
62− compilerKind: ghc
63− compilerVersion: 9.0.2
64− setup-method: ghcup
65− allow-failure: false
66− - compiler: ghc-8.10.7
67− compilerKind: ghc
68− compilerVersion: 8.10.7
69− setup-method: ghcup
70− allow-failure: false
71− - compiler: ghc-8.8.4
72− compilerKind: ghc
73− compilerVersion: 8.8.4
74− setup-method: hvr-ppa
75− allow-failure: false
76− - compiler: ghc-8.6.5
77− compilerKind: ghc
78− compilerVersion: 8.6.5
79− setup-method: hvr-ppa
80− allow-failure: false
81− fail-fast: false
82− steps:
83− - name: apt
84− run: |
85− apt-get update
86− apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5
87− if [ "${{ matrix.setup-method }}" = ghcup ]; then
88− mkdir -p "$HOME/.ghcup/bin"
89− curl -sL https://downloads.haskell.org/ghcup/0.1.20.0/x86_64-linux-ghcup-0.1.20.0 > "$HOME/.ghcup/bin/ghcup"
90− chmod a+x "$HOME/.ghcup/bin/ghcup"
91− "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false)
92− "$HOME/.ghcup/bin/ghcup" install cabal 3.10.2.0 || (cat "$HOME"/.ghcup/logs/*.* && false)
93− else
94− apt-add-repository -y 'ppa:hvr/ghc'
95− apt-get update
96− apt-get install -y "$HCNAME"
97− mkdir -p "$HOME/.ghcup/bin"
98− curl -sL https://downloads.haskell.org/ghcup/0.1.20.0/x86_64-linux-ghcup-0.1.20.0 > "$HOME/.ghcup/bin/ghcup"
99− chmod a+x "$HOME/.ghcup/bin/ghcup"
100− "$HOME/.ghcup/bin/ghcup" install cabal 3.10.2.0 || (cat "$HOME"/.ghcup/logs/*.* && false)
101− fi
102− env:
103− HCKIND: ${{ matrix.compilerKind }}
104− HCNAME: ${{ matrix.compiler }}
105− HCVER: ${{ matrix.compilerVersion }}
106− - name: Set PATH and environment variables
107− run: |
108− echo "$HOME/.cabal/bin" >> $GITHUB_PATH
109− echo "LANG=C.UTF-8" >> "$GITHUB_ENV"
110− echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV"
111− echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV"
112− HCDIR=/opt/$HCKIND/$HCVER
113− if [ "${{ matrix.setup-method }}" = ghcup ]; then
114− HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER")
115− HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#')
116− HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#')
117− echo "HC=$HC" >> "$GITHUB_ENV"
118− echo "HCPKG=$HCPKG" >> "$GITHUB_ENV"
119− echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV"
120− echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.2.0 -vnormal+nowrap" >> "$GITHUB_ENV"
121− else
122− HC=$HCDIR/bin/$HCKIND
123− echo "HC=$HC" >> "$GITHUB_ENV"
124− echo "HCPKG=$HCDIR/bin/$HCKIND-pkg" >> "$GITHUB_ENV"
125− echo "HADDOCK=$HCDIR/bin/haddock" >> "$GITHUB_ENV"
126− echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.2.0 -vnormal+nowrap" >> "$GITHUB_ENV"
127− fi
128−
129− HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')
130− echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV"
131− echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV"
132− echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV"
133− echo "HEADHACKAGE=false" >> "$GITHUB_ENV"
134− echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV"
135− echo "GHCJSARITH=0" >> "$GITHUB_ENV"
136− env:
137− HCKIND: ${{ matrix.compilerKind }}
138− HCNAME: ${{ matrix.compiler }}
139− HCVER: ${{ matrix.compilerVersion }}
140− - name: env
141− run: |
142− env
143− - name: write cabal config
144− run: |
145− mkdir -p $CABAL_DIR
146− cat >> $CABAL_CONFIG <<EOF
147− remote-build-reporting: anonymous
148− write-ghc-environment-files: never
149− remote-repo-cache: $CABAL_DIR/packages
150− logs-dir: $CABAL_DIR/logs
151− world-file: $CABAL_DIR/world
152− extra-prog-path: $CABAL_DIR/bin
153− symlink-bindir: $CABAL_DIR/bin
154− installdir: $CABAL_DIR/bin
155− build-summary: $CABAL_DIR/logs/build.log
156− store-dir: $CABAL_DIR/store
157− install-dirs user
158− prefix: $CABAL_DIR
159− repository hackage.haskell.org
160− url: http://hackage.haskell.org/
161− EOF
162− cat >> $CABAL_CONFIG <<EOF
163− program-default-options
164− ghc-options: $GHCJOBS +RTS -M3G -RTS
165− EOF
166− cat $CABAL_CONFIG
167− - name: versions
168− run: |
169− $HC --version || true
170− $HC --print-project-git-commit-id || true
171− $CABAL --version || true
172− - name: update cabal index
173− run: |
174− $CABAL v2-update -v
175− - name: install cabal-plan
176− run: |
177− mkdir -p $HOME/.cabal/bin
178− curl -sL https://github.com/haskell-hvr/cabal-plan/releases/download/v0.7.3.0/cabal-plan-0.7.3.0-x86_64-linux.xz > cabal-plan.xz
179− echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c -
180− xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan
181− rm -f cabal-plan.xz
182− chmod a+x $HOME/.cabal/bin/cabal-plan
183− cabal-plan --version
184− - name: checkout
185− uses: actions/checkout@v3
186− with:
187− path: source
188− - name: initial cabal.project for sdist
189− run: |
190− touch cabal.project
191− echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project
192− cat cabal.project
193− - name: sdist
194− run: |
195− mkdir -p sdist
196− $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist
197− - name: unpack
198− run: |
199− mkdir -p unpacked
200− find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \;
201− - name: generate cabal.project
202− run: |
203− PKGDIR_postgresql_simple="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/postgresql-simple-[0-9.]*')"
204− echo "PKGDIR_postgresql_simple=${PKGDIR_postgresql_simple}" >> "$GITHUB_ENV"
205− rm -f cabal.project cabal.project.local
206− touch cabal.project
207− touch cabal.project.local
208− echo "packages: ${PKGDIR_postgresql_simple}" >> cabal.project
209− echo "package postgresql-simple" >> cabal.project
210− echo " ghc-options: -Werror=missing-methods" >> cabal.project
211− cat >> cabal.project <<EOF
212− allow-newer: cryptohash-md5-0.11.100.1:base
213− EOF
214− $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: $_ installed\n" unless /^(postgresql-simple)$/; }' >> cabal.project.local
215− cat cabal.project
216− cat cabal.project.local
217− - name: dump install plan
218− run: |
219− $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all
220− cabal-plan
221− - name: restore cache
222− uses: actions/cache/restore@v3
223− with:
224− key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }}
225− path: ~/.cabal/store
226− restore-keys: ${{ runner.os }}-${{ matrix.compiler }}-
227− - name: install dependencies
228− run: |
229− $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all
230− $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all
231− - name: build w/o tests
232− run: |
233− $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all
234− - name: build
235− run: |
236− $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always
237− - name: tests
238− run: |
239− $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct
240− - name: cabal check
241− run: |
242− cd ${PKGDIR_postgresql_simple} || false
243− ${CABAL} -vnormal check
244− - name: haddock
245− run: |
246− $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all
247− - name: unconstrained build
248− run: |
249− rm -f cabal.project.local
250− $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all
251− - name: save cache
252− uses: actions/cache/save@v3
253− if: always()
254− with:
255− key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }}
256− path: ~/.cabal/store
.github/workflows/simple.ymldeleted−58
@@ -1,58 +0,0 @@
1−name: Simple
2−on:
3− push:
4− branches:
5− - master
6− pull_request:
7− branches:
8− - master
9−
10−jobs:
11− native:
12− name: "Simple: GHC ${{ matrix.ghc }} on ${{ matrix.os }}"
13− runs-on: ${{ matrix.os }}
14− strategy:
15− matrix:
16− os: [macos-latest, windows-latest]
17− ghc: ['8.10','9.0','9.2','9.4.8','9.6.3','9.8.1']
18− fail-fast: false
19− timeout-minutes:
20− 60
21− steps:
22− - name: Set git to use LF
23− run: |
24− git config --global core.autocrlf false
25− git config --global core.eol lf
26−
27− - name: Set up Haskell
28− id: setup-haskell
29− uses: haskell/actions/setup@v2
30− with:
31− ghc-version: ${{ matrix.ghc }}
32− cabal-version: '3.10.2.0'
33−
34− - name: Set up PostgreSQL
35− uses: ikalnytskyi/action-setup-postgres@v3
36− id: postgres
37− with:
38− username: ci
39− password: sw0rdfish
40− database: test
41−
42− - name: Checkout
43− uses: actions/checkout@v3.0.2
44−
45− - name: Cache
46− uses: actions/cache@v2.1.3
47− with:
48− path: ${{ steps.setup-haskell.outputs.cabal-store }}
49− key: ${{ runner.os }}-${{ matrix.ghc }}-${{ github.sha }}
50− restore-keys: ${{ runner.os }}-${{ matrix.ghc }}-
51−
52− - name: Build
53− run: cabal build all --enable-tests
54−
55− - name: Test
56− run: cabal test all --enable-tests --test-show-details=direct
57− env:
58− DATABASE_CONNSTRING: ${{ steps.postgres.outputs.connection-uri }}
.gitignore+1−8
@@ -7,11 +7,4 @@ dist/
77*.o
88\#*\#
99.#*
10−/CHANGELOG.md
11−.cabal-sandbox/
12−.stack-work/
13−cabal.sandbox.config
14−/dist-newstyle
15−.ghc.environment.*
16−cabal.project.local
17−dump-core
10+postgresql-simple-*.tar.gz
CHANGES.mddeleted−746
@@ -1,746 +0,0 @@
1−### Version 0.7.0.0 (2023-07-31)
2−
3− * Remove Eq Null instance. (Future `base` may break it, we remove it profilacticly).
4− * Use `postgresql-libpq >=0.10.0.0`. It includes critical fixes,
5− by using `postgresql-simple >=0.7` you won't get older `postgresql-libpq`.
6− * Drop support for GHC prior 8.6
7− * Added a class for `postgresql-simple` exceptions: `SomePostgreSqlException`.
8− This allows to catch all `postgresql-simple` exceptions at once.
9− (c.f. `AsyncException` in `base).
10−
11−### Version 0.6.5.1 (2023-07-09)
12−
13− * Support `aeson-2.2.0.0`
14−
15−### Version 0.6.5 (2022-10-30)
16−
17− * Add `withConnect`
18−
19−### Version 0.6.4 (2021-01-06)
20−
21− * Add foldCopyData helper function
22− Thanks to Sebastián Estrella for the implementation
23− https://github.com/haskellari/postgresql-simple/pull/56
24− * Implement support for postgresql 'interval' type
25− Thanks to Andre Marques Lee for the implementation
26− https://github.com/haskellari/postgresql-simple/pull/60
27− * Depend on `time-compat` to provide uniform `time` related interface.
28−
29−### Version 0.6.3 (2020-11-15)
30−
31− * Add `fromFieldJSONByteString`
32− Thanks to tomjaguarpaw for the implementation
33− https://github.com/haskellari/postgresql-simple/pull/47
34− * Add `attoFieldParser`
35− Thanks to Victor Nawothnig for the implementation
36− https://github.com/haskellari/postgresql-simple/pull/45
37− * Add `Identity` and `Const` instance
38− Thanks to Cary Robbins for the implementation
39− https://github.com/haskellari/postgresql-simple/pull/46
40− * Add `withTransactionModeRetry'`, a variant of `withTransactionModeRetry`
41− for all exception types.
42− Thanks to Elliot Cameron for the implementation
43− https://github.com/haskellari/postgresql-simple/pull/42
44− * Fix spurious aborts when retrying transactions
45− Thanks to Elliot Cameron for the implementation
46− https://github.com/haskellari/postgresql-simple/pull/34
47− * Add `Database.PostgreSQL.Simple.Newtypes` module
48− with `Aeson` newtype.
49− https://github.com/haskellari/postgresql-simple/pull/55
50−
51−### Version 0.6.2 (2019-04-26)
52−
53− * Define `MonadFail Ok`.
54−
55−### Version 0.6.1 (2019-03-04)
56−
57− * Escape double '??' to a literal '?
58− Thanks to Felix Paulusma for the implementation.
59− https://github.com/phadej/postgresql-simple/pull/5
60−
61− * Mention GHC Generics support in the documentation.
62− Thanks to Gabriel Gonzalez for the implementation.
63− https://github.com/phadej/postgresql-simple/pull/6
64−
65− * Better error message for "Query resulted in a command response
66− Thanks to Max Amanshauser for the implementation.
67− https://github.com/phadej/postgresql-simple/pull/7
68−
69− * fromJSONField: Include JSONPath on JSON parse errors
70− Thanks to Simon Hengel for the implementation.
71− https://github.com/phadej/postgresql-simple/pull/2
72−
73− * No TH in implementation
74− https://github.com/phadej/postgresql-simple/pull/4
75−
76−### Version 0.6 (2018-10-16)
77−
78− * *Breaking change*: Use `Only` package's `Only` for a common 1-tuple.
79−
80− Consider a downstream library depending already both on
81− `Only` and `postgresql-simple` package. This library my define
82− a `MyClass` with instances for `Only.Only` and `PostgreSQL.Only`.
83− As now these types are the same, a library would break.
84− Therefore I consider "merging" types a breaking change.
85−
86− There are two ways for adopting this change in that scenario:
87−
88− - Either CPP-guard `PostgreSQL.Only` instance with
89−
90− ```haskell
91− #if !MIN_VERSION_postgresql_simple(0,6,0)
92− instance MyClass (PostgreSQL.Only a) where ...
93− #endif
94− ```
95−
96− - or simply remove it and add `postgresql-simple >=0.6` lower bound,
97− making sure that there's only single `Only`.
98−
99− * Add `ToField` instances for case-insensitive strict and lazy text.
100− Thanks to Max Tagher for the implementation.
101− https://github.com/lpsmith/postgresql-simple/pull/232
102−
103− * Add support to CockroachDB.
104− Thanks to Georte Steel.
105− https://github.com/lpsmith/postgresql-simple/pull/245
106−
107− * Add Generic ConnectInfo instance
108− Thanks to Dmitry Dzhus.
109− https://github.com/lpsmith/postgresql-simple/pull/235
110−
111− * Add `fromFieldRange :: Typeable a => FieldParser a -> FieldParser (PGRange a)`
112− https://github.com/lpsmith/postgresql-simple/pull/221
113−
114− * Add `fromFieldJSONByteString :: FieldParser ByteString`
115− https://github.com/lpsmith/postgresql-simple/pull/222/files
116−
117− * Fix off-by-one error in year builder.
118− Thanks to Nathan Ferris Hunter.
119− https://github.com/lpsmith/postgresql-simple/pull/230
120−
121− * Extend ToRow and FromRow to tuples of size 18
122− Thanks to Bardur Arantsson.
123− https://github.com/lpsmith/postgresql-simple/pull/229
124−
125− * Add `Vector` and `Vector.Unboxed` `query` variants.
126− These are more memory efficient
127− (especially, if you anyway will convert to some vector)
128− https://github.com/phadej/1
129−
130− * Documentation improvements
131− https://github.com/lpsmith/postgresql-simple/pull/227
132− https://github.com/lpsmith/postgresql-simple/pull/236
133−
134−### Version 0.5.4.0 (2018-05-23)
135− * Support GHC-8.4 (Semigroup/Monoid)
136−
137−### Version 0.5.3.0 (2017-05-15)
138− * Refactored some rudimentary cursor handling code out of the
139− implementation of the fold operators, into a new
140− `Database.PostgreSQL.Simple.Cursor` module, thanks to Bardur Arantsson.
141−
142− * Made the `FromField` instance for `Char` compatible with
143− postgresql's `bpchar` type. Thanks to Ivan Lazar Miljenovic for
144− reporting the issue.
145−
146− * Added `Show` and `Eq` instances for `Notification`, thanks to
147− Matvey Aksenov.
148−
149− * Fixed some example code, thanks to Matvey Aksenov.
150−
151− * Fixed a problem with using `conversionError` to throw exceptions
152− of type `SomeException`. Previously, the exception would be
153− wrapped in a second `SomeException` dynamic constructor which
154− would cause normal GHC typecase idioms over `SomeException` to fail.
155−
156−### Version 0.5.2.1 (2016-06-29)
157− * Bumped the lower bound for `base` to 4.6. Thanks to Herbert
158− Valerio Riedel for reporting the issue.
159−
160− * Added an `Eq` instance for `SqlError`, thanks to Chris Allen
161−
162− * Fixed a bug where a all-caps `"NULL"` text value inside a
163− postgresql array would get parsed as the SQL null value. Thanks
164− goes to Edgar Gomes and Silk for finding and fixing this mistake.
165−
166− * Modified `withTransaction` and friends to ignore `IOError`s when
167− attempting to roll back the transaction. This fixes a buggy
168− interaction between `withTransaction` and async exceptions (e.g.
169− `System.Timeout`) on unix platforms. Thanks goes to Erik
170− Hesselink and Silk for providing the test case that exposed this
171− issue.
172−
173− * Added the `testTimeout` regression test for the problem above.
174−
175−### Version 0.5.2.0 (2016-05-25)
176− * Significantly improved the error reporting from
177− `Copy.putCopyData`, thanks to Ben Gamari.
178−
179− * Moved the test suite to use `tasty`, with a big thanks
180− to Ben Gamari.
181−
182− * Added `FromField.optionalField`, and updated the documentation
183− of `FromField.fromJSONField`, as inspired by an email conversation
184− with Ian Wagner.
185−
186− * Updated all links in the haddocks to use https, and added a link
187− to the documentation of `connectPostgreSQL`.
188−
189− * Added a truncated changelog to the source distribution.
190−
191−### Version 0.5.1.3 (2016-04-30)
192− * Implemented the Monad of No Return proposal, future-proofing
193− postgresql-simple against future releases of GHC.
194−
195− * Fixed a rare and usually benign race condition where
196− `getNotification` could end up waiting on a newly reallocated
197− file descriptor index, potentially leading to deadlock if the
198− descriptor does not become readable promptly. This fix only
199− applies to GHC 7.8 or later, as it depends on `threadWaitReadSTM`.
200−
201− * Tweaked the time parsers to accept times of day of the form `hh:mm`,
202− omitting seconds, following changes made to aeson.
203−
204− * Updated the documentation of the `In` type to point out a gotcha
205− when using the SQL fragment `... NOT IN ?` with `In []`. Thanks
206− goes to Simon Michael and Dan Haraj for bringing this issue to
207− my attention.
208−
209−### Version 0.5.1.2 (2015-12-14)
210− * The syntax generated for empty arrays was changed so that
211− postgresql's type inference would work better, thanks to
212− Amit Levy.
213−
214− * Further revision and expansion of the new Time documentation.
215−
216−### Version 0.5.1.1 (2015-12-02)
217− * This is a documentation-only release
218−
219− * The documentation of the `Time` module has been completely
220− rewritten, and is far longer and more informative. It contains
221− a brief overview of civil time, the semantics of postgresql's
222− time types, and their relation to Haskell's time types via
223− postgresql-simple.
224−
225− * The documentation of `connectPostgreSQL` has been modified to
226− mention the effects of environment variables on the connection
227− string parameters.
228−
229− * The documentation of `HStore.Internal` has been unhidden from
230− haddock.
231−
232− * A typo in example code was fixed courtesy of Levi Notik.
233−
234−### Version 0.5.1.0 (2015-10-22)
235− * Optimized the implementation of the streaming operators to avoid
236− creating intermediate lists of rows, thanks to Timo von Holtz.
237−
238− * Added default instances for `ToRow` and `FromRow` that depend on
239− Generics, thanks to Alexey Khudyakov.
240−
241− * Fixed support for bytestring-0.9 and GHC 7.4.
242−
243−### Version 0.5.0.1 (2015-09-21)
244− * Fixed a bug when printing a `ZonedTime` with a negative offset
245− that is not a whole number of hours.
246−
247−### Version 0.5.0.0 (2015-09-19)
248− * Removed the deprecated `BuiltinTypes` module.
249−
250− * Modified the SQL quasiquoter so that it returns a `Query`, not
251− an overloaded string, and so that the `OverloadedStrings` language
252− extension is no longer necessary, thanks to Mike Ledger.
253−
254− * Moved away from `blaze-builder` in favor of `bytestring-builder`. This
255− shouldn't affect very many people, but does reduce the transitive
256− dependencies.
257−
258− * Rewrote the timestamp printers to use the new `Prim`
259− infrastructure in `bytestring-builder`. The new printers should
260− be a fair bit faster.
261−
262− * Added support for exclusion violations to the `ConstraintViolation`
263− type in the Errors module, thanks to João Cristóvão.
264−
265− * Moved away from the `uuid` package in favor of the `uuid-types` package,
266− thanks to Bardur Arantsson. This shouldn't affect anybody, but does
267− reduce the transitive dependencies.
268−
269− * Postgresql-simple now explicitly assumes the UTF8 character encoding
270− for communication between the client and server. All database encodings
271− support UTF8 except for Mule Internal Code, the Multilingual
272− Extensions for Emacs. An exception should be raised upon
273− connecting to a database by the backend if the backend cannot
274− accommodate this requirement.
275−
276− * Added `Eq` and `Typeable` instances for `Connection`.
277−
278− * Added the `foldWith`, `forEachWith`, and `returningWith` families
279− of functions courtesy of Travis Staton.
280−
281− * Support for Ranged types, with thanks to Leonid Onokhov for his
282− contributions.
283−
284− * The `FromField` instance for JSON now allows for top-level values that
285− are not objects or arrays, thanks to Sam Rijs.
286−
287− * The timestamp parsers have been replaced with those now in Aeson.
288− Janne Hellsten adapted the old parsers from postgresql-simple for
289− inclusion in Aeson; Bryan O'Sullivan rewrote those parsers to be
290− faster, with some tweaks contributed by myself. And now to
291− bring the effort full circle, the result has been brought back to
292− postgresql-simple, with some adaptations.
293−
294− * Fixed a bug in the typeinfo system where postgresql's `_record` type
295− was being reported as a basic type and not an array type. Thanks to
296− Nickolay Kolev for helping to expose this issue.
297−
298− * Fixed a bug with the `typeInfo` operator, thanks to Timmy Tofu. In the
299− case of parsing subfields of arrays and composites, it would fetch the
300− `TypeInfo` of the array or composite type and not the subtype.
301−
302−### Version 0.4.10.0 (2015-02-26)
303− * Added a blurb about SSL/TLS in the documentation for connectPostgreSQL
304−
305− * Moved some functions into the Internal module, courtesy of Aleksey
306− Uimanov.
307−
308−### Version 0.4.9.0 (2014-12-27)
309− * Made the fromField method for PGArray available as pgArrayFieldParser,
310− outside of the typeclass courtesy of Tom Ellis.
311−
312− * Fixed a missing OverloadedStrings pragma in the documentation of SqlQQ.
313−
314− * Fixed deprecation warnings, courtesy of Simon Hengel.
315−
316−### Version 0.4.8.0 (2014-11-24)
317− * Added support for postgresql's citext type extension via the
318− case-insensitive package.
319−
320− * Added the function parseHStoreList to the HStore module.
321−
322−### Version 0.4.7.0 (2014-10-27)
323− * Added support for very old timestamps to UTCTime. Depending on time
324− zone, very old timestamps can be returned with a offset from UTC that
325− contains seconds.
326−
327− All timezones in the TZ database moved to a time standard offset an
328− integer number of minutes from UTC before 1973, almost all locations
329− moved before 1938, and a solid majority moved before 1921.
330−
331− ZonedTime assumes offsets are a whole number of minutes, and thus the
332− conversion to ZonedTime does not support these timestamps and will
333− still throw a conversion error.
334−
335− Note that PostgreSQL's "timestamp with time zone" (or "timestamptz")
336− type is nearly universally misunderstood. For an explanation, see:
337−
338− https://github.com/lpsmith/postgresql-simple/issues/69
339−
340− Thanks to Michael Snoyman for his assistance with this issue.
341−
342−### Version 0.4.6.0 (2014-10-07)
343− * Added an instance ToField NominalDiffTime.
344−
345−### Version 0.4.5.0 (2014-09-26)
346− * Added support for retrieving NaN and ±Infinity floating point values
347− from postgres to the FromField instances for Float, Double, and Rational.
348− The instance for Scientific is unchanged due to the fact it has no
349− way of representing these special values. Thanks goes to Tom Nielsen
350− for reporting the issue.
351−
352−### Version 0.4.4.1 (2014-09-07)
353− * Fixed a rather serious bug that prevented the COPY module from working
354− at all on unix clients since version 0.4.3.0. Thanks goes to
355− Dmitry Dzhus for reporting the issue.
356−
357− * Added a regression test for the COPY module to the test suite.
358−
359−### Version 0.4.4.0 (2014-08-26)
360− * Added the jsonb type debuting in PostgreSQL 9.4 to the TypeInfo.Static
361− and Builtin tables, and extended the out-of-box json instances to
362− be compatible with the new type. Thanks to Tobias Florek for the
363− patch.
364−
365− * Ported some expanded documentation from mysql-simple, and fixed
366− a documentation typo.
367−
368−### Version 0.4.3.0 (2014-07-10)
369− * connect and exec now use libpq asynchronously on non-Windows platforms.
370− This means we are using threadWaitRead and threadWaitWrite to
371− have GHC's IO manager schedule non-blocking C calls to libpq,
372− instead of using blocking C calls and having the OS kernel do the
373− scheduling. Among other things, this now means that System.Timeout
374− will work with connect and exec on unix platforms.
375−
376− * connect and exec now throw IOErrors instead of SQLErrors in
377− some cases. The intention is for SQLErrors to represent
378− an error returned by the server, and to use IOErrors for errors
379− that originate from client-side code. However, this goal
380− isn't perfectly achieved as of yet.
381−
382−### Version 0.4.2.3 (2014-06-04)
383− * This is strictly a documentation release, with no code changes.
384−
385− * Fixed several documentation typos, thanks to Chris Allen and remdezx.
386−
387− * Expanded the documentation of connectPostgreSQL, including a short
388− overview of common use cases and two new links to the official Postgres
389− documentation about the authentication process.
390−
391− * De-emphasized connect and ConnectInfo in favor of connectPostgreSQL.
392−
393−### Version 0.4.2.2 (2014-05-15)
394− * Fixed compatibility with scientific-0.3.\*, thanks to Adam Bergmark
395−
396− * Improved documentation of the FromField module, as well as the fold,
397− foldWithOptions, executeMany, and returning operators.
398−
399−### Version 0.4.2.1 (2014-03-27)
400− * Fixed bug in Values syntax generation
401−
402− * Improved documentation, including examples of multi-row update,
403− a better example for Values, documenting the inaccuracies in reading
404− floating point numbers from the database, and the IsString instance
405− for QualifiedIdentifier.
406−
407−### Version 0.4.2.0 (2014-03-22)
408− * Added ToField and FromField instances for the scientific package
409−
410− * Changed the Identifier and QualifiedIdentifier to use Text in
411− order to avoid encoding errors. Technically this requires a
412− major version bump, but let's pretend 0.4.1.0 didn't happen.
413−
414− * Removed non-exhaustive cases in the ToField instance for Values,
415− and tweaked error messages.
416−
417−### Version 0.4.1.0 (2014-03-22)
418− * Fixed the parsing of arrays containing null values, courtesy of
419− Francesco Mazzoli
420−
421− * Added support for properly escaped identifiers, courtesy of
422− Tobias Florek. See the new Identifier and QualifiedIdentifier
423− types inside Database.PostgreSQL.Simple.Types.
424−
425− * Added support for parameterized VALUES expressions. This is
426− more general than executeMany and returning. See the
427− Database.PostgreSQL.Simple.Types.Values data type.
428−
429−### Version 0.4.0.2 (2014-01-12)
430− * Tweaked C preprocessor directive to be more portable
431−
432− * Tweaked testsuite for compatibility with aeson-0.7
433−
434−### Version 0.4.0.1 (2013-12-21)
435− * Relaxed dependency on aeson to >= 0.6
436−
437− * Update the documentation of `fromField`
438−
439−### Version 0.4.0.0 (2013-12-21)
440− * Changed the calling code of `fromField` so that it always sends
441− a copy of the raw data. This should be a small but significant
442− performance bump for most people most of the time; however it
443− may slow down retrieval of large values not converted directly
444− to ByteString, such as large json, hstore, and array values.
445− See commit 8635f8 for more information.
446−
447− * Added the PGArray type. Thanks to Joey Adams for the suggestion
448−
449− * Fixed JSON decoding, which was almost entirely broken up until now,
450− due to bugs in the version of aeson currently available on Hackage.
451− Thanks to Amit Levy for the report.
452−
453− * Added FromField instances for IORef, MVar, and IOVector.
454−
455−### Version 0.3.10.0 (2013-12-17)
456− * Added the queryWith function, courtesy of Leonid Onokhov
457−
458− * Added the Default type, for representing postgresql's default values
459−
460−### Version 0.3.9.1 (2013-10-28)
461− * Removed dependency on hashable
462−
463−### Version 0.3.9.0 (2013-10-27)
464− * Added FromField and ToField instances for the `uuid` package,
465− courtesy of Bas van Dijk.
466−
467− * Added instance FromRow (Maybe a) for most pre-packaged FromRow
468− instances. See issue #64 for some discussion.
469−
470− * Added the fromBinary, fromHStoreMap, and fromHStoreList newtype
471− unwrapper functions, courtesy of Bas van Dijk.
472−
473−### Version 0.3.8.0 (2013-10-11)
474− * Fixed the example code in `FromField`, thanks to Adam Bergmark.
475−
476− * Added `Notification.getBackendPID`.
477−
478−### Version 0.3.7.1 (2013-09-12)
479− * Relaxed the dependency on bytestring-0.10 back to bytestring-0.9,
480− courtesy of Michael Snoyman
481−
482−### Version 0.3.7.0 (2013-09-11)
483− * Added `aeson` as a dependency.
484−
485− * Added ToField and FromField instances for aeson's JSON.Value type,
486− courtesy of Bas van Dijk.
487−
488− * Added toJSONField and fromJSONField helper functions for declaring
489− FromField/ToField JSON instances to other Haskell types, courtesy
490− of Bas van Dijk.
491−
492− * Added a FromField instance for (), corresponding to postgresql's void
493− type.
494−
495− * Added liftConversion and liftRowParser functions to the Internal
496− module, for lifting IO actions into the respective monads.
497−
498− * The SqlError predicates available in the Transaction module are now
499− also exported from the Errors module.
500−
501− * Various documentation fixes.
502−
503−### Version 0.3.6.0 (2013-08-19)
504− * Added the json type to BuiltinTypes and TypeInfo.Static, courtesy of
505− Manuel Gómez.
506−
507− * Removed the remaining internal dependencies on BuiltinTypes from
508− FromField. Added the TypeInfo.Macro module as a result.
509−
510− * Deprecated the BuiltinTypes module, which will be removed several
511− months from now. Fixed the example code in FromField to reflect
512− this change.
513−
514−### Version 0.3.5.0 (2013-08-09)
515− * Added an FromRow instance for Vector, semantically identical to the
516− existing FromRow instance for [], courtesy of Doug Beardsley
517−
518− * Reworked the documentation for the Copy module, and tweaked the
519− documentation for the LargeObjects module.
520−
521−### Version 0.3.4.0 (2013-07-23)
522− * Added direct support for COPY IN and COPY OUT, without having
523− to use raw postgresql-libpq calls and postgresql-simple's Internal
524− module.
525−
526− * Changed `getNotification` so that it throws a IOError (resource vanished)
527− exception instead of an ErrorCall exception when it fails to fetch
528− the connection's file descriptor from libpq.
529−
530−### Version 0.3.3.2 (2013-06-18)
531− * Optimized the definition of `mconcat` in the Monoid instance for
532− the Query type, courtesy of Joey Adams.
533−
534−### Version 0.3.3.1 (2013-06-06)
535− * `getNotification` now works on Windows, albeit using a one-second
536− polling loop, courtesy of Joey Adams.
537−
538−### Version 0.3.3.0 (2013-05-29)
539− * Fixed two issues with the fold operator: fold would raise the wrong
540− exception, and gave the database cursor a static name preventing
541− folds from being nested. Thanks to Joey Adams for his
542− work on these issues.
543−
544−### Version 0.3.2.0 (2013-05-20)
545− * Added a savepoint abstraction to the Transaction module, courtesy
546− of Joey Adams
547−
548−### Version 0.3.1.2 (2013-04-29)
549− * Fixed hstore parser to not unnecessarily reverse the key-value pairs
550−
551−### Version 0.3.1.1 (2013-04-29)
552− * Fixed hstore parser to recognize empty hstores, courtesy of Simon
553− Meier
554−
555−### Version 0.3.1.0 (2013-04-26)
556− * Added support for Range and Composite types to the TypeInfo system.
557−
558− * Added support for hstore types in the Simple.HStore module.
559−
560− * Improved documentation of the FromField module.
561−
562−### Version 0.3.0.1 (2013-03-26)
563− * A large chunk of the documentation inside the FromField module had
564− silently failed to render in Haddock.
565−
566−### Version 0.3.0.0 (2013-03-25)
567− * Added support for PostgreSQL's Array Types. Thanks to Jason Dusek
568− for his work on this feature.
569−
570− * Added a brand new TypeInfo system that gives FromField instances
571− convenient and efficient access to the pg_type metatable. This
572− replaced the older typename cache, and was necessary to properly
573− support postgres array types. Thanks to Bas van Dijk for his
574− work on this feature.
575−
576− * Changed the type of the `fromField` and `fromRow` methods to allow
577− a restricted set of IO actions, and stopped pre-calculating the type
578− name of every column. As a result, the type of the `typename`
579− operator changed from `Field -> ByteString` to
580− `Field -> Conversion ByteString`, where Conversion is the new monad
581− that conversion computations run inside.
582−
583− * Improved the documentation of the FromField module.
584−
585− * Added the Database.PostgreSQL.Simple.Errors module, which offers
586− some predicates and functions for interpreting SqlError values, courtesy
587− of Leonid Onokhov.
588−
589− * Added a the name of a column and the associated table's object identifier
590− to ResultError exceptions, courtesy of Jeff Chu.
591−
592− * Moved most of the more detailed transaction operators into the
593− Database.PostgreSQL.Simple.Transaction module.
594−
595− * Changed withTransactionModeRetry to accept a predicate of which
596− SqlErrors to retry, due to the fact that serialization errors can
597− sometimes manifest themselves as constraint violations. Thanks
598− to Oliver Charles for pointing this out and implementing the change.
599−
600− * Added simple tests of the fold operator, thanks to Joey Adams.
601−
602− * Added simple tests of the array conversion code.
603−
604− * Added recognition of -- comments in the quasiquoter, which are
605− now stripped out.
606−
607−
608−### Version 0.2.4.1 (2012-08-29)
609− * Fixed the documentation of `In`. Thanks to rekado and dstcruz for
610− pointing this out.
611−
612−### Version 0.2.4.0 (2012-08-23)
613− * Added the `withTransactionSerializable` and `withTransactionModeRetry`
614− operators, thanks to Joey Adams.
615−
616−### Version 0.2.3.0 (2012-08-09)
617− * Added the `returning` operator, thanks to Jason Dusek
618−
619−### Version 0.2.2.0 (2012-07-26)
620− * Added a ToRow instance for the (:.) type, courtesy of Leonid Onokhov
621−
622− * Added the type oid for PostgreSQL's `uuid` type to BuiltinTypes
623−
624−### Version 0.2.1.0 (2012-07-23)
625− * Added the FromRow.fieldWith operator, thanks to Leonid Onokhov
626−
627− * Added a type synonym for FieldParser
628−
629−### Version 0.2.0.1 (2012-06-21)
630− * Fixed a compatibility problem with PostgreSQL 8.1, which does not allow
631− clients to set their own value for `standard_conforming_strings`. This
632− connection variable is still set to `on` for PostgreSQL 8.2 and later.
633−
634−### Version 0.2: (2012-06-19)
635− * Removed the conversion from `timestamp` to `UTCTime`. Some code will be
636− broken even though it will still compile.
637−
638− * Renamed a number of data constructors, mostly in the BuiltinTypes module.
639−
640− * Exported ToRow/FromRow from Database.PostgreSQL.Simple
641−
642−
643−### Version 0.1.4.3: (2012-06-10)
644− * Fix language extensions for compatibility with GHC 7.0
645−
646−### Version 0.1.4.2: (2012-06-10)
647− * Fix a wayward dependency on Text.
648−
649−### Version 0.1.4.1: (2012-06-10)
650− * Added support for timezones with minutes in their UTC offset.
651−
652−### Version 0.1.4: (2012-06-10)
653− * Removed pcre-light dependency, courtesy of Joey Adams.
654−
655− * Reworked support for the Time types.
656−
657− * The conversion from PostgreSQL's `timestamp` (without time zone) type
658− to Haskell's `UTCTime` type is deprecated and will be removed in 0.2.
659−
660− * `Data.Time.LocalTime` now has `FromField`/`ToField` instances. It is
661− now the preferred way of dealing with `timestamp` (without time zone).
662−
663− * `Database.PostgreSQL.Simple.Time` is a new module that offers types
664− that accommodate PostgreSQL's infinities.
665−
666− * All time-related `FromField`/`ToField` instances are now based on new,
667− higher-speed parsers and printers instead of those provided by the
668− time package included in GHC.
669−
670− * Planned breaking changes for 0.2:
671−
672− * Removing the conversion from `timestamp` to `UTCTime`.
673−
674− * Renaming some of the type names in `BuiltinTypes`.
675−
676−
677−### Version 0.1.3: (2012-05-30)
678− * Made ZonedTime an instance of FromField and ToField
679−
680− * Added getNotificationNonBlocking
681−
682−
683−### Version 0.1.2: (2012-05-09)
684− * Switched to libpq-based escaping for bytea types; Binary now works with
685− PostgreSQL 8 courtesy of Joey Adams.
686−
687− * postgresql-simple now sets standard_conforming_strings to "on". This
688− per-connection variable is initialized according to the server
689− configuration, which defaults to "off" for PostgreSQL < 9, and "on"
690− for PostgreSQL >= 9. You may need to adjust any string literals in
691− your SQL queries, or set the variable yourself.
692−
693− * Exported (:.) from Database.PostgreSQL.Simple
694−
695−
696−### Version 0.1.1: (2012-05-06)
697− * Added some preliminary documentation for the Ok, Notification, and
698− LargeObjects modules
699−
700− * Implemented the `fail` method for the monad instance for `Ok`.
701−
702− * Fixed a bug relating to handling the transaction level
703−
704−
705−### Version 0.1: (2012-05-04)
706− * Renamed several modules, typeclasses, and functions:
707−
708− QueryParams (renderParams) -> ToRow (toRow)
709− QueryResults (convertResults) -> FromRow (fromRow)
710− Param (render) -> ToField (toField)
711− Result (convert) -> FromField (fromField)
712−
713− * Added the `Database.PostgreSQL.Simple.Ok` module, a variation of
714− `Either SomeException` that has an instance for `Alternative` and also
715− uses a list of exceptions to track the ways it has failed.
716−
717− * Changed the return type of `fromField` and `fromRow` from
718− `Either SomeException` to `Ok`.
719−
720− * Thanks to suggestions from Ozgun Ataman, the `FromRow` typeclass has been
721− massively improved. The result is simpler definitions and better
722− compositionality. Also, user-defined instances need not be to be
723− concerned about forcing the converted results to WHNF. Here is an
724− example comparing the old to the new:
725−
726− instance (Result a, Result b) => QueryResults (a,b) where
727− convertResults [fa,fb] [va,vb] = do
728− !a <- convert fa va
729− !b <- convert fb vb
730− return (a,b)
731− convertResults fs vs = convertError fs vs 2
732−
733− instance (FromField a, FromField b) => FromRow (a,b) where
734− fromRow = (,) <$> field <*> field
735−
736− * Added `(:.)`, a pair that allows one to compose `FromRow` instances:
737−
738− instance (FromRow a, FromRow b) => FromRow (a :. b) where
739− fromRow = (:.) <$> fromRow <*> fromRow
740−
741− * Moved the contents `Field` module into the `FromField` module.
742−
743− * Removed the `RawResult` type.
744−
745− * Added `DefaultIsolationLevel` as a distinct `IsolationLevel` option
746− and `DefaultReadWriteMode` as a distinct `ReadWriteMode`.
CONTRIBUTING.mddeleted−13
@@ -1,13 +0,0 @@
1−Patches welcome!
2−
3−- If you are only going to bump bounds:
4− - If it's really **only bounds**, please simply open an issue (so you'll have a URL to refer to). I have a semi-automated process to make revisions, pull requests only disturb it.
5− - If patch includes **source code change** (i.e. I'll need to make a release), and it's a patch to support **newer base/GHC version**:
6− - Amend `tested-with` to include that GHC
7− - Regenerate `.github/workflows/haskell-ci.yml` with `haskell-ci regenerate` (get the latest from [GitHub haskell-ci/haskell-ci](https://github.com/haskell-ci/haskell-ci))
8−
9−- Don't edit `CHANGELOG.md`, rather include a copyable entry in your pull request description. I often process pull requests in bulk, and everyone editing the `CHANGELOG.md` causes unnecessary conflicts.
10−- For the same reason, do not edit `version` or `x-revision`
11−
12−- I use [`stylish-haskell`](https://github.com/jaspervdj/stylish-haskell) to format imports. I encourage you to use it too, when contributing.
13−- General code style is 4 spaces, just look around how it looks, it's not so strict.
CONTRIBUTORSdeleted−36
@@ -1,36 +0,0 @@
1−Bryan O'Sullivan <bos@serpentine.com>
2−Leon P Smith <leon@melding-monads.com>
3−Felipe Lessa <felipe.lessa@gmail.com>
4−Ozgun Ataman <ozataman@gmail.com>
5−Joey Adams <joeyadams3.14159@gmail.com>
6−Rekado <rekado@elephly.net>
7−Leonid Onokhov <sopvop@gmail.com>
8−Bas van Dijk <v.dijk.bas@gmail.com>
9−Jason Dusek <jason.dusek@gmail.com>
10−Jeff Chu <jeff@kiteedu.com>
11−Oliver Charles <oliver.g.charles@gmail.com>
12−Simon Meier <iridcode@gmail.com>
13−Alexey Uimanov <s9gf4ult@gmail.com>
14−Doug Beardsley <mightybyte@gmail.com>
15−Manuel Gómez <targen@gmail.com>
16−Michael Snoyman <michael@snoyman.com>
17−Adam Bergmark <adam@edea.se>
18−Tobias Florek <tob@butter.sh>
19−Francesco Mazzoli <francesco.mazzoli@erudify.com>
20−Chris Allen <cma@bitemyapp.com>
21−Simon Hengel <sol@typeful.net>
22−Tom Ellis <tom-2013@purelyagile.com>
23−Mike Ledger <mike@quasimal.com>
24−João Cristóvão <jmacristovao@gmail.com>
25−Bardur Arantsson <bardur@scientician.net>
26−Travis Staton <hello@travisstaton.com>
27−Sam Rijs <srijs@airpost.net>
28−Janne Hellsten <jjhellst@gmail.com>
29−Timmy Tofu <timmytofu@users.noreply.github.com>
30−Alexey Khudyakov <alexey.skladnoy@gmail.com>
31−Timo von Holtz <tvh@anchor.com.au>
32−Amit Levy <amit@amitlevy.com>
33−Ben Gamari <ben@smart-cactus.org>
34−Edgar Gomes Araujo <talktoedgar@gmail.com>
35−Erik Hesselink <hesselink@gmail.com>
36−Matvey Aksenov <matvey.aksenov@gmail.com>
README.mddeleted−4
@@ -1,4 +0,0 @@
1−[![Hackage page (downloads and API reference)][hackage-png]][hackage]
2−
3− [hackage-png]: http://img.shields.io/hackage/v/postgresql-simple.svg
4− [hackage]: http://hackage.haskell.org/package/postgresql-simple
bench/Select.hsdeleted−32
@@ -1,32 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−module Main where
3−
4−import Database.PostgreSQL.Simple
5−import qualified Database.PostgreSQL.Simple.Vector as V
6−import qualified Database.PostgreSQL.Simple.Vector.Unboxed as VU
7−
8−import System.Environment (getArgs)
9−import Data.Foldable (Foldable, foldl')
10−import qualified Data.Vector.Unboxed as VU
11−
12−main :: IO ()
13−main = do
14− args <- getArgs
15− conn <- connectPostgreSQL ""
16− case args of
17− ("vector":_) -> do
18− result <- V.query_ conn "SELECT * FROM generate_series(1, 10000000);"
19− print (process result)
20− ("unboxed":_) -> do
21− -- dummy column
22− result <- VU.query_ conn "SELECT (NULL :: VOID), * FROM generate_series(1, 10000000);"
23− print (process' result)
24− _ -> do
25− result <- query_ conn "SELECT * FROM generate_series(1, 10000000);"
26− print (process result)
27−
28−process :: Foldable f => f (Only Int) -> Int
29−process = foldl' (\x (Only y) -> max x y) 0
30−
31−process' :: VU.Vector ((), Int) -> Int
32−process' = VU.foldl' (\x (_, y) -> max x y) 0
cabal.haskell-cideleted−5
@@ -1,5 +0,0 @@
1−branches: master
2−postgresql: True
3−
4−-- services aren't supported on Travis on macOS
5−-- osx: 8.4.4
cabal.projectdeleted−4
@@ -1,4 +0,0 @@
1−packages: .
2−tests: true
3−
4−allow-newer: cryptohash-md5-0.11.100.1:base
cabal.project.local.windeleted−4
@@ -1,4 +0,0 @@
1−constraints: these -assoc
2−
3−package postgresql-libpq
4− flags: -use-pkg-config
postgresql-simple.cabal+57−171
@@ -1,175 +1,61 @@
1−cabal-version: 1.12
2−name: postgresql-simple
3−version: 0.7.0.0
4−x-revision: 1
5−synopsis: Mid-Level PostgreSQL client library
6−description:
7− Mid-Level PostgreSQL client library, forked from mysql-simple.
8−
9−license: BSD3
10−license-file: LICENSE
11−author: Bryan O'Sullivan, Leon P Smith
12−maintainer: Oleg Grenrus <oleg.grenrus@iki.fi>
13−copyright:
14− (c) 2011 MailRank, Inc.
15− (c) 2011-2018 Leon P Smith
16− (c) 2018-2020 Oleg Grenrus
17−
18−category: Database
19−build-type: Simple
20−extra-source-files:
21− CHANGES.md
22− CONTRIBUTORS
23− test/results/malformed-input.expected
24− test/results/unique-constraint-violation.expected
25−
26−tested-with:
27− GHC ==8.6.5
28− || ==8.8.4
29− || ==8.10.7
30− || ==9.0.2
31− || ==9.2.8
32− || ==9.4.8
33− || ==9.6.3
34− || ==9.8.1
35−
36−library
37− default-language: Haskell2010
38− hs-source-dirs: src
39− exposed-modules:
40− Database.PostgreSQL.Simple
41− Database.PostgreSQL.Simple.Arrays
42− Database.PostgreSQL.Simple.Copy
43− Database.PostgreSQL.Simple.Cursor
44− Database.PostgreSQL.Simple.Errors
45− Database.PostgreSQL.Simple.FromField
46− Database.PostgreSQL.Simple.FromRow
47− Database.PostgreSQL.Simple.HStore
48− Database.PostgreSQL.Simple.HStore.Internal
49− Database.PostgreSQL.Simple.Internal
50− Database.PostgreSQL.Simple.LargeObjects
51− Database.PostgreSQL.Simple.Newtypes
52− Database.PostgreSQL.Simple.Notification
53− Database.PostgreSQL.Simple.Ok
54− Database.PostgreSQL.Simple.Range
55− Database.PostgreSQL.Simple.SqlQQ
56− Database.PostgreSQL.Simple.Time
57− Database.PostgreSQL.Simple.Time.Internal
58− Database.PostgreSQL.Simple.ToField
59− Database.PostgreSQL.Simple.ToRow
60− Database.PostgreSQL.Simple.Transaction
61− Database.PostgreSQL.Simple.TypeInfo
62− Database.PostgreSQL.Simple.TypeInfo.Macro
63− Database.PostgreSQL.Simple.TypeInfo.Static
64− Database.PostgreSQL.Simple.Types
65− Database.PostgreSQL.Simple.Vector
66− Database.PostgreSQL.Simple.Vector.Unboxed
67−
68− -- Other-modules:
69− other-modules:
70− Database.PostgreSQL.Simple.Compat
71− Database.PostgreSQL.Simple.HStore.Implementation
72− Database.PostgreSQL.Simple.Internal.PQResultUtils
73− Database.PostgreSQL.Simple.Time.Implementation
74− Database.PostgreSQL.Simple.Time.Internal.Parser
75− Database.PostgreSQL.Simple.Time.Internal.Printer
76− Database.PostgreSQL.Simple.TypeInfo.Types
77−
78− -- GHC bundled libs
79− build-depends:
80− base >=4.12.0.0 && <4.20
81− , bytestring >=0.10.8.2 && <0.13
82− , containers >=0.6.0.1 && <0.7
83− , template-haskell >=2.14.0.0 && <2.22
84− , text >=1.2.3.0 && <1.3 || >=2.0 && <2.2
85− , time-compat >=1.9.5 && <1.12
86− , transformers >=0.5.6.2 && <0.7
87−
88− -- Other dependencies
89− build-depends:
90− aeson >=2.1.2.1 && <2.3
91− , attoparsec >=0.14.4 && <0.15
92− , case-insensitive >=1.2.1.0 && <1.3
93− , hashable >=1.4.3.0 && <1.5
94− , Only >=0.1 && <0.1.1
95− , postgresql-libpq >=0.10.0.0 && <0.11
96− , scientific >=0.3.7.0 && <0.4
97− , uuid-types >=1.0.5 && <1.1
98− , vector >=0.13.0.0 && <0.14
99−
100− default-extensions:
101− BangPatterns
102− DoAndIfThenElse
103− OverloadedStrings
104− TypeOperators
105− ViewPatterns
106−
107− ghc-options: -Wall -fno-warn-name-shadowing
1+Name: postgresql-simple
2+Version: 0.0.99
3+Synopsis: Mid-Level PostgreSQL client library
4+Description:
5+ Mid-Level PostgreSQL client library, forked from mysql-simple.
6+License: BSD3
7+License-file: LICENSE
8+Author: Bryan O'Sullivan, Leon P Smith
9+Maintainer: Leon P Smith <leon@melding-monads.com>
10+Copyright: (c) 2011 MailRank, Inc.
11+ (c) 2011 Leon P Smith
12+Category: Database
13+Build-type: Simple
14+
15+Cabal-version: >=1.6
16+
17+Library
18+ hs-source-dirs: src
19+ Exposed-modules:
20+ Database.PostgreSQL.Simple
21+ Database.PostgreSQL.Simple.BuiltinTypes
22+ Database.PostgreSQL.Simple.Field
23+ Database.PostgreSQL.Simple.FromField
24+ Database.PostgreSQL.Simple.FromRow
25+ Database.PostgreSQL.Simple.LargeObjects
26+ Database.PostgreSQL.Simple.Notification
27+ Database.PostgreSQL.Simple.Ok
28+ Database.PostgreSQL.Simple.Param
29+ Database.PostgreSQL.Simple.QueryParams
30+ Database.PostgreSQL.Simple.SqlQQ
31+ Database.PostgreSQL.Simple.Types
32+-- Other-modules:
33+ Database.PostgreSQL.Simple.Internal
34+
35+ Build-depends:
36+ attoparsec >= 0.8.5.3,
37+ base < 5,
38+ base16-bytestring,
39+ blaze-builder,
40+ blaze-textual,
41+ bytestring >= 0.9,
42+ containers,
43+ postgresql-libpq >= 0.6.2,
44+ pcre-light,
45+ old-locale,
46+ template-haskell,
47+ text >= 0.11.1,
48+ time,
49+ transformers,
50+ vector
51+
52+ extensions: DoAndIfThenElse, OverloadedStrings, BangPatterns, ViewPatterns
10853
10954source-repository head
11055 type: git
111− location: http://github.com/haskellari/postgresql-simple
112−
113−test-suite inspection
114− default-language: Haskell2010
115− type: exitcode-stdio-1.0
116− hs-source-dirs: test
117− main-is: Inspection.hs
118− build-depends:
119− base
120− , inspection-testing >=0.4.1.1 && <0.6
121− , postgresql-libpq
122− , postgresql-simple
123− , tasty
124− , tasty-hunit
125−
126−test-suite test
127− default-language: Haskell2010
128− type: exitcode-stdio-1.0
129− hs-source-dirs: test
130− main-is: Main.hs
131− other-modules:
132− Common
133− Exception
134− Interval
135− Notify
136− Serializable
137− Time
56+ location: http://github.com/lpsmith/postgresql-simple
13857
139− ghc-options: -threaded
140− ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind
141− default-extensions:
142− NamedFieldPuns
143− OverloadedStrings
144− PatternGuards
145− Rank2Types
146− RecordWildCards
147− ScopedTypeVariables
148−
149− build-depends:
150− aeson
151− , base
152− , base16-bytestring
153− , bytestring
154− , case-insensitive
155− , containers
156− , cryptohash-md5 >=0.11.100.1 && <0.12
157− , filepath
158− , HUnit
159− , postgresql-simple
160− , tasty
161− , tasty-golden
162− , tasty-hunit
163− , text
164− , time-compat
165− , vector
166−
167−benchmark select
168− default-language: Haskell2010
169− type: exitcode-stdio-1.0
170− hs-source-dirs: bench
171− main-is: Select.hs
172− build-depends:
173− base
174− , postgresql-simple
175− , vector
58+source-repository this
59+ type: git
60+ location: http://github.com/lpsmith/postgresql-simple
61+ tag: v0.0.5
sdist.shdeleted−25
@@ -1,25 +0,0 @@
1−#!/bin/bash
2−
3−echo "Generating CHANGELOG.md"
4−echo
5−
6−cat <<HEADER > CHANGELOG.md
7−For the full changelog, see
8−<https://github.com/lpsmith/postgresql-simple/blob/master/CHANGES.md>
9−
10−HEADER
11−
12−perl -ne '$n++ if /^###/; exit if $n==2; print' CHANGES.md >> CHANGELOG.md
13−
14−cat CHANGELOG.md
15−rm -f ./dist/*.tar
16−rm -f ./dist/*.tar.gz
17−cabal sdist
18−cd dist
19−wc *.tar.gz
20−gunzip *.gz
21−wc *.tar
22−zopfli *.tar
23−wc *.tar.gz
24−cd ..
25−rm -f ./dist/*.tar
src/Database/PostgreSQL/Simple.hs+362−390
@@ -1,18 +1,14 @@
1−{-# LANGUAGE DeriveDataTypeable #-}
2−{-# LANGUAGE NamedFieldPuns #-}
3−{-# LANGUAGE OverloadedStrings #-}
4−{-# LANGUAGE PatternGuards #-}
5−{-# LANGUAGE RecordWildCards #-}
6−{-# LANGUAGE ViewPatterns #-}
1+{-# LANGUAGE DeriveDataTypeable, RecordWildCards, NamedFieldPuns #-}
72
83------------------------------------------------------------------------------
94-- |
105-- Module: Database.PostgreSQL.Simple
116-- Copyright: (c) 2011 MailRank, Inc.
12−-- (c) 2011-2012 Leon P Smith
7+-- (c) 2011 Leon P Smith
138-- License: BSD3
149-- Maintainer: Leon P Smith <leon@melding-monads.com>
1510-- Stability: experimental
11+-- Portability: portable
1612--
1713-- A mid-level client library for the PostgreSQL database, aimed at ease of
1814-- use and high performance.
@@ -42,9 +38,6 @@ module Database.PostgreSQL.Simple
4238 -- ** Modifying multiple rows at once
4339 -- $many
4440
45− -- ** @RETURNING@: modifications that return results
46− -- $returning
47−
4841 -- * Extracting results
4942 -- $result
5043
@@ -55,35 +48,26 @@ module Database.PostgreSQL.Simple
5548 -- $types
5649
5750 -- * Types
58− Connection
51+ Base.ConnectInfo(..)
52+ , Connection
5953 , Query
60− , ToRow
61− , FromRow
6254 , In(..)
6355 , Binary(..)
6456 , Only(..)
65− , (:.)(..)
6657 -- ** Exceptions
67− , SomePostgreSqlException(..)
6858 , SqlError(..)
69− , PQ.ExecStatus(..)
70− , FormatError(..)
71− , QueryError(..)
72− , ResultError(..)
59+ , FormatError(fmtMessage, fmtQuery, fmtParams)
60+ , QueryError(qeMessage, qeQuery)
61+ , ResultError(errSQLType, errHaskellType, errMessage)
7362 -- * Connection management
74− , Base.connectPostgreSQL
75− , Base.close
7663 , Base.connect
77− , Base.withConnect
78− , Base.ConnectInfo(..)
79− , Base.defaultConnectInfo
64+ , Base.connectPostgreSQL
8065 , Base.postgreSQLConnectionString
66+ , Base.defaultConnectInfo
67+ , Base.close
8168 -- * Queries that return results
8269 , query
8370 , query_
84− -- ** Queries taking parser as argument
85− , queryWith
86− , queryWith_
8771 -- * Queries that stream results
8872 , FoldOptions(..)
8973 , FetchQuantity(..)
@@ -94,15 +78,6 @@ module Database.PostgreSQL.Simple
9478 , foldWithOptions_
9579 , forEach
9680 , forEach_
97− , returning
98− -- ** Queries that stream results taking a parser as an argument
99− , foldWith
100− , foldWithOptionsAndParser
101− , foldWith_
102− , foldWithOptionsAndParser_
103− , forEachWith
104− , forEachWith_
105− , returningWith
10681 -- * Statements that do not return results
10782 , execute
10883 , execute_
@@ -110,9 +85,18 @@ module Database.PostgreSQL.Simple
11085-- , Base.insertID
11186 -- * Transaction handling
11287 , withTransaction
113− , withSavepoint
88+ , TransactionMode(..)
89+ , IsolationLevel(..)
90+ , ReadWriteMode(..)
91+ , defaultTransactionMode
92+ , defaultIsolationLevel
93+ , defaultReadWriteMode
94+ , withTransactionLevel
95+ , withTransactionMode
11496-- , Base.autocommit
11597 , begin
98+ , beginLevel
99+ , beginMode
116100 , commit
117101 , rollback
118102 -- * Helper functions
@@ -120,27 +104,59 @@ module Database.PostgreSQL.Simple
120104 , formatQuery
121105 ) where
122106
123−import Data.ByteString.Builder (Builder, byteString, char8)
124−import Control.Applicative ((<$>))
125−import Control.Exception as E
107+import Blaze.ByteString.Builder
108+ ( Builder, fromByteString, toByteString )
109+import Blaze.ByteString.Builder.Char8 (fromChar)
110+import Control.Applicative ((<$>), pure)
111+import Control.Concurrent.MVar
112+import Control.Exception
113+ ( Exception, bracket, onException, throw, throwIO, finally )
114+import Control.Monad (foldM)
115+import Control.Monad.Fix (fix)
126116import Data.ByteString (ByteString)
117+import Data.Char(ord)
127118import Data.Int (Int64)
119+import qualified Data.IntMap as IntMap
128120import Data.List (intersperse)
129−import Data.Monoid (mconcat)
130−import Database.PostgreSQL.Simple.Compat ((<>), toByteString)
131−import Database.PostgreSQL.Simple.Cursor
121+import Data.Monoid (mappend, mconcat)
122+import Data.Typeable (Typeable)
123+import Database.PostgreSQL.Simple.BuiltinTypes
124+ ( oid2builtin, builtin2typname )
132125import Database.PostgreSQL.Simple.FromField (ResultError(..))
133126import Database.PostgreSQL.Simple.FromRow (FromRow(..))
134−import Database.PostgreSQL.Simple.ToField (Action(..))
135−import Database.PostgreSQL.Simple.ToRow (ToRow(..))
127+import Database.PostgreSQL.Simple.Ok
128+import Database.PostgreSQL.Simple.Param (Action(..), inQuotes)
129+import Database.PostgreSQL.Simple.QueryParams (QueryParams(..))
136130import Database.PostgreSQL.Simple.Types
137− ( Binary(..), In(..), Only(..), Query(..), (:.)(..) )
131+ ( Binary(..), In(..), Only(..), Query(..) )
138132import Database.PostgreSQL.Simple.Internal as Base
139−import Database.PostgreSQL.Simple.Internal.PQResultUtils
140−import Database.PostgreSQL.Simple.Transaction
141133import qualified Database.PostgreSQL.LibPQ as PQ
134+import Text.Regex.PCRE.Light (compile, caseless, match)
142135import qualified Data.ByteString.Char8 as B
143−
136+import qualified Data.Vector as V
137+import Control.Exception
138+import Control.Monad.Trans.Reader
139+import Control.Monad.Trans.State.Strict
140+
141+-- | Exception thrown if a 'Query' could not be formatted correctly.
142+-- This may occur if the number of \'@?@\' characters in the query
143+-- string does not match the number of parameters provided.
144+data FormatError = FormatError {
145+ fmtMessage :: String
146+ , fmtQuery :: Query
147+ , fmtParams :: [ByteString]
148+ } deriving (Eq, Show, Typeable)
149+
150+instance Exception FormatError
151+
152+-- | Exception thrown if 'query' is used to perform an @INSERT@-like
153+-- operation, or 'execute' is used to perform a @SELECT@-like operation.
154+data QueryError = QueryError {
155+ qeMessage :: String
156+ , qeQuery :: Query
157+ } deriving (Eq, Show, Typeable)
158+
159+instance Exception QueryError
144160
145161-- | Format a query string.
146162--
@@ -152,11 +168,11 @@ import qualified Data.ByteString.Char8 as B
152168--
153169-- Throws 'FormatError' if the query string could not be formatted
154170-- correctly.
155−formatQuery :: ToRow q => Connection -> Query -> q -> IO ByteString
171+formatQuery :: QueryParams q => Connection -> Query -> q -> IO ByteString
156172formatQuery conn q@(Query template) qs
157173 | null xs && '?' `B.notElem` template = return template
158174 | otherwise = toByteString <$> buildQuery conn q template xs
159− where xs = toRow qs
175+ where xs = renderParams qs
160176
161177-- | Format a query string with a variable number of rows.
162178--
@@ -171,208 +187,105 @@ formatQuery conn q@(Query template) qs
171187--
172188-- Throws 'FormatError' if the query string could not be formatted
173189-- correctly.
174−formatMany :: (ToRow q) => Connection -> Query -> [q] -> IO ByteString
190+formatMany :: (QueryParams q) => Connection -> Query -> [q] -> IO ByteString
175191formatMany _ q [] = fmtError "no rows supplied" q []
176192formatMany conn q@(Query template) qs = do
177− case parseTemplate template of
178− Just (before, qbits, after) -> do
179− bs <- mapM (buildQuery conn q qbits . toRow) qs
180− return . toByteString . mconcat $ byteString before :
181− intersperse (char8 ',') bs ++
182− [byteString after]
183− Nothing -> fmtError "syntax error in multi-row template" q []
184−
185−-- Split the input string into three pieces, @before@, @qbits@, and @after@,
186−-- following this grammar:
187−--
188−-- start: ^ before qbits after $
189−-- before: ([^?]* [^?\w])? 'VALUES' \s*
190−-- qbits: '(' \s* '?' \s* (',' \s* '?' \s*)* ')'
191−-- after: [^?]*
192−--
193−-- \s: [ \t\n\r\f]
194−-- \w: [A-Z] | [a-z] | [\x80-\xFF] | '_' | '$' | [0-9]
195−--
196−-- This would be much more concise with some sort of regex engine.
197−-- 'formatMany' used to use pcre-light instead of this hand-written parser,
198−-- but pcre is a hassle to install on Windows.
199−parseTemplate :: ByteString -> Maybe (ByteString, ByteString, ByteString)
200−parseTemplate template =
201− -- Convert input string to uppercase, to facilitate searching.
202− search $ B.map toUpper_ascii template
193+ case match re template [] of
194+ Just [_,before,qbits,after] -> do
195+ bs <- mapM (buildQuery conn q qbits . renderParams) qs
196+ return . toByteString . mconcat $ fromByteString before :
197+ intersperse (fromChar ',') bs ++
198+ [fromByteString after]
199+ _ -> error "foo"
203200 where
204− -- Search for the next occurrence of "VALUES"
205− search bs =
206− case B.breakSubstring "VALUES" bs of
207− (x, y)
208− -- If "VALUES" is not present in the string, or any '?' characters
209− -- were encountered prior to it, fail.
210− | B.null y || ('?' `B.elem` x)
211− -> Nothing
212−
213− -- If "VALUES" is preceded by an identifier character (a.k.a. \w),
214− -- try the next occurrence.
215− | not (B.null x) && isIdent (B.last x)
216− -> search $ B.drop 6 y
217−
218− -- Otherwise, we have a legitimate "VALUES" token.
219− | otherwise
220− -> parseQueryBits $ skipSpace $ B.drop 6 y
221−
222− -- Parse '(' \s* '?' \s* . If this doesn't match
223− -- (and we don't consume a '?'), look for another "VALUES".
224− --
225− -- qb points to the open paren (if present), meaning it points to the
226− -- beginning of the "qbits" production described above. This is why we
227− -- pass it down to finishQueryBits.
228− parseQueryBits qb
229− | Just ('(', skipSpace -> bs1) <- B.uncons qb
230− , Just ('?', skipSpace -> bs2) <- B.uncons bs1
231− = finishQueryBits qb bs2
232− | otherwise
233− = search qb
234−
235− -- Parse (',' \s* '?' \s*)* ')' [^?]* .
236− --
237− -- Since we've already consumed at least one '?', there's no turning back.
238− -- The parse has to succeed here, or the whole thing fails
239− -- (because we don't allow '?' to appear outside of the VALUES list).
240− finishQueryBits qb bs0
241− | Just (')', bs1) <- B.uncons bs0
242− = if '?' `B.elem` bs1
243− then Nothing
244− else Just $ slice3 template qb bs1
245− | Just (',', skipSpace -> bs1) <- B.uncons bs0
246− , Just ('?', skipSpace -> bs2) <- B.uncons bs1
247− = finishQueryBits qb bs2
248− | otherwise
249− = Nothing
250−
251− -- Slice a string into three pieces, given the start offset of the second
252− -- and third pieces. Each "offset" is actually a tail of the uppercase
253− -- version of the template string. Its length is used to infer the offset.
254− --
255− -- It is important to note that we only slice the original template.
256− -- We don't want our all-caps trick messing up the actual query string.
257− slice3 source p1 p2 =
258− (s1, s2, source'')
259− where
260− (s1, source') = B.splitAt (B.length source - B.length p1) source
261− (s2, source'') = B.splitAt (B.length p1 - B.length p2) source'
262−
263− toUpper_ascii c | c >= 'a' && c <= 'z' = toEnum (fromEnum c - 32)
264− | otherwise = c
265−
266− -- Based on the definition of {ident_cont} in src/backend/parser/scan.l
267− -- in the PostgreSQL source. No need to check [a-z], since we converted
268− -- the whole string to uppercase.
269− isIdent c = (c >= '0' && c <= '9')
270− || (c >= 'A' && c <= 'Z')
271− || (c >= '\x80' && c <= '\xFF')
272− || c == '_'
273− || c == '$'
274−
275− -- Based on {space} in scan.l
276− isSpace_ascii c = (c == ' ') || (c >= '\t' && c <= '\r')
277−
278− skipSpace = B.dropWhile isSpace_ascii
201+ re = compile "^([^?]+\\bvalues\\s*)\
202+ \(\\(\\s*[?](?:\\s*,\\s*[?])*\\s*\\))\
203+ \([^?]*)$"
204+ [caseless]
279205
206+escapeStringConn conn s = withConnection conn $ \c -> do
207+ PQ.escapeStringConn c s
280208
281209buildQuery :: Connection -> Query -> ByteString -> [Action] -> IO Builder
282−buildQuery conn q template xs =
283− zipParams (split template) <$> mapM (buildAction conn q xs) xs
284− where split s =
285− -- This part escapes double '??'s to make literal '?'s possible
286− -- in PostgreSQL queries using the JSON operators: @?@, @?|@ and @?&@
287− let (h,t) = breakOnSingleQuestionMark s
288− in byteString h
289− : if B.null t
290− then []
291− else split (B.tail t)
292− zipParams (t:ts) (p:ps) = t <> p <> zipParams ts ps
210+buildQuery conn q template xs = zipParams (split template) <$> mapM sub xs
211+ where quote = inQuotes . fromByteString . maybe undefined id
212+ sub (Plain b) = pure b
213+ sub (Escape s) = quote <$> escapeStringConn conn s
214+ sub (Many ys) = mconcat <$> mapM sub ys
215+ split s = fromByteString h : if B.null t then [] else split (B.tail t)
216+ where (h,t) = B.break (=='?') s
217+ zipParams (t:ts) (p:ps) = t `mappend` p `mappend` zipParams ts ps
293218 zipParams [t] [] = t
294− zipParams _ _ = fmtError (show countSingleQs ++
295− " single '?' characters, but " ++
219+ zipParams _ _ = fmtError (show (B.count '?' template) ++
220+ " '?' characters, but " ++
296221 show (length xs) ++ " parameters") q xs
297− countSingleQs = go 0 template
298− where go i "" = (i :: Int)
299− go i bs = case qms of
300− ("?","?") -> go i nextQMBS
301− ("?",_) -> go (i+1) nextQMBS
302− _ -> i
303− where qms = B.splitAt 1 qmBS
304− (qmBS,nextQMBS) = B.splitAt 2 qmBS'
305− qmBS' = B.dropWhile (/= '?') bs
306222
307223-- | Execute an @INSERT@, @UPDATE@, or other SQL query that is not
308224-- expected to return results.
309225--
310226-- Returns the number of rows affected.
311227--
312−-- Throws 'FormatError' if the query could not be formatted correctly, or
313−-- a 'SqlError' exception if the backend returns an error.
314−execute :: (ToRow q) => Connection -> Query -> q -> IO Int64
228+-- Throws 'FormatError' if the query could not be formatted correctly.
229+execute :: (QueryParams q) => Connection -> Query -> q -> IO Int64
315230execute conn template qs = do
316231 result <- exec conn =<< formatQuery conn template qs
317232 finishExecute conn template result
318233
234+-- | A version of 'execute' that does not perform query substitution.
235+execute_ :: Connection -> Query -> IO Int64
236+execute_ conn q@(Query stmt) = do
237+ result <- exec conn stmt
238+ finishExecute conn q result
239+
319240-- | Execute a multi-row @INSERT@, @UPDATE@, or other SQL query that is not
320241-- expected to return results.
321242--
322−-- Returns the number of rows affected. If the list of parameters is empty,
323−-- this function will simply return 0 without issuing the query to the backend.
324−-- If this is not desired, consider using the 'Values' constructor instead.
325−--
326−-- Throws 'FormatError' if the query could not be formatted correctly, or
327−-- a 'SqlError' exception if the backend returns an error.
328−--
329−-- For example, here's a command that inserts two rows into a table
330−-- with two columns:
331−--
332−-- @
333−-- executeMany c [sql|
334−-- INSERT INTO sometable VALUES (?,?)
335−-- |] [(1, \"hello\"),(2, \"world\")]
336−-- @
337−--
338−-- Here's an canonical example of a multi-row update command:
243+-- Returns the number of rows affected.
339244--
340−-- @
341−-- executeMany c [sql|
342−-- UPDATE sometable
343−-- SET y = upd.y
344−-- FROM (VALUES (?,?)) as upd(x,y)
345−-- WHERE sometable.x = upd.x
346−-- |] [(1, \"hello\"),(2, \"world\")]
347−-- @
348−
349−executeMany :: (ToRow q) => Connection -> Query -> [q] -> IO Int64
245+-- Throws 'FormatError' if the query could not be formatted correctly.
246+executeMany :: (QueryParams q) => Connection -> Query -> [q] -> IO Int64
350247executeMany _ _ [] = return 0
351248executeMany conn q qs = do
352249 result <- exec conn =<< formatMany conn q qs
353250 finishExecute conn q result
354251
355−-- | Execute @INSERT ... RETURNING@, @UPDATE ... RETURNING@, or other SQL
356−-- query that accepts multi-row input and is expected to return results.
357−-- Note that it is possible to write
358−-- @'query' conn "INSERT ... RETURNING ..." ...@
359−-- in cases where you are only inserting a single row, and do not need
360−-- functionality analogous to 'executeMany'.
361−--
362−-- If the list of parameters is empty, this function will simply return @[]@
363−-- without issuing the query to the backend. If this is not desired,
364−-- consider using the 'Values' constructor instead.
365−--
366−-- Throws 'FormatError' if the query could not be formatted correctly.
367−returning :: (ToRow q, FromRow r) => Connection -> Query -> [q] -> IO [r]
368−returning = returningWith fromRow
252+finishExecute :: Connection -> Query -> PQ.Result -> IO Int64
253+finishExecute conn q result = do
254+ status <- PQ.resultStatus result
255+ case status of
256+ PQ.CommandOk -> do
257+ ncols <- PQ.nfields result
258+ if ncols /= 0
259+ then throwIO $ QueryError ("execute resulted in " ++ show ncols ++
260+ "-column result") q
261+ else do
262+ nstr <- PQ.cmdTuples result
263+ return $ case nstr of
264+ Nothing -> 0 -- is this appropriate?
265+ Just str -> toInteger str
266+ PQ.TuplesOk -> do
267+ ncols <- PQ.nfields result
268+ throwIO $ QueryError ("execute resulted in " ++ show ncols ++
269+ "-column result") q
270+ PQ.CopyIn -> fail "FIXME: postgresql-simple does not currently support COPY IN"
271+ PQ.CopyOut -> fail "FIXME: postgresql-simple does not currently support COPY OUT"
272+ _ -> do
273+ errormsg <- maybe "" id <$> PQ.resultErrorMessage result
274+ statusmsg <- PQ.resStatus status
275+ state <- maybe "" id <$> PQ.resultErrorField result PQ.DiagSqlstate
276+ throwIO $ SqlError { sqlState = state
277+ , sqlNativeError = fromEnum status
278+ , sqlErrorMsg = B.concat [ "execute: ", statusmsg
279+ , ": ", errormsg ]}
280+ where
281+ toInteger str = B.foldl' delta 0 str
282+ where
283+ delta acc c =
284+ if '0' <= c && c <= '9'
285+ then 10 * acc + fromIntegral (ord c - ord '0')
286+ else error ("finishExecute: not an int: " ++ B.unpack str)
287+
369288
370−-- | A version of 'returning' taking parser as argument
371−returningWith :: (ToRow q) => RowParser r -> Connection -> Query -> [q] -> IO [r]
372−returningWith _ _ _ [] = return []
373−returningWith parser conn q qs = do
374− result <- exec conn =<< formatMany conn q qs
375− finishQueryWith parser conn q result
376289
377290-- | Perform a @SELECT@ or other SQL query that is expected to return
378291-- results. All results are retrieved and converted before this
@@ -389,27 +302,17 @@ returningWith parser conn q qs = do
389302-- using 'execute' instead of 'query').
390303--
391304-- * 'ResultError': result conversion failed.
392−--
393−-- * 'SqlError': the postgresql backend returned an error, e.g.
394−-- a syntax or type error, or an incorrect table or column name.
395−query :: (ToRow q, FromRow r) => Connection -> Query -> q -> IO [r]
396−query = queryWith fromRow
305+query :: (QueryParams q, FromRow r)
306+ => Connection -> Query -> q -> IO [r]
307+query conn template qs = do
308+ result <- exec conn =<< formatQuery conn template qs
309+ finishQuery conn template result
397310
398311-- | A version of 'query' that does not perform query substitution.
399312query_ :: (FromRow r) => Connection -> Query -> IO [r]
400−query_ = queryWith_ fromRow
401−
402−-- | A version of 'query' taking parser as argument
403−queryWith :: ToRow q => RowParser r -> Connection -> Query -> q -> IO [r]
404−queryWith parser conn template qs = do
405− result <- exec conn =<< formatQuery conn template qs
406− finishQueryWith parser conn template result
407−
408−-- | A version of 'query_' taking parser as argument
409−queryWith_ :: RowParser r -> Connection -> Query -> IO [r]
410−queryWith_ parser conn q@(Query que) = do
313+query_ conn q@(Query que) = do
411314 result <- exec conn que
412− finishQueryWith parser conn q result
315+ finishQuery conn q result
413316
414317-- | Perform a @SELECT@ or other SQL query that is expected to return
415318-- results. Results are streamed incrementally from the server, and
@@ -421,12 +324,6 @@ queryWith_ parser conn q@(Query que) = do
421324-- This fold is /not/ strict. The stream consumer is responsible for
422325-- forcing the evaluation of its result to avoid space leaks.
423326--
424−-- This is implemented using a database cursor. As such, this requires
425−-- a transaction. This function will detect whether or not there is a
426−-- transaction in progress, and will create a 'ReadCommitted' 'ReadOnly'
427−-- transaction if needed. The cursor is given a unique temporary name,
428−-- so the consumer may itself call fold.
429−--
430327-- Exceptions that may be thrown:
431328--
432329-- * 'FormatError': the query string could not be formatted correctly.
@@ -435,10 +332,8 @@ queryWith_ parser conn q@(Query que) = do
435332-- using 'execute' instead of 'query').
436333--
437334-- * 'ResultError': result conversion failed.
438−--
439−-- * 'SqlError': the postgresql backend returned an error, e.g.
440−-- a syntax or type error, or an incorrect table or column name.
441−fold :: ( FromRow row, ToRow params )
335+
336+fold :: ( FromRow row, QueryParams params )
442337 => Connection
443338 -> Query
444339 -> params
@@ -447,20 +342,6 @@ fold :: ( FromRow row, ToRow params )
447342 -> IO a
448343fold = foldWithOptions defaultFoldOptions
449344
450−-- | A version of 'fold' taking a parser as an argument
451−foldWith :: ( ToRow params )
452− => RowParser row
453− -> Connection
454− -> Query
455− -> params
456− -> a
457− -> (a -> row -> IO a)
458− -> IO a
459−foldWith = foldWithOptionsAndParser defaultFoldOptions
460−
461−-- | Number of rows to fetch at a time. 'Automatic' currently defaults
462−-- to 256 rows, although it might be nice to make this more intelligent
463−-- based on e.g. the average size of the rows.
464345data FetchQuantity
465346 = Automatic
466347 | Fixed !Int
@@ -471,20 +352,12 @@ data FoldOptions
471352 transactionMode :: !TransactionMode
472353 }
473354
474−-- | defaults to 'Automatic', and 'TransactionMode' 'ReadCommitted' 'ReadOnly'
475−defaultFoldOptions :: FoldOptions
476355defaultFoldOptions = FoldOptions {
477356 fetchQuantity = Automatic,
478357 transactionMode = TransactionMode ReadCommitted ReadOnly
479358 }
480359
481−-- | The same as 'fold', but this provides a bit more control over
482−-- lower-level details. Currently, the number of rows fetched per
483−-- round-trip to the server and the transaction mode may be adjusted
484−-- accordingly. If the connection is already in a transaction,
485−-- then the existing transaction is used and thus the 'transactionMode'
486−-- option is ignored.
487−foldWithOptions :: ( FromRow row, ToRow params )
360+foldWithOptions :: ( FromRow row, QueryParams params )
488361 => FoldOptions
489362 -> Connection
490363 -> Query
@@ -492,21 +365,9 @@ foldWithOptions :: ( FromRow row, ToRow params )
492365 -> a
493366 -> (a -> row -> IO a)
494367 -> IO a
495−foldWithOptions opts = foldWithOptionsAndParser opts fromRow
496−
497−-- | A version of 'foldWithOptions' taking a parser as an argument
498−foldWithOptionsAndParser :: (ToRow params)
499− => FoldOptions
500− -> RowParser row
501− -> Connection
502− -> Query
503− -> params
504− -> a
505− -> (a -> row -> IO a)
506− -> IO a
507−foldWithOptionsAndParser opts parser conn template qs a f = do
368+foldWithOptions opts conn template qs a f = do
508369 q <- formatQuery conn template qs
509− doFold opts parser conn template (Query q) a f
370+ doFold opts conn template (Query q) a f
510371
511372-- | A version of 'fold' that does not perform query substitution.
512373fold_ :: (FromRow r) =>
@@ -517,14 +378,6 @@ fold_ :: (FromRow r) =>
517378 -> IO a
518379fold_ = foldWithOptions_ defaultFoldOptions
519380
520−-- | A version of 'fold_' taking a parser as an argument
521−foldWith_ :: RowParser r
522− -> Connection
523− -> Query
524− -> a
525− -> (a -> r -> IO a)
526− -> IO a
527−foldWith_ = foldWithOptionsAndParser_ defaultFoldOptions
528381
529382foldWithOptions_ :: (FromRow r) =>
530383 FoldOptions
@@ -533,27 +386,18 @@ foldWithOptions_ :: (FromRow r) =>
533386 -> a -- ^ Initial state for result consumer.
534387 -> (a -> r -> IO a) -- ^ Result consumer.
535388 -> IO a
536−foldWithOptions_ opts conn query' a f = doFold opts fromRow conn query' query' a f
537−
538−-- | A version of 'foldWithOptions_' taking a parser as an argument
539−foldWithOptionsAndParser_ :: FoldOptions
540− -> RowParser r
541− -> Connection
542− -> Query -- ^ Query.
543− -> a -- ^ Initial state for result consumer.
544− -> (a -> r -> IO a) -- ^ Result consumer.
545− -> IO a
546−foldWithOptionsAndParser_ opts parser conn query' a f = doFold opts parser conn query' query' a f
547−
548−doFold :: FoldOptions
549− -> RowParser row
389+foldWithOptions_ opts conn query a f = doFold opts conn query query a f
390+
391+
392+doFold :: ( FromRow row )
393+ => FoldOptions
550394 -> Connection
551395 -> Query
552396 -> Query
553397 -> a
554398 -> (a -> row -> IO a)
555399 -> IO a
556−doFold FoldOptions{..} parser conn _template q a0 f = do
400+doFold FoldOptions{..} conn _template q a f = do
557401 stat <- withConnection conn PQ.transactionStatus
558402 case stat of
559403 PQ.TransIdle -> withTransactionMode transactionMode conn go
@@ -571,17 +415,11 @@ doFold FoldOptions{..} parser conn _template q a0 f = do
571415 PQ.TransUnknown -> fail "foldWithOpts FIXME: PQ.TransUnknown"
572416 -- Not sure what this means.
573417 where
574− declare =
575− declareCursor conn q
576− fetch cursor a =
577− foldForwardWithParser cursor parser chunkSize f a
578−
579− go = bracket declare closeCursor $ \cursor ->
580− let loop a = fetch cursor a >>=
581− \r -> case r of
582− Left x -> return x
583− Right x -> loop x
584− in loop a0
418+ go = do
419+ -- FIXME: what about name clashes with already-declared cursors?
420+ _ <- execute_ conn ("DECLARE fold NO SCROLL CURSOR FOR "
421+ `mappend` q)
422+ loop a `finally` execute_ conn "CLOSE fold"
585423
586424-- FIXME: choose the Automatic chunkSize more intelligently
587425-- One possibility is to use the type of the results, although this
@@ -592,45 +430,193 @@ doFold FoldOptions{..} parser conn _template q a0 f = do
592430 chunkSize = case fetchQuantity of
593431 Automatic -> 256
594432 Fixed n -> n
433+ loop a = do
434+ rs <- query conn "FETCH FORWARD ? FROM fold" (Only chunkSize)
435+ if null rs then return a else foldM f a rs >>= loop
595436
596437-- | A version of 'fold' that does not transform a state value.
597−forEach :: (ToRow q, FromRow r) =>
438+forEach :: (QueryParams q, FromRow r) =>
598439 Connection
599440 -> Query -- ^ Query template.
600441 -> q -- ^ Query parameters.
601442 -> (r -> IO ()) -- ^ Result consumer.
602443 -> IO ()
603−forEach = forEachWith fromRow
444+forEach conn template qs = fold conn template qs () . const
604445{-# INLINE forEach #-}
605446
606−-- | A version of 'forEach' taking a parser as an argument
607−forEachWith :: ( ToRow q )
608− => RowParser r
609− -> Connection
610− -> Query
611− -> q
612− -> (r -> IO ())
613− -> IO ()
614−forEachWith parser conn template qs = foldWith parser conn template qs () . const
615−{-# INLINE forEachWith #-}
616−
617447-- | A version of 'forEach' that does not perform query substitution.
618448forEach_ :: (FromRow r) =>
619449 Connection
620450 -> Query -- ^ Query template.
621451 -> (r -> IO ()) -- ^ Result consumer.
622452 -> IO ()
623−forEach_ = forEachWith_ fromRow
453+forEach_ conn template = fold_ conn template () . const
624454{-# INLINE forEach_ #-}
625455
626−forEachWith_ :: RowParser r
627− -> Connection
628− -> Query
629− -> (r -> IO ())
630− -> IO ()
631−forEachWith_ parser conn template = foldWith_ parser conn template () . const
632−{-# INLINE forEachWith_ #-}
633−
456+forM' :: (Ord n, Num n) => n -> n -> (n -> IO a) -> IO [a]
457+forM' lo hi m = loop hi []
458+ where
459+ loop !n !as
460+ | n < lo = return as
461+ | otherwise = do
462+ a <- m n
463+ loop (n-1) (a:as)
464+
465+finishQuery :: (FromRow r) => Connection -> Query -> PQ.Result -> IO [r]
466+finishQuery conn q result = do
467+ status <- PQ.resultStatus result
468+ case status of
469+ PQ.CommandOk -> do
470+ throwIO $ QueryError "query resulted in a command response" q
471+ PQ.TuplesOk -> do
472+ ncols <- PQ.nfields result
473+ let unCol (PQ.Col x) = fromIntegral x
474+ typenames <- V.generateM (unCol ncols)
475+ (\(PQ.Col . fromIntegral -> col) -> do
476+ getTypename conn =<< PQ.ftype result col)
477+ nrows <- PQ.ntuples result
478+ ncols <- PQ.nfields result
479+ forM' 0 (nrows-1) $ \row -> do
480+ let rw = Row row typenames result
481+ case runStateT (runReaderT (unRP fromRow) rw) 0 of
482+ Ok (val,col) | col == ncols -> return val
483+ | otherwise -> do
484+ vals <- forM' 0 (ncols-1) $ \c -> do
485+ v <- PQ.getvalue result row c
486+ return ( typenames V.! unCol c
487+ , fmap ellipsis v )
488+ throw (ConversionFailed
489+ (show (unCol ncols) ++ " values: " ++ show vals)
490+ (show (unCol col) ++ " slots in target type")
491+ "mismatch between number of columns to \
492+ \convert and number in target type")
493+ Errors [] -> throwIO $ ConversionFailed "" "" "unknown error"
494+ Errors [x] -> throwIO x
495+ Errors xs -> throwIO $ ManyErrors xs
496+
497+ellipsis :: ByteString -> ByteString
498+ellipsis bs
499+ | B.length bs > 15 = B.take 10 bs `B.append` "[...]"
500+ | otherwise = bs
501+
502+-- | Throw a 'ConversionFailed' exception, indicating a mismatch
503+-- between the number of columns in the 'Field' and row, and the
504+-- number in the collection to be converted to.
505+convertError :: [Field]
506+ -- ^ Descriptors of fields to be converted.
507+ -> [Maybe ByteString]
508+ -- ^ Contents of the row to be converted.
509+ -> Int
510+ -- ^ Number of columns expected for conversion. For
511+ -- instance, if converting to a 3-tuple, the number to
512+ -- provide here would be 3.
513+ -> Either SomeException a
514+convertError fs vs n = Left . SomeException $ ConversionFailed
515+ (show (length fs) ++ " values: " ++ show (zip (map typename fs)
516+ (map (fmap ellipsis) vs)))
517+ (show n ++ " slots in target type")
518+ "mismatch between number of columns to convert and number in target type"
519+
520+
521+-- | Of the four isolation levels defined by the SQL standard,
522+-- these are the three levels distinguished by PostgreSQL as of version 9.0.
523+-- See <http://www.postgresql.org/docs/9.1/static/transaction-iso.html>
524+-- for more information.
525+
526+data IsolationLevel
527+ = ReadCommitted
528+ | RepeatableRead
529+ | Serializable
530+ deriving (Show, Eq, Ord, Enum, Bounded)
531+
532+data ReadWriteMode
533+ = ReadWrite
534+ | ReadOnly
535+ deriving (Show, Eq, Ord, Enum, Bounded)
536+
537+data TransactionMode = TransactionMode {
538+ isolationLevel :: !IsolationLevel,
539+ readWriteMode :: !ReadWriteMode
540+ } deriving (Show, Eq)
541+
542+defaultTransactionMode :: TransactionMode
543+defaultTransactionMode = TransactionMode ReadCommitted ReadWrite
544+
545+defaultIsolationLevel :: IsolationLevel
546+defaultIsolationLevel = ReadCommitted
547+
548+defaultReadWriteMode :: ReadWriteMode
549+defaultReadWriteMode = ReadWrite
550+
551+-- | Execute an action inside a SQL transaction.
552+--
553+-- This function initiates a transaction with a \"@begin
554+-- transaction@\" statement, then executes the supplied action. If
555+-- the action succeeds, the transaction will be completed with
556+-- 'Base.commit' before this function returns.
557+--
558+-- If the action throws /any/ kind of exception (not just a
559+-- PostgreSQL-related exception), the transaction will be rolled back using
560+-- 'rollback', then the exception will be rethrown.
561+withTransaction :: Connection -> IO a -> IO a
562+withTransaction = withTransactionMode defaultTransactionMode
563+
564+-- | Execute an action inside a SQL transaction with a given isolation level.
565+withTransactionLevel :: IsolationLevel -> Connection -> IO a -> IO a
566+withTransactionLevel lvl
567+ = withTransactionMode defaultTransactionMode { isolationLevel = lvl }
568+
569+-- | Execute an action inside a SQL transaction with a given transaction mode.
570+withTransactionMode :: TransactionMode -> Connection -> IO a -> IO a
571+withTransactionMode mode conn act = do
572+ beginMode mode conn
573+ r <- act `onException` rollback conn
574+ commit conn
575+ return r
576+
577+-- | Rollback a transaction.
578+rollback :: Connection -> IO ()
579+rollback conn = execute_ conn "ABORT" >> return ()
580+
581+-- | Commit a transaction.
582+commit :: Connection -> IO ()
583+commit conn = execute_ conn "COMMIT" >> return ()
584+
585+-- | Begin a transaction.
586+begin :: Connection -> IO ()
587+begin = beginMode defaultTransactionMode
588+
589+-- | Begin a transaction with a given isolation level
590+beginLevel :: IsolationLevel -> Connection -> IO ()
591+beginLevel lvl = beginMode defaultTransactionMode { isolationLevel = lvl }
592+
593+-- | Begin a transaction with a given transaction mode
594+beginMode :: TransactionMode -> Connection -> IO ()
595+beginMode mode conn = do
596+ execute_ conn $! case mode of
597+ TransactionMode ReadCommitted ReadWrite ->
598+ "BEGIN"
599+ TransactionMode ReadCommitted ReadOnly ->
600+ "BEGIN READ ONLY"
601+ TransactionMode RepeatableRead ReadWrite ->
602+ "BEGIN ISOLATION LEVEL REPEATABLE READ"
603+ TransactionMode RepeatableRead ReadOnly ->
604+ "BEGIN ISOLATION LEVEL REPEATABLE READ READ ONLY"
605+ TransactionMode Serializable ReadWrite ->
606+ "BEGIN ISOLATION LEVEL SERIALIZABLE"
607+ TransactionMode Serializable ReadOnly ->
608+ "BEGIN ISOLATION LEVEL SERIALIZABLE READ ONLY"
609+ return ()
610+
611+fmtError :: String -> Query -> [Action] -> a
612+fmtError msg q xs = throw FormatError {
613+ fmtMessage = msg
614+ , fmtQuery = q
615+ , fmtParams = map twiddle xs
616+ }
617+ where twiddle (Plain b) = toByteString b
618+ twiddle (Escape s) = s
619+ twiddle (Many ys) = B.concat (map twiddle ys)
634620
635621-- $use
636622--
@@ -658,11 +644,9 @@ forEachWith_ parser conn template = foldWith_ parser conn template () . const
658644-- >
659645-- > import Database.PostgreSQL.Simple
660646-- >
661−-- > hello :: IO Int
662647-- > hello = do
663−-- > conn <- connectPostgreSQL ""
664−-- > [Only i] <- query_ conn "select 2 + 2"
665−-- > return i
648+-- > conn <- connect defaultConnectInfo
649+-- > query conn "select 2 + 2"
666650--
667651-- A 'Query' value does not represent the actual query that will be
668652-- executed, but is a template for constructing the final query.
@@ -709,7 +693,7 @@ forEachWith_ parser conn template = foldWith_ parser conn template () . const
709693-- Automated type inference means that you will often be able to avoid
710694-- supplying explicit type signatures for the elements of a tuple.
711695-- However, sometimes the compiler will not be able to infer your
712−-- types. Consider a case where you write a numeric literal in a
696+-- types. Consider a care where you write a numeric literal in a
713697-- parameter tuple:
714698--
715699-- > query conn "select ? + ?" (40,2)
@@ -723,30 +707,15 @@ forEachWith_ parser conn template = foldWith_ parser conn template () . const
723707-- The same kind of problem can arise with string literals if you have
724708-- the @OverloadedStrings@ language extension enabled. Again, just
725709-- use an explicit type signature if this happens.
726−--
727−-- Finally, remember that the compiler must be able to infer the type
728−-- of a query's /results/ as well as its parameters. We might like
729−-- the following example to work:
730−--
731−-- > print =<< query_ conn "select 2 + 2"
732−--
733−-- Unfortunately, while a quick glance tells us that the result type
734−-- should be a single row containing a single numeric column, the
735−-- compiler has no way to infer what the types are. We can easily fix
736−-- this by providing an explicit type annotation:
737−--
738−-- > xs <- query_ conn "select 2 + 2"
739−-- > print (xs :: [Only Int])
740710
741711-- $only_param
742712--
743713-- Haskell lacks a single-element tuple type, so if you have just one
744−-- value you want substituted into a query or a single-column result,
745−-- what should you do?
714+-- value you want substituted into a query, what should you do?
746715--
747716-- The obvious approach would appear to be something like this:
748717--
749−-- > instance (ToField a) => ToRow a where
718+-- > instance (Param a) => QueryParam a where
750719-- > ...
751720--
752721-- Unfortunately, this wreaks havoc with type inference, so we take a
@@ -757,9 +726,6 @@ forEachWith_ parser conn template = foldWith_ parser conn template () . const
757726--
758727-- > execute conn "insert into users (first_name) values (?)"
759728-- > ["Nuala"]
760−--
761−-- A row of /n/ query results is represented using an /n/-tuple, so
762−-- you should use 'Only' to represent a single-column result.
763729
764730-- $in
765731--
@@ -777,7 +743,7 @@ forEachWith_ parser conn template = foldWith_ parser conn template () . const
777743-- Here's an example:
778744--
779745-- > query conn "select * from users where first_name in ?" $
780−-- > Only $ In ["Anna", "Boris", "Carla"]
746+-- > In ["Anna", "Boris", "Carla"]
781747--
782748-- If your 'In'-wrapped list is empty, the string @\"(null)\"@ will be
783749-- substituted instead, to ensure that your clause remains
@@ -805,7 +771,7 @@ forEachWith_ parser conn template = foldWith_ parser conn template () . const
805771-- * There must be no other \"@?@\" characters anywhere in your
806772-- template.
807773--
808−-- * There must be one or more \"@?@\" in the parentheses.
774+-- * There must one or more \"@?@\" in the parentheses.
809775--
810776-- * Extra white space is fine.
811777--
@@ -826,22 +792,6 @@ forEachWith_ parser conn template = foldWith_ parser conn template () . const
826792-- > insert into users (first_name,last_name) values
827793-- > ('Boris','Karloff'),('Ed','Wood')
828794
829−-- $returning
830−--
831−-- PostgreSQL supports returning values from data manipulation statements
832−-- such as @INSERT@ and @UPDATE@. You can use these statements by
833−-- using 'query' instead of 'execute'. For multi-tuple inserts,
834−-- use 'returning' instead of 'executeMany'.
835−--
836−-- For example, were there an auto-incrementing @id@ column and
837−-- timestamp column @t@ that defaulted to the present time for the
838−-- @sales@ table, then the following query would insert two new
839−-- sales records and also return their new @id@s and timestamps.
840−--
841−-- > let q = "insert into sales (amount, label) values (?,?) returning id, t"
842−-- > xs :: [(Int, UTCTime)] <- query conn q (15,"Sawdust")
843−-- > ys :: [(Int, UTCTime)] <- returning conn q [(20,"Chips"),(300,"Wood")]
844−
845795-- $result
846796--
847797-- The 'query' and 'query_' functions return a list of values in the
@@ -876,7 +826,7 @@ forEachWith_ parser conn template = foldWith_ parser conn template () . const
876826--
877827-- Although SQL can accommodate @NULL@ as a value for any of these
878828-- types, Haskell cannot. If your result contains columns that may be
879−-- @NULL@, be sure that you use 'Maybe' in those positions of your
829+-- @NULL@, be sure that you use 'Maybe' in those positions of of your
880830-- tuple.
881831--
882832-- > (Text, Maybe Int, Int)
@@ -902,7 +852,7 @@ forEachWith_ parser conn template = foldWith_ parser conn template () . const
902852-- all values of the given PostgreSQL type is considered \"compatible\".
903853-- For instance, you can always extract a PostgreSQL 16-bit @SMALLINT@
904854-- column to a Haskell 'Int'. The Haskell 'Float' type can accurately
905−-- represent a @SMALLINT@, so it is considered compatible with those types.
855+-- represent a @SMALLINT@, so it is considered compatble with those types.
906856--
907857-- * A numeric compatibility check is based only on the type of a
908858-- column, /not/ on its values. For instance, a PostgreSQL 64-bit
@@ -916,3 +866,25 @@ forEachWith_ parser conn template = foldWith_ parser conn template () . const
916866-- UTF-8. If you use some other encoding, decoding may fail or give
917867-- wrong results. In such cases, write a @newtype@ wrapper and a
918868-- custom 'Result' instance to handle your encoding.
869+
870+getTypename :: Connection -> PQ.Oid -> IO ByteString
871+getTypename conn@Connection{..} oid =
872+ case oid2builtin oid of
873+ Just builtin -> return $! builtin2typname builtin
874+ Nothing -> modifyMVar connectionObjects $ \oidmap -> do
875+ case IntMap.lookup (oid2int oid) oidmap of
876+ Just name -> return (oidmap, name)
877+ Nothing -> do
878+ names <- query conn "SELECT typname FROM pg_type WHERE oid=?"
879+ (Only oid)
880+ name <- case names of
881+ [] -> return $ throw SqlError {
882+ sqlNativeError = -1,
883+ sqlErrorMsg = "invalid type oid",
884+ sqlState = ""
885+ }
886+ [Only x] -> return x
887+ _ -> fail "typename query returned more than one result"
888+ -- oid is a primary key, so the query should
889+ -- never return more than one result
890+ return (IntMap.insert (oid2int oid) name oidmap, name)
src/Database/PostgreSQL/Simple.hs-bootdeleted−23
@@ -1,23 +0,0 @@
1−module Database.PostgreSQL.Simple
2− ( Connection
3− , Query
4− , query
5− , query_
6− , execute
7− , execute_
8− , executeMany
9− ) where
10−
11−import Data.Int(Int64)
12−import Database.PostgreSQL.Simple.Internal
13−import Database.PostgreSQL.Simple.Types
14−import {-# SOURCE #-} Database.PostgreSQL.Simple.FromRow
15−import {-# SOURCE #-} Database.PostgreSQL.Simple.ToRow
16−
17−query :: (ToRow q, FromRow r) => Connection -> Query -> q -> IO [r]
18−
19−query_ :: FromRow r => Connection -> Query -> IO [r]
20−
21−execute :: ToRow q => Connection -> Query -> q -> IO Int64
22−
23−executeMany :: ToRow q => Connection -> Query -> [q] -> IO Int64
src/Database/PostgreSQL/Simple/Arrays.hsdeleted−92
@@ -1,92 +0,0 @@
1−{-# LANGUAGE PatternGuards #-}
2−
3−------------------------------------------------------------------------------
4−-- |
5−-- Module: Database.PostgreSQL.Simple.Arrays
6−-- Copyright: (c) 2012 Leon P Smith
7−-- License: BSD3
8−-- Maintainer: Leon P Smith <leon@melding-monads.com>
9−-- Stability: experimental
10−--
11−-- A Postgres array parser and pretty-printer.
12−------------------------------------------------------------------------------
13−
14−module Database.PostgreSQL.Simple.Arrays where
15−
16−import Control.Applicative (Applicative(..), Alternative(..), (<$>))
17−import Data.ByteString.Char8 (ByteString)
18−import qualified Data.ByteString.Char8 as B
19−import Data.Monoid
20−import Data.Attoparsec.ByteString.Char8
21−
22−
23−-- | Parse one of three primitive field formats: array, quoted and plain.
24−arrayFormat :: Char -> Parser ArrayFormat
25−arrayFormat delim = Array <$> array delim
26− <|> Plain <$> plain delim
27− <|> Quoted <$> quoted
28−
29−data ArrayFormat = Array [ArrayFormat]
30− | Plain ByteString
31− | Quoted ByteString
32− deriving (Eq, Show, Ord)
33−
34−array :: Char -> Parser [ArrayFormat]
35−array delim = char '{' *> option [] (arrays <|> strings) <* char '}'
36− where
37− strings = sepBy1 (Quoted <$> quoted <|> Plain <$> plain delim) (char delim)
38− arrays = sepBy1 (Array <$> array delim) (char ',')
39− -- NB: Arrays seem to always be delimited by commas.
40−
41−-- | Recognizes a quoted string.
42−quoted :: Parser ByteString
43−quoted = char '"' *> option "" contents <* char '"'
44− where
45− esc' = char '\\' *> (char '\\' <|> char '"')
46− unQ = takeWhile1 (notInClass "\"\\")
47− contents = mconcat <$> many (unQ <|> B.singleton <$> esc')
48−
49−-- | Recognizes a plain string literal, not containing quotes or brackets and
50−-- not containing the delimiter character.
51−plain :: Char -> Parser ByteString
52−plain delim = takeWhile1 (notInClass (delim:"\"{}"))
53−
54−-- Mutually recursive 'fmt' and 'delimit' separate out value formatting
55−-- from the subtleties of delimiting.
56−
57−-- | Format an array format item, using the delimiter character if the item is
58−-- itself an array.
59−fmt :: Char -> ArrayFormat -> ByteString
60−fmt = fmt' False
61−
62−-- | Format a list of array format items, inserting the appropriate delimiter
63−-- between them. When the items are arrays, they will be delimited with
64−-- commas; otherwise, they are delimited with the passed-in-delimiter.
65−delimit :: Char -> [ArrayFormat] -> ByteString
66−delimit _ [] = ""
67−delimit c [x] = fmt' True c x
68−delimit c (x:y:z) = (fmt' True c x `B.snoc` c') `mappend` delimit c (y:z)
69− where
70− c' | Array _ <- x = ','
71− | otherwise = c
72−
73−-- | Format an array format item, using the delimiter character if the item is
74−-- itself an array, optionally applying quoting rules. Creates copies for
75−-- safety when used in 'FromField' instances.
76−fmt' :: Bool -> Char -> ArrayFormat -> ByteString
77−fmt' quoting c x =
78− case x of
79− Array items -> '{' `B.cons` (delimit c items `B.snoc` '}')
80− Plain bytes -> B.copy bytes
81− Quoted q | quoting -> '"' `B.cons` (esc q `B.snoc` '"')
82− | otherwise -> B.copy q
83− -- NB: The 'snoc' and 'cons' functions always copy.
84−
85−-- | Escape a string according to Postgres double-quoted string format.
86−esc :: ByteString -> ByteString
87−esc = B.concatMap f
88− where
89− f '"' = "\\\""
90− f '\\' = "\\\\"
91− f c = B.singleton c
92− -- TODO: Implement easy performance improvements with unfoldr.
src/Database/PostgreSQL/Simple/BuiltinTypes.hsnew file+403
@@ -0,0 +1,403 @@
1+{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}
2+
3+------------------------------------------------------------------------------
4+-- |
5+-- Module: Database.PostgreSQL.Simple.BuiltinTypes
6+-- Copyright: (c) 2011 Leon P Smith
7+-- License: BSD3
8+-- Maintainer: Leon P Smith <leon@melding-monads.com>
9+-- Stability: experimental
10+--
11+------------------------------------------------------------------------------
12+
13+-- Note that this file is generated by tools/GenBuiltinTypes.hs, and should
14+-- not be edited directly
15+
16+module Database.PostgreSQL.Simple.BuiltinTypes
17+ ( BuiltinType (..)
18+ , builtin2oid
19+ , oid2builtin
20+ , builtin2typname
21+ , oid2typname
22+ ) where
23+
24+import Data.Typeable
25+import Data.ByteString (ByteString)
26+import qualified Database.PostgreSQL.LibPQ as PQ
27+
28+data BuiltinType
29+ = Bool
30+ | Bytea
31+ | Char
32+ | Name
33+ | Int8
34+ | Int2
35+ | Int4
36+ | Regproc
37+ | Text
38+ | Oid
39+ | Tid
40+ | Xid
41+ | Cid
42+ | Xml
43+ | Point
44+ | Lseg
45+ | Path
46+ | Box
47+ | Polygon
48+ | Line
49+ | Cidr
50+ | Float4
51+ | Float8
52+ | Abstime
53+ | Reltime
54+ | Tinterval
55+ | Unknown
56+ | Circle
57+ | Money
58+ | Macaddr
59+ | Inet
60+ | Bpchar
61+ | Varchar
62+ | Date
63+ | Time
64+ | Timestamp
65+ | TimestampWithTimeZone
66+ | Interval
67+ | TimeWithTimeZone
68+ | Bit
69+ | Varbit
70+ | Numeric
71+ | Refcursor
72+ | Record
73+ | Void
74+ deriving (Eq, Ord, Enum, Bounded, Read, Show, Typeable)
75+
76+builtin2oid :: BuiltinType -> PQ.Oid
77+builtin2oid typ = PQ.Oid $ case typ of
78+ Bool -> 16
79+ Bytea -> 17
80+ Char -> 18
81+ Name -> 19
82+ Int8 -> 20
83+ Int2 -> 21
84+ Int4 -> 23
85+ Regproc -> 24
86+ Text -> 25
87+ Oid -> 26
88+ Tid -> 27
89+ Xid -> 28
90+ Cid -> 29
91+ Xml -> 142
92+ Point -> 600
93+ Lseg -> 601
94+ Path -> 602
95+ Box -> 603
96+ Polygon -> 604
97+ Line -> 628
98+ Cidr -> 650
99+ Float4 -> 700
100+ Float8 -> 701
101+ Abstime -> 702
102+ Reltime -> 703
103+ Tinterval -> 704
104+ Unknown -> 705
105+ Circle -> 718
106+ Money -> 790
107+ Macaddr -> 829
108+ Inet -> 869
109+ Bpchar -> 1042
110+ Varchar -> 1043
111+ Date -> 1082
112+ Time -> 1083
113+ Timestamp -> 1114
114+ TimestampWithTimeZone -> 1184
115+ Interval -> 1186
116+ TimeWithTimeZone -> 1266
117+ Bit -> 1560
118+ Varbit -> 1562
119+ Numeric -> 1700
120+ Refcursor -> 1790
121+ Record -> 2249
122+ Void -> 2278
123+
124+oid2builtin :: PQ.Oid -> Maybe BuiltinType
125+oid2builtin (PQ.Oid x) = case x of
126+ 16 -> Just Bool
127+ 17 -> Just Bytea
128+ 18 -> Just Char
129+ 19 -> Just Name
130+ 20 -> Just Int8
131+ 21 -> Just Int2
132+ 23 -> Just Int4
133+ 24 -> Just Regproc
134+ 25 -> Just Text
135+ 26 -> Just Oid
136+ 27 -> Just Tid
137+ 28 -> Just Xid
138+ 29 -> Just Cid
139+ 142 -> Just Xml
140+ 600 -> Just Point
141+ 601 -> Just Lseg
142+ 602 -> Just Path
143+ 603 -> Just Box
144+ 604 -> Just Polygon
145+ 628 -> Just Line
146+ 650 -> Just Cidr
147+ 700 -> Just Float4
148+ 701 -> Just Float8
149+ 702 -> Just Abstime
150+ 703 -> Just Reltime
151+ 704 -> Just Tinterval
152+ 705 -> Just Unknown
153+ 718 -> Just Circle
154+ 790 -> Just Money
155+ 829 -> Just Macaddr
156+ 869 -> Just Inet
157+ 1042 -> Just Bpchar
158+ 1043 -> Just Varchar
159+ 1082 -> Just Date
160+ 1083 -> Just Time
161+ 1114 -> Just Timestamp
162+ 1184 -> Just TimestampWithTimeZone
163+ 1186 -> Just Interval
164+ 1266 -> Just TimeWithTimeZone
165+ 1560 -> Just Bit
166+ 1562 -> Just Varbit
167+ 1700 -> Just Numeric
168+ 1790 -> Just Refcursor
169+ 2249 -> Just Record
170+ 2278 -> Just Void
171+ _ -> Nothing
172+
173+builtin2typname :: BuiltinType -> ByteString
174+builtin2typname typ = case typ of
175+ Bool -> bool
176+ Bytea -> bytea
177+ Char -> char
178+ Name -> name
179+ Int8 -> int8
180+ Int2 -> int2
181+ Int4 -> int4
182+ Regproc -> regproc
183+ Text -> text
184+ Oid -> oid
185+ Tid -> tid
186+ Xid -> xid
187+ Cid -> cid
188+ Xml -> xml
189+ Point -> point
190+ Lseg -> lseg
191+ Path -> path
192+ Box -> box
193+ Polygon -> polygon
194+ Line -> line
195+ Cidr -> cidr
196+ Float4 -> float4
197+ Float8 -> float8
198+ Abstime -> abstime
199+ Reltime -> reltime
200+ Tinterval -> tinterval
201+ Unknown -> unknown
202+ Circle -> circle
203+ Money -> money
204+ Macaddr -> macaddr
205+ Inet -> inet
206+ Bpchar -> bpchar
207+ Varchar -> varchar
208+ Date -> date
209+ Time -> time
210+ Timestamp -> timestamp
211+ TimestampWithTimeZone -> timestamptz
212+ Interval -> interval
213+ TimeWithTimeZone -> timetz
214+ Bit -> bit
215+ Varbit -> varbit
216+ Numeric -> numeric
217+ Refcursor -> refcursor
218+ Record -> record
219+ Void -> void
220+
221+oid2typname :: PQ.Oid -> Maybe ByteString
222+oid2typname (PQ.Oid x) = case x of
223+ 16 -> Just bool
224+ 17 -> Just bytea
225+ 18 -> Just char
226+ 19 -> Just name
227+ 20 -> Just int8
228+ 21 -> Just int2
229+ 23 -> Just int4
230+ 24 -> Just regproc
231+ 25 -> Just text
232+ 26 -> Just oid
233+ 27 -> Just tid
234+ 28 -> Just xid
235+ 29 -> Just cid
236+ 142 -> Just xml
237+ 600 -> Just point
238+ 601 -> Just lseg
239+ 602 -> Just path
240+ 603 -> Just box
241+ 604 -> Just polygon
242+ 628 -> Just line
243+ 650 -> Just cidr
244+ 700 -> Just float4
245+ 701 -> Just float8
246+ 702 -> Just abstime
247+ 703 -> Just reltime
248+ 704 -> Just tinterval
249+ 705 -> Just unknown
250+ 718 -> Just circle
251+ 790 -> Just money
252+ 829 -> Just macaddr
253+ 869 -> Just inet
254+ 1042 -> Just bpchar
255+ 1043 -> Just varchar
256+ 1082 -> Just date
257+ 1083 -> Just time
258+ 1114 -> Just timestamp
259+ 1184 -> Just timestamptz
260+ 1186 -> Just interval
261+ 1266 -> Just timetz
262+ 1560 -> Just bit
263+ 1562 -> Just varbit
264+ 1700 -> Just numeric
265+ 1790 -> Just refcursor
266+ 2249 -> Just record
267+ 2278 -> Just void
268+ _ -> Nothing
269+
270+bool :: ByteString
271+bool = "bool"
272+
273+bytea :: ByteString
274+bytea = "bytea"
275+
276+char :: ByteString
277+char = "char"
278+
279+name :: ByteString
280+name = "name"
281+
282+int8 :: ByteString
283+int8 = "int8"
284+
285+int2 :: ByteString
286+int2 = "int2"
287+
288+int4 :: ByteString
289+int4 = "int4"
290+
291+regproc :: ByteString
292+regproc = "regproc"
293+
294+text :: ByteString
295+text = "text"
296+
297+oid :: ByteString
298+oid = "oid"
299+
300+tid :: ByteString
301+tid = "tid"
302+
303+xid :: ByteString
304+xid = "xid"
305+
306+cid :: ByteString
307+cid = "cid"
308+
309+xml :: ByteString
310+xml = "xml"
311+
312+point :: ByteString
313+point = "point"
314+
315+lseg :: ByteString
316+lseg = "lseg"
317+
318+path :: ByteString
319+path = "path"
320+
321+box :: ByteString
322+box = "box"
323+
324+polygon :: ByteString
325+polygon = "polygon"
326+
327+line :: ByteString
328+line = "line"
329+
330+cidr :: ByteString
331+cidr = "cidr"
332+
333+float4 :: ByteString
334+float4 = "float4"
335+
336+float8 :: ByteString
337+float8 = "float8"
338+
339+abstime :: ByteString
340+abstime = "abstime"
341+
342+reltime :: ByteString
343+reltime = "reltime"
344+
345+tinterval :: ByteString
346+tinterval = "tinterval"
347+
348+unknown :: ByteString
349+unknown = "unknown"
350+
351+circle :: ByteString
352+circle = "circle"
353+
354+money :: ByteString
355+money = "money"
356+
357+macaddr :: ByteString
358+macaddr = "macaddr"
359+
360+inet :: ByteString
361+inet = "inet"
362+
363+bpchar :: ByteString
364+bpchar = "bpchar"
365+
366+varchar :: ByteString
367+varchar = "varchar"
368+
369+date :: ByteString
370+date = "date"
371+
372+time :: ByteString
373+time = "time"
374+
375+timestamp :: ByteString
376+timestamp = "timestamp"
377+
378+timestamptz :: ByteString
379+timestamptz = "timestamptz"
380+
381+interval :: ByteString
382+interval = "interval"
383+
384+timetz :: ByteString
385+timetz = "timetz"
386+
387+bit :: ByteString
388+bit = "bit"
389+
390+varbit :: ByteString
391+varbit = "varbit"
392+
393+numeric :: ByteString
394+numeric = "numeric"
395+
396+refcursor :: ByteString
397+refcursor = "refcursor"
398+
399+record :: ByteString
400+record = "record"
401+
402+void :: ByteString
403+void = "void"
src/Database/PostgreSQL/Simple/Compat.hsdeleted−41
@@ -1,41 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−-- | This is a module of its own, partly because it uses the CPP extension,
3−-- which doesn't play well with backslash-broken string literals.
4−module Database.PostgreSQL.Simple.Compat
5− ( mask
6− , (<>)
7− , unsafeDupablePerformIO
8− , toByteString
9− , scientificBuilder
10− , toPico
11− , fromPico
12− ) where
13−
14−import qualified Control.Exception as E
15−import Data.ByteString (ByteString)
16−import Data.ByteString.Lazy (toStrict)
17−import Data.ByteString.Builder (Builder, toLazyByteString)
18−import Data.Text.Lazy.Builder.Scientific (scientificBuilder)
19−import System.IO.Unsafe (unsafeDupablePerformIO)
20−import Data.Fixed (Pico)
21−import Data.Fixed (Fixed(MkFixed))
22−
23−-- | Like 'E.mask', but backported to base before version 4.3.0.
24−--
25−-- Note that the restore callback is monomorphic, unlike in 'E.mask'. This
26−-- could be fixed by changing the type signature, but it would require us to
27−-- enable the RankNTypes extension (since 'E.mask' has a rank-3 type). The
28−-- 'withTransactionMode' function calls the restore callback only once, so we
29−-- don't need that polymorphism.
30−mask :: ((IO a -> IO a) -> IO b) -> IO b
31−mask io = E.mask $ \restore -> io restore
32−{-# INLINE mask #-}
33−
34−toByteString :: Builder -> ByteString
35−toByteString x = toStrict (toLazyByteString x)
36−
37−toPico :: Integer -> Pico
38−toPico = MkFixed
39−
40−fromPico :: Pico -> Integer
41−fromPico (MkFixed i) = i
src/Database/PostgreSQL/Simple/Copy.hsdeleted−269
@@ -1,269 +0,0 @@
1−{-# LANGUAGE CPP, DeriveDataTypeable #-}
2−
3−------------------------------------------------------------------------------
4−-- |
5−-- Module: Database.PostgreSQL.Simple.Copy
6−-- Copyright: (c) 2013 Leon P Smith
7−-- License: BSD3
8−-- Maintainer: Leon P Smith <leon@melding-monads.com>
9−-- Stability: experimental
10−--
11−-- mid-level support for COPY IN and COPY OUT. See
12−-- <https://www.postgresql.org/docs/9.5/static/sql-copy.html> for
13−-- more information.
14−--
15−-- To use this binding, first call 'copy' with an appropriate
16−-- query as documented in the link above. Then, in the case of a
17−-- @COPY TO STDOUT@ query, call 'getCopyData' repeatedly until it
18−-- returns 'CopyOutDone'. In the case of a @COPY FROM STDIN@
19−-- query, call 'putCopyData' repeatedly and then finish by calling
20−-- either 'putCopyEnd' to proceed or 'putCopyError' to abort.
21−--
22−-- You cannot issue another query on the same connection while a copy
23−-- is ongoing; this will result in an exception. It is harmless to
24−-- concurrently call @getNotification@ on a connection while it is in
25−-- a @CopyIn@ or @CopyOut@ state, however be aware that current versions
26−-- of the PostgreSQL backend will not deliver notifications to a client
27−-- while a transaction is ongoing.
28−--
29−------------------------------------------------------------------------------
30−
31−module Database.PostgreSQL.Simple.Copy
32− ( copy
33− , copy_
34− , CopyOutResult(..)
35− , foldCopyData
36− , getCopyData
37− , putCopyData
38− , putCopyEnd
39− , putCopyError
40− ) where
41−
42−import Control.Applicative
43−import Control.Concurrent
44−import Control.Exception ( throwIO )
45−import qualified Data.Attoparsec.ByteString.Char8 as P
46−import Data.Typeable(Typeable)
47−import Data.Int(Int64)
48−import qualified Data.ByteString.Char8 as B
49−import qualified Database.PostgreSQL.LibPQ as PQ
50−import Database.PostgreSQL.Simple
51−import Database.PostgreSQL.Simple.Types
52−import Database.PostgreSQL.Simple.Internal hiding (result, row)
53−
54−
55−-- | Issue a @COPY FROM STDIN@ or @COPY TO STDOUT@ query. In the former
56−-- case, the connection's state will change to @CopyIn@; in the latter,
57−-- @CopyOut@. The connection must be in the ready state in order
58−-- to call this function. Performs parameter substitution.
59−
60−copy :: ( ToRow params ) => Connection -> Query -> params -> IO ()
61−copy conn template qs = do
62− q <- formatQuery conn template qs
63− doCopy "Database.PostgreSQL.Simple.Copy.copy" conn template q
64−
65−
66−-- | Issue a @COPY FROM STDIN@ or @COPY TO STDOUT@ query. In the former
67−-- case, the connection's state will change to @CopyIn@; in the latter,
68−-- @CopyOut@. The connection must be in the ready state in order
69−-- to call this function. Does not perform parameter subsitution.
70−
71−copy_ :: Connection -> Query -> IO ()
72−copy_ conn (Query q) = do
73− doCopy "Database.PostgreSQL.Simple.Copy.copy_" conn (Query q) q
74−
75−doCopy :: B.ByteString -> Connection -> Query -> B.ByteString -> IO ()
76−doCopy funcName conn template q = do
77− result <- exec conn q
78− status <- PQ.resultStatus result
79− let errMsg msg = throwIO $ QueryError
80− (B.unpack funcName ++ " " ++ msg)
81− template
82− let err = errMsg $ show status
83− case status of
84− PQ.EmptyQuery -> err
85− PQ.CommandOk -> err
86− PQ.TuplesOk -> err
87− PQ.CopyOut -> return ()
88− PQ.CopyIn -> return ()
89− PQ.CopyBoth -> errMsg "COPY BOTH is not supported"
90− PQ.SingleTuple -> errMsg "single-row mode is not supported"
91− PQ.BadResponse -> throwResultError funcName result status
92− PQ.NonfatalError -> throwResultError funcName result status
93− PQ.FatalError -> throwResultError funcName result status
94−
95−data CopyOutResult
96− = CopyOutRow !B.ByteString -- ^ Data representing either exactly
97− -- one row of the result, or header
98− -- or footer data depending on format.
99− | CopyOutDone {-# UNPACK #-} !Int64 -- ^ No more rows, and a count of the
100− -- number of rows returned.
101− deriving (Eq, Typeable, Show)
102−
103−
104−-- | Fold over @COPY TO STDOUT@ query passing each copied row to an accumulator
105−-- and calling a post-process at the end. A connection must be in the
106−-- @CopyOut@ state in order to call this function.
107−--
108−-- __Example__
109−--
110−-- > (acc, count) <- foldCopyData conn
111−-- > (\acc row -> return (row:acc))
112−-- > (\acc count -> return (acc, count))
113−-- > []
114−
115−foldCopyData
116− :: Connection -- ^ Database connection
117− -> (a -> B.ByteString -> IO a) -- ^ Accumulate one row of the result
118− -> (a -> Int64 -> IO b) -- ^ Post-process accumulator with a count of rows
119− -> a -- ^ Initial accumulator
120− -> IO b -- ^ Result
121−foldCopyData conn f g !acc = do
122− result <- getCopyData conn
123− case result of
124− CopyOutRow row -> f acc row >>= foldCopyData conn f g
125− CopyOutDone count -> g acc count
126−
127−
128−-- | Retrieve some data from a @COPY TO STDOUT@ query. A connection
129−-- must be in the @CopyOut@ state in order to call this function. If this
130−-- returns a 'CopyOutRow', the connection remains in the @CopyOut@ state,
131−-- if it returns 'CopyOutDone', then the connection has reverted to the
132−-- ready state.
133−
134−getCopyData :: Connection -> IO CopyOutResult
135−getCopyData conn = withConnection conn loop
136− where
137− funcName = "Database.PostgreSQL.Simple.Copy.getCopyData"
138− loop pqconn = do
139−#if defined(mingw32_HOST_OS)
140− row <- PQ.getCopyData pqconn False
141−#else
142− row <- PQ.getCopyData pqconn True
143−#endif
144− case row of
145− PQ.CopyOutRow rowdata -> return $! CopyOutRow rowdata
146− PQ.CopyOutDone -> CopyOutDone <$> getCopyCommandTag funcName pqconn
147−#if defined(mingw32_HOST_OS)
148− PQ.CopyOutWouldBlock -> do
149− fail (B.unpack funcName ++ ": the impossible happened")
150−#else
151− PQ.CopyOutWouldBlock -> do
152− mfd <- PQ.socket pqconn
153− case mfd of
154− Nothing -> throwIO (fdError funcName)
155− Just fd -> do
156− threadWaitRead fd
157− _ <- PQ.consumeInput pqconn
158− loop pqconn
159−#endif
160− PQ.CopyOutError -> do
161− mmsg <- PQ.errorMessage pqconn
162− throwIO SqlError {
163− sqlState = "",
164− sqlExecStatus = FatalError,
165− sqlErrorMsg = maybe "" id mmsg,
166− sqlErrorDetail = "",
167− sqlErrorHint = funcName
168− }
169−
170−
171−-- | Feed some data to a @COPY FROM STDIN@ query. Note that
172−-- the data does not need to represent a single row, or even an
173−-- integral number of rows. The net result of
174−-- @putCopyData conn a >> putCopyData conn b@
175−-- is the same as @putCopyData conn c@ whenever @c == BS.append a b@.
176−--
177−-- A connection must be in the @CopyIn@ state in order to call this
178−-- function, otherwise a 'SqlError' exception will result. The
179−-- connection remains in the @CopyIn@ state after this function
180−-- is called.
181−
182−putCopyData :: Connection -> B.ByteString -> IO ()
183−putCopyData conn dat = withConnection conn $ \pqconn -> do
184− doCopyIn funcName (\c -> PQ.putCopyData c dat) pqconn
185− where
186− funcName = "Database.PostgreSQL.Simple.Copy.putCopyData"
187−
188−
189−-- | Completes a @COPY FROM STDIN@ query. Returns the number of rows
190−-- processed.
191−--
192−-- A connection must be in the @CopyIn@ state in order to call this
193−-- function, otherwise a 'SqlError' exception will result. The
194−-- connection's state changes back to ready after this function
195−-- is called.
196−
197−putCopyEnd :: Connection -> IO Int64
198−putCopyEnd conn = withConnection conn $ \pqconn -> do
199− doCopyIn funcName (\c -> PQ.putCopyEnd c Nothing) pqconn
200− getCopyCommandTag funcName pqconn
201− where
202− funcName = "Database.PostgreSQL.Simple.Copy.putCopyEnd"
203−
204−
205−-- | Aborts a @COPY FROM STDIN@ query. The string parameter is simply
206−-- an arbitrary error message that may show up in the PostgreSQL
207−-- server's log.
208−--
209−-- A connection must be in the @CopyIn@ state in order to call this
210−-- function, otherwise a 'SqlError' exception will result. The
211−-- connection's state changes back to ready after this function
212−-- is called.
213−
214−putCopyError :: Connection -> B.ByteString -> IO ()
215−putCopyError conn err = withConnection conn $ \pqconn -> do
216− doCopyIn funcName (\c -> PQ.putCopyEnd c (Just err)) pqconn
217− consumeResults pqconn
218− where
219− funcName = "Database.PostgreSQL.Simple.Copy.putCopyError"
220−
221−
222−doCopyIn :: B.ByteString -> (PQ.Connection -> IO PQ.CopyInResult)
223− -> PQ.Connection -> IO ()
224−doCopyIn funcName action = loop
225− where
226− loop pqconn = do
227− stat <- action pqconn
228− case stat of
229− PQ.CopyInOk -> return ()
230− PQ.CopyInError -> do
231− mmsg <- PQ.errorMessage pqconn
232− throwIO SqlError {
233− sqlState = "",
234− sqlExecStatus = FatalError,
235− sqlErrorMsg = maybe "" id mmsg,
236− sqlErrorDetail = "",
237− sqlErrorHint = funcName
238− }
239− PQ.CopyInWouldBlock -> do
240− mfd <- PQ.socket pqconn
241− case mfd of
242− Nothing -> throwIO (fdError funcName)
243− Just fd -> do
244− threadWaitWrite fd
245− loop pqconn
246−{-# INLINE doCopyIn #-}
247−
248−getCopyCommandTag :: B.ByteString -> PQ.Connection -> IO Int64
249−getCopyCommandTag funcName pqconn = do
250− result <- maybe (fail errCmdStatus) return =<< PQ.getResult pqconn
251− cmdStat <- maybe (fail errCmdStatus) return =<< PQ.cmdStatus result
252− consumeResults pqconn
253− let rowCount = P.string "COPY " *> (P.decimal <* P.endOfInput)
254− case P.parseOnly rowCount cmdStat of
255− Left _ -> do mmsg <- PQ.errorMessage pqconn
256− fail $ errCmdStatusFmt
257− ++ maybe "" (\msg -> "\nConnection error: "++B.unpack msg) mmsg
258− Right n -> return $! n
259− where
260− errCmdStatus = B.unpack funcName ++ ": failed to fetch command status"
261− errCmdStatusFmt = B.unpack funcName ++ ": failed to parse command status"
262−
263−
264−consumeResults :: PQ.Connection -> IO ()
265−consumeResults pqconn = do
266− mres <- PQ.getResult pqconn
267− case mres of
268− Nothing -> return ()
269− Just _ -> consumeResults pqconn
src/Database/PostgreSQL/Simple/Cursor.hsdeleted−98
@@ -1,98 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−
3−------------------------------------------------------------------------------
4−-- |
5−-- Module: Database.PostgreSQL.Simple.Cursor
6−-- Copyright: (c) 2011-2012 Leon P Smith
7−-- (c) 2017 Bardur Arantsson
8−-- License: BSD3
9−-- Maintainer: Leon P Smith <leon@melding-monads.com>
10−--
11−------------------------------------------------------------------------------
12−
13−module Database.PostgreSQL.Simple.Cursor
14− (
15− -- * Types
16− Cursor
17− -- * Cursor management
18− , declareCursor
19− , closeCursor
20− -- * Folding over rows from a cursor
21− , foldForward
22− , foldForwardWithParser
23− ) where
24−
25−import Data.ByteString.Builder (intDec)
26−import Control.Applicative ((<$>))
27−import Control.Exception as E
28−import Control.Monad (unless, void)
29−import Data.Monoid (mconcat)
30−import Database.PostgreSQL.Simple.Compat ((<>), toByteString)
31−import Database.PostgreSQL.Simple.FromRow (FromRow(..))
32−import Database.PostgreSQL.Simple.Types (Query(..))
33−import Database.PostgreSQL.Simple.Internal as Base hiding (result, row)
34−import Database.PostgreSQL.Simple.Internal.PQResultUtils
35−import Database.PostgreSQL.Simple.Transaction
36−import qualified Database.PostgreSQL.LibPQ as PQ
37−
38−-- | Cursor within a transaction.
39−data Cursor = Cursor !Query !Connection
40−
41−-- | Declare a temporary cursor. The cursor is given a
42−-- unique name for the given connection.
43−declareCursor :: Connection -> Query -> IO Cursor
44−declareCursor conn q = do
45− name <- newTempName conn
46− void $ execute_ conn $ mconcat ["DECLARE ", name, " NO SCROLL CURSOR FOR ", q]
47− return $ Cursor name conn
48−
49−-- | Close the given cursor.
50−closeCursor :: Cursor -> IO ()
51−closeCursor (Cursor name conn) =
52− (void $ execute_ conn ("CLOSE " <> name)) `E.catch` \ex ->
53− -- Don't throw exception if CLOSE failed because the transaction is
54− -- aborted. Otherwise, it will throw away the original error.
55− unless (isFailedTransactionError ex) $ throwIO ex
56−
57−-- | Fold over a chunk of rows from the given cursor, calling the
58−-- supplied fold-like function on each row as it is received. In case
59−-- the cursor is exhausted, a 'Left' value is returned, otherwise a
60−-- 'Right' value is returned.
61−foldForwardWithParser :: Cursor -> RowParser r -> Int -> (a -> r -> IO a) -> a -> IO (Either a a)
62−foldForwardWithParser (Cursor name conn) parser chunkSize f a0 = do
63− let q = "FETCH FORWARD "
64− <> (toByteString $ intDec chunkSize)
65− <> " FROM "
66− <> fromQuery name
67− result <- exec conn q
68− status <- PQ.resultStatus result
69− case status of
70− PQ.TuplesOk -> do
71− nrows <- PQ.ntuples result
72− ncols <- PQ.nfields result
73− if nrows > 0
74− then do
75− let inner a row = do
76− x <- getRowWith parser row ncols conn result
77− f a x
78− Right <$> foldM' inner a0 0 (nrows - 1)
79− else
80− return $ Left a0
81− _ -> throwResultError "foldForwardWithParser" result status
82−
83−-- | Fold over a chunk of rows, calling the supplied fold-like function
84−-- on each row as it is received. In case the cursor is exhausted,
85−-- a 'Left' value is returned, otherwise a 'Right' value is returned.
86−foldForward :: FromRow r => Cursor -> Int -> (a -> r -> IO a) -> a -> IO (Either a a)
87−foldForward cursor = foldForwardWithParser cursor fromRow
88−
89−
90−foldM' :: (Ord n, Num n) => (a -> n -> IO a) -> a -> n -> n -> IO a
91−foldM' f a lo hi = loop a lo
92− where
93− loop x !n
94− | n > hi = return x
95− | otherwise = do
96− x' <- f x n
97− loop x' (n+1)
98−{-# INLINE foldM' #-}
src/Database/PostgreSQL/Simple/Errors.hsdeleted−140
@@ -1,140 +0,0 @@
1−{-# LANGUAGE DeriveDataTypeable #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE RecordWildCards #-}
4−------------------------------------------------------------------------------
5−-- |
6−-- Module: Database.PostgreSQL.Simple.Errors
7−-- Copyright: (c) 2012-2013 Leonid Onokhov, Joey Adams
8−-- License: BSD3
9−-- Maintainer: Leon P Smith <leon@melding-monads.com>
10−-- Stability: experimental
11−--
12−-- | Module for parsing errors from postgresql error messages.
13−-- Currently only parses integrity violation errors (class 23).
14−--
15−-- /Note: Success of parsing may depend on language settings./
16−----------------------------------------------------------
17−module Database.PostgreSQL.Simple.Errors
18− ( ConstraintViolation(..)
19− , constraintViolation
20− , constraintViolationE
21− , catchViolation
22− , isSerializationError
23− , isNoActiveTransactionError
24− , isFailedTransactionError
25− )
26− where
27−
28−import Control.Exception as E
29−
30−import Data.Attoparsec.ByteString.Char8
31−import Data.ByteString (ByteString)
32−import Data.Typeable
33−
34−import Database.PostgreSQL.Simple.Internal
35−
36−-- Examples of parsed error messages
37−--
38−-- `ERROR: new row for relation "users" violates check
39−-- constraint "user_kind_check"`
40−--
41−-- `ERROR: insert or update on table "user_group_map" violates foreign key
42−-- constraint "user_id"`
43−--
44−-- `ERROR: null value in column "login" violates not-null constraint`
45−--
46−-- `ERROR: duplicate key value violates unique constraint "users_login_key"`
47−
48−data ConstraintViolation
49− = NotNullViolation ByteString
50− -- ^ The field is a column name
51− | ForeignKeyViolation ByteString ByteString
52− -- ^ Table name and name of violated constraint
53− | UniqueViolation ByteString
54− -- ^ Name of violated constraint
55− | CheckViolation ByteString ByteString
56− -- ^ Relation name (usually table), constraint name
57− | ExclusionViolation ByteString
58− -- ^ Name of the exclusion violation constraint
59− deriving (Show, Eq, Ord, Typeable)
60−
61−-- Default instance should be enough
62−instance Exception ConstraintViolation where
63− toException = postgresqlExceptionToException
64− fromException = postgresqlExceptionFromException
65−
66−
67−-- | Tries to convert 'SqlError' to 'ConstrainViolation', checks sqlState and
68−-- succeeds only if able to parse sqlErrorMsg.
69−--
70−-- > createUser = handleJust constraintViolation handler $ execute conn ...
71−-- > where
72−-- > handler (UniqueViolation "user_login_key") = ...
73−-- > handler _ = ...
74−constraintViolation :: SqlError -> Maybe ConstraintViolation
75−constraintViolation e =
76− case sqlState e of
77− "23502" -> NotNullViolation <$> parseMaybe parseQ1 msg
78− "23503" -> uncurry ForeignKeyViolation <$> parseMaybe parseQ2 msg
79− "23505" -> UniqueViolation <$> parseMaybe parseQ1 msg
80− "23514" -> uncurry CheckViolation <$> parseMaybe parseQ2 msg
81− "23P01" -> ExclusionViolation <$> parseMaybe parseQ1 msg
82− _ -> Nothing
83− where msg = sqlErrorMsg e
84−
85−
86−-- | Like constraintViolation, but also packs original SqlError.
87−--
88−-- > createUser = handleJust constraintViolationE handler $ execute conn ...
89−-- > where
90−-- > handler (_, UniqueViolation "user_login_key") = ...
91−-- > handler (e, _) = throwIO e
92−--
93−constraintViolationE :: SqlError -> Maybe (SqlError, ConstraintViolation)
94−constraintViolationE e = fmap ((,) e) $ constraintViolation e
95−
96−-- | Catches SqlError, tries to convert to ConstraintViolation, re-throws
97−-- on fail. Provides alternative interface to 'E.handleJust'
98−--
99−-- > createUser = catchViolation catcher $ execute conn ...
100−-- > where
101−-- > catcher _ (UniqueViolation "user_login_key") = ...
102−-- > catcher e _ = throwIO e
103−catchViolation :: (SqlError -> ConstraintViolation -> IO a) -> IO a -> IO a
104−catchViolation f m = E.catch m
105− (\e -> maybe (throwIO e) (f e) $ constraintViolation e)
106−
107−-- Parsers just try to extract quoted strings from error messages, number
108−-- of quoted strings depend on error type.
109−scanTillQuote :: Parser ByteString
110−scanTillQuote = scan False go
111− where go True _ = Just False -- escaped character
112− go False '"' = Nothing -- end parse
113− go False '\\' = Just True -- next one is escaped
114− go _ _ = Just False
115−
116−parseQ1 :: Parser ByteString
117−parseQ1 = scanTillQuote *> char '"' *> scanTillQuote <* char '"'
118−
119−parseQ2 :: Parser (ByteString, ByteString)
120−parseQ2 = (,) <$> parseQ1 <*> parseQ1
121−
122−parseMaybe :: Parser a -> ByteString -> Maybe a
123−parseMaybe p b = either (const Nothing) Just $ parseOnly p b
124−
125−------------------------------------------------------------------------
126−-- Error predicates
127−--
128−-- https://www.postgresql.org/docs/9.5/static/errcodes-appendix.html
129−
130−isSerializationError :: SqlError -> Bool
131−isSerializationError = isSqlState "40001"
132−
133−isNoActiveTransactionError :: SqlError -> Bool
134−isNoActiveTransactionError = isSqlState "25P01"
135−
136−isFailedTransactionError :: SqlError -> Bool
137−isFailedTransactionError = isSqlState "25P02"
138−
139−isSqlState :: ByteString -> SqlError -> Bool
140−isSqlState s SqlError{..} = sqlState == s
src/Database/PostgreSQL/Simple/Field.hsnew file+15
@@ -0,0 +1,15 @@
1+module Database.PostgreSQL.Simple.Field
2+ ( Field
3+ , typename
4+ , name
5+ , tableOid
6+ , tableColumn
7+ , format
8+ , typeOid
9+ , Oid
10+ , Format(..)
11+ , RawResult(..)
12+ ) where
13+
14+import Database.PostgreSQL.Simple.Internal
15+import Database.PostgreSQL.LibPQ (Format(..), Oid)
src/Database/PostgreSQL/Simple/FromField.hs+146−571
@@ -1,179 +1,79 @@
1−{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-}
2−{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
3−{-# LANGUAGE PatternGuards, ScopedTypeVariables #-}
4−{-# LANGUAGE RecordWildCards #-}
5−{-# LANGUAGE PolyKinds #-}
6−
7−{- |
8−Module: Database.PostgreSQL.Simple.FromField
9−Copyright: (c) 2011 MailRank, Inc.
10− (c) 2011-2013 Leon P Smith
11−License: BSD3
12−Maintainer: Leon P Smith <leon@melding-monads.com>
13−Stability: experimental
14−
15−The 'FromField' typeclass, for converting a single value in a row
16−returned by a SQL query into a more useful Haskell representation.
17−Note that each instance of 'FromField' is documented by a list of
18−compatible postgresql types.
19−
20−A Haskell numeric type is considered to be compatible with all
21−PostgreSQL numeric types that are less accurate than it. For instance,
22−the Haskell 'Double' type is compatible with the PostgreSQL's 32-bit
23−@int@ type because it can represent a @int@ exactly. On the other hand,
24−since a 'Double' might lose precision if representing PostgreSQL's 64-bit
25−@bigint@, the two are /not/ considered compatible.
26−
27−Note that the 'Float' and 'Double' instances use attoparsec's 'double'
28−conversion routine, which sacrifices some accuracy for speed. If you
29−need accuracy, consider first converting data to a 'Scientific' or 'Rational'
30−type, and then converting to a floating-point type. If you are defining
31−your own 'Database.PostgreSQL.Simple.FromRow.FromRow' instances, this can be
32−achieved simply by
33−@'fromRational' '<$>' 'Database.PostgreSQL.Simple.FromRow.field'@, although
34−this idiom is additionally compatible with PostgreSQL's @int8@ and @numeric@
35−types. If this is unacceptable, you may find
36−'Database.PostgreSQL.Simple.FromRow.fieldWith' useful.
37−
38−Also note that while converting to a 'Double' through the 'Scientific' type
39−is likely somewhat faster than converting through the 'Rational' type,
40−the 'Scientific' type has no way to represent @NaN@ and @±Infinity@ values.
41−Thus, if you need precision conversion of regular floating point values
42−and the possibility of receiving these special values from the backend,
43−stick with 'Rational'.
44−
45−Because 'FromField' is a typeclass, one may provide conversions to
46−additional Haskell types without modifying postgresql-simple. This is
47−particularly useful for supporting PostgreSQL types that postgresql-simple
48−does not support out-of-box. Here's an example of what such an instance
49−might look like for a UUID type that implements the @Read@ class:
50−
51−@
52−import Data.UUID ( UUID )
53−import Database.PostgreSQL.Simple.FromField
54− ( FromField (fromField) , typeOid, returnError, ResultError (..) )
55−import Database.PostgreSQL.Simple.TypeInfo.Static (typoid, uuid)
56−import qualified Data.ByteString.Char8 as B
57−
58−instance FromField UUID where
59− fromField f mdata =
60− if typeOid f /= typoid uuid
61− then returnError Incompatible f \"\"
62− else case B.unpack \`fmap\` mdata of
63− Nothing -> returnError UnexpectedNull f \"\"
64− Just dat ->
65− case [ x | (x,t) <- reads dat, (\"\",\"\") <- lex t ] of
66− [x] -> return x
67− _ -> returnError ConversionFailed f dat
68−@
69−
70−Note that because PostgreSQL's @uuid@ type is built into postgres and is
71−not provided by an extension, the 'typeOid' of @uuid@ does not change and
72−thus we can examine it directly. One could hard-code the type oid, or
73−obtain it by other means, but in this case we simply pull it out of the
74−static table provided by postgresql-simple.
75−
76−On the other hand if the type is provided by an extension, such as
77−@PostGIS@ or @hstore@, then the 'typeOid' is not stable and can vary from
78−database to database. In this case it is recommended that FromField
79−instances use 'typename' instead.
80−
81−-}
82−
1+{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, FlexibleInstances #-}
2+{-# LANGUAGE PatternGuards, ScopedTypeVariables, OverloadedStrings #-}
3+------------------------------------------------------------------------------
4+-- |
5+-- Module: Database.PostgreSQL.Simple.FromField
6+-- Copyright: (c) 2011 MailRank, Inc.
7+-- (c) 2011 Leon P Smith
8+-- License: BSD3
9+-- Maintainer: Leon P Smith <leon@melding-monads.com>
10+-- Stability: experimental
11+-- Portability: portable
12+--
13+-- The 'Result' typeclass, for converting a single value in a row
14+-- returned by a SQL query into a more useful Haskell representation.
15+--
16+-- A Haskell numeric type is considered to be compatible with all
17+-- PostgreSQL numeric types that are less accurate than it. For instance,
18+-- the Haskell 'Double' type is compatible with the PostgreSQL's 32-bit
19+-- @Int@ type because it can represent a @Int@ exactly. On the other hand,
20+-- since a 'Double' might lose precision if representing a 64-bit @BigInt@,
21+-- the two are /not/ considered compatible.
22+--
23+------------------------------------------------------------------------------
8324
8425module Database.PostgreSQL.Simple.FromField
8526 (
8627 FromField(..)
87− , FieldParser
88− , Conversion()
89−
90− , runConversion
91− , conversionMap
92− , conversionError
9328 , ResultError(..)
9429 , returnError
95−
96− , Field
97− , typename
98− , TypeInfo(..)
99− , Attribute(..)
100− , typeInfo
101− , typeInfoByOid
102− , name
103− , tableOid
104− , tableColumn
105− , format
106− , typeOid
107− , PQ.Oid(..)
108− , PQ.Format(..)
109− , pgArrayFieldParser
110− , attoFieldParser
111−
112− , optionalField
113− , fromJSONField
114− , fromFieldJSONByteString
11530 ) where
11631
11732#include "MachDeps.h"
11833
119−import Control.Applicative ( Const(Const), (<|>), (<$>), pure, (*>), (<*) )
120−import Control.Concurrent.MVar (MVar, newMVar)
121−import Control.Exception (Exception (toException, fromException))
122−import qualified Data.Aeson as JSON
123−import Data.Attoparsec.ByteString.Char8 hiding (Result)
124−import Data.ByteString (ByteString)
34+import Control.Applicative (Applicative, (<|>), (<$>), (<*>), (<*), pure)
35+import Control.Exception (SomeException(..), Exception, throw)
36+import Data.Attoparsec.Char8 hiding (Result)
37+import Data.Bits ((.&.), (.|.), shiftL)
38+import Data.ByteString (ByteString)
12539import qualified Data.ByteString.Char8 as B
126−import Data.Functor.Identity (Identity(Identity))
127−import Data.Int (Int16, Int32, Int64)
128−import Data.IORef (IORef, newIORef)
129−import Data.Ratio (Ratio)
130−import Data.Time.Compat ( UTCTime, ZonedTime, LocalTime, Day, TimeOfDay, CalendarDiffTime )
131−import Data.Typeable (Typeable, typeOf)
132−import Data.Vector (Vector)
133−import Data.Vector.Mutable (IOVector)
134−import qualified Data.Vector as V
135−import Database.PostgreSQL.Simple.Internal
136−import Database.PostgreSQL.Simple.Compat
137−import Database.PostgreSQL.Simple.Ok
138−import Database.PostgreSQL.Simple.Types
139−import Database.PostgreSQL.Simple.TypeInfo as TI
140−import qualified Database.PostgreSQL.Simple.TypeInfo.Static as TI
141−import Database.PostgreSQL.Simple.Time
142−import Database.PostgreSQL.Simple.Arrays as Arrays
40+import Data.Int (Int16, Int32, Int64)
41+import Data.List (foldl')
42+import Data.Ratio (Ratio)
43+import Data.Time.Calendar (Day, fromGregorian)
44+import Data.Time.Clock (UTCTime)
45+import Data.Time.Format (parseTime)
46+import Data.Time.LocalTime (TimeOfDay, makeTimeOfDayValid)
47+import Data.Typeable (TypeRep, Typeable, typeOf)
48+import Data.Word (Word64)
49+import Database.PostgreSQL.Simple.Internal
50+import Database.PostgreSQL.Simple.Field (Field(..), RawResult(..))
51+import Database.PostgreSQL.Simple.BuiltinTypes
52+import Database.PostgreSQL.Simple.Ok
53+import Database.PostgreSQL.Simple.Types (Binary(..), Null(..))
14354import qualified Database.PostgreSQL.LibPQ as PQ
55+import System.IO.Unsafe (unsafePerformIO)
56+import System.Locale (defaultTimeLocale)
14457import qualified Data.ByteString as SB
14558import qualified Data.ByteString.Char8 as B8
14659import qualified Data.ByteString.Lazy as LB
14760import qualified Data.Text as ST
14861import qualified Data.Text.Encoding as ST
62+import qualified Data.Text.Encoding.Error (UnicodeException)
14963import qualified Data.Text.Lazy as LT
150−import Data.CaseInsensitive (CI)
151−import qualified Data.CaseInsensitive as CI
152−import Data.UUID.Types (UUID)
153−import qualified Data.UUID.Types as UUID
154−import Data.Scientific (Scientific)
155−import GHC.Real (infinity, notANumber)
156−
157−import qualified Data.Aeson.Types as JSON
15864
15965-- | Exception thrown if conversion from a SQL value to a Haskell
16066-- value fails.
16167data ResultError = Incompatible { errSQLType :: String
162− , errSQLTableOid :: Maybe PQ.Oid
163− , errSQLField :: String
16468 , errHaskellType :: String
16569 , errMessage :: String }
16670 -- ^ The SQL and Haskell types are not compatible.
16771 | UnexpectedNull { errSQLType :: String
168− , errSQLTableOid :: Maybe PQ.Oid
169− , errSQLField :: String
17072 , errHaskellType :: String
17173 , errMessage :: String }
17274 -- ^ A SQL @NULL@ was encountered when the Haskell
17375 -- type did not permit it.
17476 | ConversionFailed { errSQLType :: String
175− , errSQLTableOid :: Maybe PQ.Oid
176− , errSQLField :: String
17777 , errHaskellType :: String
17878 , errMessage :: String }
17979 -- ^ The SQL value could not be parsed, or could not
@@ -182,489 +82,167 @@ data ResultError = Incompatible { errSQLType :: String
18282 -- between metadata and actual data in a row).
18383 deriving (Eq, Show, Typeable)
18484
185−instance Exception ResultError where
186− toException = postgresqlExceptionToException
187− fromException = postgresqlExceptionFromException
188−
189−left :: Exception a => a -> Conversion b
190−left = conversionError
85+instance Exception ResultError
19186
192−type FieldParser a = Field -> Maybe ByteString -> Conversion a
87+left :: Exception a => a -> Ok b
88+left = Errors . (:[]) . SomeException
19389
19490-- | A type that may be converted from a SQL type.
19591class FromField a where
196− fromField :: FieldParser a
92+ fromField :: Field -> Maybe ByteString -> Ok a
19793 -- ^ Convert a SQL value to a Haskell value.
19894 --
199− -- Returns a list of exceptions if the conversion fails. In the case of
200− -- library instances, this will usually be a single 'ResultError', but
201− -- may be a 'UnicodeException'.
202− --
203− -- Note that retaining any reference to the 'Field' argument causes
204− -- the entire @LibPQ.'PQ.Result'@ to be retained. Thus, implementations
205− -- of 'fromField' should return results that do not refer to this value
206− -- after the result have been evaluated to WHNF.
207− --
208− -- Note that as of @postgresql-simple-0.4.0.0@, the 'ByteString' value
209− -- has already been copied out of the @LibPQ.'PQ.Result'@ before it has
210− -- been passed to 'fromField'. This is because for short strings, it's
211− -- cheaper to copy the string than to set up a finalizer.
212−
213−-- | Returns the data type name. This is the preferred way of identifying
214−-- types that do not have a stable type oid, such as types provided by
215−-- extensions to PostgreSQL.
216−--
217−-- More concretely, it returns the @typname@ column associated with the
218−-- type oid in the @pg_type@ table. First, postgresql-simple will check
219−-- the built-in, static table. If the type oid is not there,
220−-- postgresql-simple will check a per-connection cache, and then
221−-- finally query the database's meta-schema.
222−
223−typename :: Field -> Conversion ByteString
224−typename field = typname <$> typeInfo field
225−
226−typeInfo :: Field -> Conversion TypeInfo
227−typeInfo Field{..} = Conversion $ \conn -> do
228− Ok <$> (getTypeInfo conn typeOid)
229−
230−typeInfoByOid :: PQ.Oid -> Conversion TypeInfo
231−typeInfoByOid oid = Conversion $ \conn -> do
232− Ok <$> (getTypeInfo conn oid)
233−
234−-- | Returns the name of the column. This is often determined by a table
235−-- definition, but it can be set using an @as@ clause.
95+ -- Returns an exception if the conversion fails. In the case of
96+ -- library instances, this will usually be a 'ResultError', but may
97+ -- be a 'UnicodeException'.
23698
237−name :: Field -> Maybe ByteString
238−name Field{..} = unsafeDupablePerformIO (PQ.fname result column)
99+instance (FromField a) => FromField (Maybe a) where
100+ fromField _ Nothing = pure Nothing
101+ fromField f bs = Just <$> fromField f bs
239102
240−-- | Returns the name of the object id of the @table@ associated with the
241−-- column, if any. Returns 'Nothing' when there is no such table;
242−-- for example a computed column does not have a table associated with it.
243−-- Analogous to libpq's @PQftable@.
244−
245−tableOid :: Field -> Maybe PQ.Oid
246−tableOid Field{..} = toMaybeOid (unsafeDupablePerformIO (PQ.ftable result column))
247− where
248− toMaybeOid x
249− = if x == PQ.invalidOid
250− then Nothing
251− else Just x
252−
253−-- | If the column has a table associated with it, this returns the
254−-- number of the associated table column. Table columns have
255−-- nonzero numbers. Zero is returned if the specified column is not
256−-- a simple reference to a table column, or when using pre-3.0
257−-- protocol. Analogous to libpq's @PQftablecol@.
258−
259−tableColumn :: Field -> Int
260−tableColumn Field{..} = fromCol (unsafeDupablePerformIO (PQ.ftablecol result column))
261− where
262− fromCol (PQ.Col x) = fromIntegral x
263−
264−-- | This returns whether the data was returned in a binary or textual format.
265−-- Analogous to libpq's @PQfformat@.
266−
267−format :: Field -> PQ.Format
268−format Field{..} = unsafeDupablePerformIO (PQ.fformat result column)
269−
270−-- | void
271−instance FromField () where
272− fromField f _bs
273− | typeOid f /= TI.voidOid = returnError Incompatible f ""
274− | otherwise = pure ()
275−
276−instance (FromField a) => FromField (Const a b) where
277− fromField f bs = Const <$> fromField f bs
278−
279−instance (FromField a) => FromField (Identity a) where
280− fromField f bs = Identity <$> fromField f bs
281−
282−-- | For dealing with null values. Compatible with any postgresql type
283−-- compatible with type @a@. Note that the type is not checked if
284−-- the value is null, although it is inadvisable to rely on this
285−-- behavior.
286−instance FromField a => FromField (Maybe a) where
287− fromField = optionalField fromField
288−
289−-- | For dealing with SQL @null@ values outside of the 'FromField' class.
290−-- Alternatively, one could use 'Control.Applicative.optional', but that
291−-- also turns type and conversion errors into 'Nothing', whereas this is
292−-- more specific and turns only @null@ values into 'Nothing'.
293−
294−optionalField :: FieldParser a -> FieldParser (Maybe a)
295−optionalField p f mv =
296− case mv of
297− Nothing -> pure Nothing
298− Just _ -> Just <$> p f mv
299−{-# INLINE optionalField #-}
300−
301−-- | compatible with any data type, but the value must be null
302103instance FromField Null where
303104 fromField _ Nothing = pure Null
304105 fromField f (Just _) = returnError ConversionFailed f "data is not null"
305106
306−-- | bool
307107instance FromField Bool where
308108 fromField f bs
309− | typeOid f /= TI.boolOid = returnError Incompatible f ""
109+ | typeOid f /= builtin2oid Bool = returnError Incompatible f ""
310110 | bs == Nothing = returnError UnexpectedNull f ""
311111 | bs == Just "t" = pure True
312112 | bs == Just "f" = pure False
313113 | otherwise = returnError ConversionFailed f ""
314114
315−-- | \"char\", bpchar
316−instance FromField Char where
317− fromField f bs0 =
318− if (eq TI.charOid \/ eq TI.bpcharOid) (typeOid f)
319− then case bs0 of
320− Nothing -> returnError UnexpectedNull f ""
321− Just bs -> if B.length bs /= 1
322− then returnError ConversionFailed f "length not 1"
323− else return $! (B.head bs)
324− else returnError Incompatible f ""
325−
326−-- | int2
327115instance FromField Int16 where
328− fromField = attoFieldParser ok16 $ signed decimal
116+ fromField = atto ok16 $ signed decimal
329117
330−-- | int2, int4
331118instance FromField Int32 where
332− fromField = attoFieldParser ok32 $ signed decimal
119+ fromField = atto ok32 $ signed decimal
333120
334−#if WORD_SIZE_IN_BITS < 64
335−-- | int2, int4, and if compiled as 64-bit code, int8 as well.
336−-- This library was compiled as 32-bit code.
337−#else
338−-- | int2, int4, and if compiled as 64-bit code, int8 as well.
339−-- This library was compiled as 64-bit code.
340−#endif
341121instance FromField Int where
342− fromField = attoFieldParser okInt $ signed decimal
122+ fromField = atto okInt $ signed decimal
343123
344−-- | int2, int4, int8
345124instance FromField Int64 where
346− fromField = attoFieldParser ok64 $ signed decimal
125+ fromField = atto ok64 $ signed decimal
347126
348−-- | int2, int4, int8
349127instance FromField Integer where
350− fromField = attoFieldParser ok64 $ signed decimal
128+ fromField = atto ok64 $ signed decimal
351129
352−-- | int2, float4 (Uses attoparsec's 'double' routine, for
353−-- better accuracy convert to 'Scientific' or 'Rational' first)
354130instance FromField Float where
355− fromField = attoFieldParser ok (realToFrac <$> pg_double)
356− where ok = eq TI.float4Oid \/ eq TI.int2Oid
131+ fromField = atto ok (realToFrac <$> double)
132+ where ok = mkCompats [Float4,Int2]
357133
358−-- | int2, int4, float4, float8 (Uses attoparsec's 'double' routine, for
359−-- better accuracy convert to 'Scientific' or 'Rational' first)
360134instance FromField Double where
361− fromField = attoFieldParser ok pg_double
362− where ok = eq TI.float4Oid \/ eq TI.float8Oid \/ eq TI.int2Oid \/ eq TI.int4Oid
135+ fromField = atto ok double
136+ where ok = mkCompats [Float4,Float8,Int2,Int4]
363137
364−-- | int2, int4, int8, float4, float8, numeric
365138instance FromField (Ratio Integer) where
366− fromField = attoFieldParser ok pg_rational
367− where ok = eq TI.float4Oid \/ eq TI.float8Oid \/ eq TI.int2Oid \/ eq TI.int4Oid \/ eq TI.int8Oid \/ eq TI.numericOid
139+ fromField = atto ok rational
140+ where ok = mkCompats [Float4,Float8,Int2,Int4,Numeric]
368141
369−-- | int2, int4, int8, float4, float8, numeric
370−instance FromField Scientific where
371− fromField = attoFieldParser ok rational
372− where ok = eq TI.float4Oid \/ eq TI.float8Oid \/ eq TI.int2Oid \/ eq TI.int4Oid \/ eq TI.int8Oid \/ eq TI.numericOid
373−
374−unBinary :: Binary t -> t
375142unBinary (Binary x) = x
376143
377−pg_double :: Parser Double
378−pg_double
379− = (string "NaN" *> pure ( 0 / 0))
380− <|> (string "Infinity" *> pure ( 1 / 0))
381− <|> (string "-Infinity" *> pure (-1 / 0))
382− <|> double
383−
384−pg_rational :: Parser Rational
385−pg_rational
386− = (string "NaN" *> pure notANumber )
387− <|> (string "Infinity" *> pure infinity )
388− <|> (string "-Infinity" *> pure (-infinity))
389− <|> rational
390−
391−-- | bytea, name, text, \"char\", bpchar, varchar, unknown
392144instance FromField SB.ByteString where
393− fromField f dat = if typeOid f == TI.byteaOid
145+ fromField f dat = if typeOid f == builtin2oid Bytea
394146 then unBinary <$> fromField f dat
395− else doFromField f okText' pure dat
147+ else doFromField f okText' (pure . B.copy) dat
396148
397−-- | oid
398149instance FromField PQ.Oid where
399− fromField f dat = PQ.Oid <$> attoFieldParser (== TI.oidOid) decimal f dat
150+ fromField f dat = PQ.Oid <$> atto (mkCompat Oid) decimal f dat
400151
401−-- | bytea, name, text, \"char\", bpchar, varchar, unknown
402152instance FromField LB.ByteString where
403153 fromField f dat = LB.fromChunks . (:[]) <$> fromField f dat
404154
405155unescapeBytea :: Field -> SB.ByteString
406− -> Conversion (Binary SB.ByteString)
407−unescapeBytea f str' = case unsafeDupablePerformIO (PQ.unescapeBytea str') of
156+ -> Ok (Binary SB.ByteString)
157+unescapeBytea f str = case unsafePerformIO (PQ.unescapeBytea str) of
408158 Nothing -> returnError ConversionFailed f "unescapeBytea failed"
409159 Just str -> pure (Binary str)
410160
411−-- | bytea
412161instance FromField (Binary SB.ByteString) where
413162 fromField f dat = case format f of
414163 PQ.Text -> doFromField f okBinary (unescapeBytea f) dat
415− PQ.Binary -> doFromField f okBinary (pure . Binary) dat
164+ PQ.Binary -> doFromField f okBinary (pure . Binary . B.copy) dat
416165
417−-- | bytea
418166instance FromField (Binary LB.ByteString) where
419167 fromField f dat = Binary . LB.fromChunks . (:[]) . unBinary <$> fromField f dat
420168
421−-- | name, text, \"char\", bpchar, varchar
422169instance FromField ST.Text where
423170 fromField f = doFromField f okText $ (either left pure . ST.decodeUtf8')
424171 -- FIXME: check character encoding
425172
426−-- | name, text, \"char\", bpchar, varchar
427173instance FromField LT.Text where
428174 fromField f dat = LT.fromStrict <$> fromField f dat
429175
430−-- | citext
431−instance FromField (CI ST.Text) where
432− fromField f mdat = do
433− typ <- typename f
434− if typ /= "citext"
435− then returnError Incompatible f ""
436− else case mdat of
437− Nothing -> returnError UnexpectedNull f ""
438− Just dat -> either left (pure . CI.mk)
439− (ST.decodeUtf8' dat)
440−
441−-- | citext
442−instance FromField (CI LT.Text) where
443− fromField f mdat = do
444− typ <- typename f
445− if typ /= "citext"
446− then returnError Incompatible f ""
447− else case mdat of
448− Nothing -> returnError UnexpectedNull f ""
449− Just dat -> either left (pure . CI.mk . LT.fromStrict)
450− (ST.decodeUtf8' dat)
451−
452−-- | name, text, \"char\", bpchar, varchar
453176instance FromField [Char] where
454177 fromField f dat = ST.unpack <$> fromField f dat
455178
456−-- | timestamptz
457179instance FromField UTCTime where
458− fromField = ff TI.timestamptzOid "UTCTime" parseUTCTime
459−
460−-- | timestamptz
461−instance FromField ZonedTime where
462− fromField = ff TI.timestamptzOid "ZonedTime" parseZonedTime
180+ fromField f =
181+ case oid2builtin (typeOid f) of
182+ Just Timestamp -> doIt "%F %T%Q" id
183+ Just TimestampWithTimeZone -> doIt "%F %T%Q%z" (++ "00")
184+ _ -> const $ returnError Incompatible f "types incompatible"
185+ where
186+ doIt _ _ Nothing = returnError UnexpectedNull f ""
187+ doIt fmt preprocess (Just bs) =
188+ case parseTime defaultTimeLocale fmt str of
189+ Just t -> pure t
190+ Nothing -> returnError ConversionFailed f "could not parse"
191+ where str = preprocess (B8.unpack bs)
463192
464−-- | timestamp
465−instance FromField LocalTime where
466− fromField = ff TI.timestampOid "LocalTime" parseLocalTime
467−
468−-- | date
469193instance FromField Day where
470− fromField = ff TI.dateOid "Day" parseDay
194+ fromField f = atto ok date f
195+ where ok = mkCompats [Date]
196+ date = fromGregorian <$> (decimal <* char '-')
197+ <*> (decimal <* char '-')
198+ <*> decimal
471199
472−-- | time
473200instance FromField TimeOfDay where
474− fromField = ff TI.timeOid "TimeOfDay" parseTimeOfDay
201+ fromField f = atto' ok time f
202+ where ok = mkCompats [Time]
203+ time = do
204+ hours <- decimal <* char ':'
205+ mins <- decimal <* char ':'
206+ secs <- decimal :: Parser Int
207+ case makeTimeOfDayValid hours mins (fromIntegral secs) of
208+ Just t -> return (pure t)
209+ _ -> return (returnError ConversionFailed f "could not parse")
475210
476−-- | timestamptz
477−instance FromField UTCTimestamp where
478− fromField = ff TI.timestamptzOid "UTCTimestamp" parseUTCTimestamp
211+instance (FromField a, FromField b) => FromField (Either a b) where
212+ fromField f dat = (Right <$> fromField f dat)
213+ <|> (Left <$> fromField f dat)
479214
480−-- | timestamptz
481−instance FromField ZonedTimestamp where
482− fromField = ff TI.timestamptzOid "ZonedTimestamp" parseZonedTimestamp
215+newtype Compat = Compat Word64
483216
484−-- | timestamp
485−instance FromField LocalTimestamp where
486− fromField = ff TI.timestampOid "LocalTimestamp" parseLocalTimestamp
217+mkCompats :: [BuiltinType] -> Compat
218+mkCompats = foldl' f (Compat 0) . map mkCompat
219+ where f (Compat a) (Compat b) = Compat (a .|. b)
487220
488−-- | date
489−instance FromField Date where
490− fromField = ff TI.dateOid "Date" parseDate
221+mkCompat :: BuiltinType -> Compat
222+mkCompat = Compat . shiftL 1 . fromEnum
491223
492−-- | interval. Requires you to configure intervalstyle as @iso_8601@.
493−--
494−-- You can configure intervalstyle on every connection with a @SET@ command,
495−-- but for better performance you may want to configure it permanently in the
496−-- file found with @SHOW config_file;@ .
497−--
498−instance FromField CalendarDiffTime where
499− fromField = ff TI.intervalOid "CalendarDiffTime" parseCalendarDiffTime
500−
501−ff :: PQ.Oid -> String -> (B8.ByteString -> Either String a)
502− -> Field -> Maybe B8.ByteString -> Conversion a
503−ff compatOid hsType parseBS f mstr =
504− if typeOid f /= compatOid
505− then err Incompatible ""
506− else case mstr of
507− Nothing -> err UnexpectedNull ""
508− Just str -> case parseBS str of
509− Left msg -> err ConversionFailed msg
510− Right val -> return val
511− where
512− err errC msg = do
513− typnam <- typename f
514− left $ errC (B8.unpack typnam)
515− (tableOid f)
516− (maybe "" B8.unpack (name f))
517− hsType
518− msg
519−{-# INLINE ff #-}
520−
521−-- | Compatible with both types. Conversions to type @b@ are
522−-- preferred, the conversion to type @a@ will be tried after
523−-- the 'Right' conversion fails.
524−instance (FromField a, FromField b) => FromField (Either a b) where
525− fromField f dat = (Right <$> fromField f dat)
526− <|> (Left <$> fromField f dat)
224+compat :: Compat -> Compat -> Bool
225+compat (Compat a) (Compat b) = a .&. b /= 0
527226
528−-- | any postgresql array whose elements are compatible with type @a@
529−instance (FromField a, Typeable a) => FromField (PGArray a) where
530− fromField = pgArrayFieldParser fromField
531−
532−pgArrayFieldParser :: Typeable a => FieldParser a -> FieldParser (PGArray a)
533−pgArrayFieldParser fieldParser f mdat = do
534− info <- typeInfo f
535− case info of
536− TI.Array{} ->
537− case mdat of
538− Nothing -> returnError UnexpectedNull f ""
539− Just dat -> do
540− case parseOnly (fromArray fieldParser info f) dat of
541− Left err -> returnError ConversionFailed f err
542− Right conv -> PGArray <$> conv
543− _ -> returnError Incompatible f ""
544−
545−fromArray :: FieldParser a -> TypeInfo -> Field -> Parser (Conversion [a])
546−fromArray fieldParser typInfo f = sequence . (parseIt <$>) <$> array delim
547− where
548− delim = typdelim (typelem typInfo)
549− fElem = f{ typeOid = typoid (typelem typInfo) }
550−
551− parseIt item =
552− fieldParser f' $ if item == Arrays.Plain "NULL" then Nothing else Just item'
553− where
554− item' = fmt delim item
555− f' | Arrays.Array _ <- item = f
556− | otherwise = fElem
557−
558−instance (FromField a, Typeable a) => FromField (Vector a) where
559− fromField f v = V.fromList . fromPGArray <$> fromField f v
560−
561−instance (FromField a, Typeable a) => FromField (IOVector a) where
562− fromField f v = liftConversion . V.unsafeThaw =<< fromField f v
563−
564−-- | uuid
565−instance FromField UUID where
566− fromField f mbs =
567− if typeOid f /= TI.uuidOid
568− then returnError Incompatible f ""
569− else case mbs of
570− Nothing -> returnError UnexpectedNull f ""
571− Just bs ->
572− case UUID.fromASCIIBytes bs of
573− Nothing -> returnError ConversionFailed f "Invalid UUID"
574− Just uuid -> pure uuid
575−
576−-- | json, jsonb
577−instance FromField JSON.Value where
578− fromField f mbs = parseBS =<< fromFieldJSONByteString f mbs
579− where parseBS bs = case JSON.eitherDecodeStrict' bs of
580− Left err -> returnError ConversionFailed f err
581− Right val -> pure val
582−
583−-- | Return the JSON ByteString directly
584−--
585−-- @since 0.6.3
586−fromFieldJSONByteString :: Field -> Maybe ByteString -> Conversion ByteString
587−fromFieldJSONByteString f mbs =
588− if typeOid f /= TI.jsonOid && typeOid f /= TI.jsonbOid
589− then returnError Incompatible f ""
590− else case mbs of
591− Nothing -> returnError UnexpectedNull f ""
592− Just bs -> pure bs
593−
594−-- | Parse a field to a JSON 'JSON.Value' and convert that into a
595−-- Haskell value using the 'JSON.FromJSON' instance.
596−--
597−-- This can be used as the default implementation for the 'fromField'
598−-- method for Haskell types that have a JSON representation in
599−-- PostgreSQL.
600−--
601−-- The 'Typeable' constraint is required to show more informative
602−-- error messages when parsing fails.
603−--
604−-- Note that @fromJSONField :: FieldParser ('Maybe' Foo)@ will return
605−-- @'Nothing'@ on the json @null@ value, and return an exception on SQL @null@
606−-- value. Alternatively, one could write @'optionalField' fromJSONField@
607−-- that will return @Nothing@ on SQL @null@, and otherwise will call
608−-- @fromJSONField :: FieldParser Foo@ and then return @'Just'@ the
609−-- result value, or return its exception. If one would
610−-- like to return @Nothing@ on both the SQL @null@ and json @null@ values,
611−-- one way to do it would be to write
612−-- @\\f mv -> 'Control.Monad.join' '<$>' optionalField fromJSONField f mv@
613−fromJSONField :: (JSON.FromJSON a, Typeable a) => FieldParser a
614−fromJSONField f mbBs = do
615− value <- fromField f mbBs
616− case JSON.ifromJSON value of
617− JSON.IError path err -> returnError ConversionFailed f $
618− "JSON decoding error: " ++ (JSON.formatError path err)
619− JSON.ISuccess x -> pure x
620−
621−-- | Compatible with the same set of types as @a@. Note that
622−-- modifying the 'IORef' does not have any effects outside
623−-- the local process on the local machine.
624−instance FromField a => FromField (IORef a) where
625− fromField f v = liftConversion . newIORef =<< fromField f v
626−
627−-- | Compatible with the same set of types as @a@. Note that
628−-- modifying the 'MVar' does not have any effects outside
629−-- the local process on the local machine.
630−instance FromField a => FromField (MVar a) where
631− fromField f v = liftConversion . newMVar =<< fromField f v
632−
633−type Compat = PQ.Oid -> Bool
634−
635−okText, okText', okBinary, ok16, ok32, ok64, okInt :: Compat
636−okText = eq TI.nameOid \/ eq TI.textOid \/ eq TI.charOid
637− \/ eq TI.bpcharOid \/ eq TI.varcharOid
638−okText' = eq TI.nameOid \/ eq TI.textOid \/ eq TI.charOid
639− \/ eq TI.bpcharOid \/ eq TI.varcharOid \/ eq TI.unknownOid
640−okBinary = eq TI.byteaOid
641−ok16 = eq TI.int2Oid
642−ok32 = eq TI.int2Oid \/ eq TI.int4Oid
643−ok64 = eq TI.int2Oid \/ eq TI.int4Oid \/ eq TI.int8Oid
227+okText, okText', ok16, ok32, ok64 :: Compat
228+okText = mkCompats [Name,Text,Char,Bpchar,Varchar]
229+okText' = mkCompats [Name,Text,Char,Bpchar,Varchar,Unknown]
230+okBinary = mkCompats [Bytea]
231+ok16 = mkCompats [Int2]
232+ok32 = mkCompats [Int2,Int4]
233+ok64 = mkCompats [Int2,Int4,Int8]
644234#if WORD_SIZE_IN_BITS < 64
645235okInt = ok32
646236#else
647237okInt = ok64
648238#endif
649239
650−-- | eq and \/ are used to imlement what Macro stuff did,
651−-- i.e. mkCompats and inlineTypoid
652−eq :: PQ.Oid -> PQ.Oid -> Bool
653−eq = (==)
654−{-# INLINE eq #-}
655−
656−infixr 2 \/
657−(\/) :: (PQ.Oid -> Bool)
658− -> (PQ.Oid -> Bool)
659− -> (PQ.Oid -> Bool)
660−f \/ g = \x -> f x || g x
661−{-# INLINE (\/) #-}
662−
663240doFromField :: forall a . (Typeable a)
664− => Field -> Compat -> (ByteString -> Conversion a)
665− -> Maybe ByteString -> Conversion a
666−doFromField f isCompat cvt (Just bs)
667− | isCompat (typeOid f) = cvt bs
241+ => Field -> Compat -> (ByteString -> Ok a)
242+ -> Maybe ByteString -> Ok a
243+doFromField f types cvt (Just bs)
244+ | Just typ <- oid2builtin (typeOid f)
245+ , mkCompat typ `compat` types = cvt bs
668246 | otherwise = returnError Incompatible f "types incompatible"
669247doFromField f _ _ _ = returnError UnexpectedNull f ""
670248
@@ -674,35 +252,32 @@ doFromField f _ _ _ = returnError UnexpectedNull f ""
674252-- exception value and returns it in a 'Left . SomeException'
675253-- constructor.
676254returnError :: forall a err . (Typeable a, Exception err)
677− => (String -> Maybe PQ.Oid -> String -> String -> String -> err)
678− -> Field -> String -> Conversion a
679−returnError mkErr f msg = do
680− typnam <- typename f
681− left $ mkErr (B.unpack typnam)
682− (tableOid f)
683− (maybe "" B.unpack (name f))
684− (show (typeOf (undefined :: a)))
685− msg
686−
687−-- | Construct a field parser from an attoparsec parser. An 'Incompatible' error is thrown if the
688−-- PostgreSQL oid does not match the specified predicate.
689−--
690−-- @
691−-- instance FromField Int16 where
692−-- fromField = attoFieldParser ok16 (signed decimal)
693−-- @
694−--
695−-- @since 0.6.3
696−attoFieldParser :: forall a. (Typeable a)
697− => (PQ.Oid -> Bool)
698− -- ^ Predicate for whether the postgresql type oid is compatible with this parser
699− -> Parser a
700− -- ^ An attoparsec parser.
701− -> FieldParser a
702−attoFieldParser types p0 f dat = doFromField f types (go p0) dat
255+ => (String -> String -> String -> err)
256+ -> Field -> String -> Ok a
257+returnError mkErr f = left . mkErr (B.unpack (typename f))
258+ (show (typeOf (undefined :: a)))
259+
260+atto :: forall a. (Typeable a)
261+ => Compat -> Parser a -> Field -> Maybe ByteString
262+ -> Ok a
263+atto types p0 f dat = doFromField f types (go p0) dat
703264 where
704− go :: Parser a -> ByteString -> Conversion a
265+ go :: Parser a -> ByteString -> Ok a
705266 go p s =
706267 case parseOnly p s of
707268 Left err -> returnError ConversionFailed f err
708269 Right v -> pure v
270+
271+atto' :: forall a. (Typeable a)
272+ => Compat -> Parser (Ok a) -> Field -> Maybe ByteString
273+ -> Ok a
274+atto' types p0 f dat = doFromField f types (go p0) dat
275+ where
276+ go :: Parser (Ok a) -> ByteString -> Ok a
277+ go p s =
278+ case parseOnly p s of
279+ Left err -> returnError ConversionFailed f err
280+ Right v -> v
281+
282+instance FromField RawResult where
283+ fromField field rawData = pure (RawResult field rawData)
src/Database/PostgreSQL/Simple/FromField.hs-bootdeleted−11
@@ -1,11 +0,0 @@
1−module Database.PostgreSQL.Simple.FromField where
2−
3−import Data.ByteString(ByteString)
4−import Database.PostgreSQL.Simple.Types
5−
6−class FromField a
7−
8−instance FromField Oid
9−instance FromField Char
10−instance FromField ByteString
11−instance FromField a => FromField (Maybe a)
src/Database/PostgreSQL/Simple/FromRow.hs+106−398
@@ -1,141 +1,75 @@
1−{-# LANGUAGE FlexibleContexts #-}
2−{-# LANGUAGE RecordWildCards, FlexibleInstances, DefaultSignatures #-}
3−
1+{-# LANGUAGE RecordWildCards #-}
42
53------------------------------------------------------------------------------
64-- |
75-- Module: Database.PostgreSQL.Simple.FromRow
8−-- Copyright: (c) 2012 Leon P Smith
6+-- Copyright: (c) 2011 Leon P Smith
97-- License: BSD3
108-- Maintainer: Leon P Smith <leon@melding-monads.com>
119-- Stability: experimental
10+-- Portability: portable
1211--
1312-- The 'FromRow' typeclass, for converting a row of results
1413-- returned by a SQL query into a more useful Haskell representation.
1514--
1615-- Predefined instances are provided for tuples containing up to ten
17−-- elements. The instances for 'Maybe' types return 'Nothing' if all
18−-- the columns that would have been otherwise consumed are null, otherwise
19−-- it attempts a regular conversion.
20−--
16+-- elements.
2117------------------------------------------------------------------------------
2218
2319module Database.PostgreSQL.Simple.FromRow
2420 ( FromRow(..)
2521 , RowParser
2622 , field
27− , fieldWith
2823 , numFieldsRemaining
2924 ) where
3025
31−import Prelude hiding (null)
32−import Control.Applicative (Applicative(..), (<$>), (<|>), (*>), liftA2)
33−import Control.Monad (replicateM, replicateM_)
34−import Control.Monad.Trans.State.Strict
35−import Control.Monad.Trans.Reader
36−import Control.Monad.Trans.Class
37−import Data.ByteString (ByteString)
26+import Control.Applicative (Applicative(..), (<$>))
27+import Control.Exception (SomeException(..), throw)
28+import Control.Monad (replicateM)
29+import Data.ByteString (ByteString)
3830import qualified Data.ByteString.Char8 as B
39−import Data.Vector (Vector)
40−import qualified Data.Vector as V
41−import Database.PostgreSQL.Simple.Types (Only(..))
31+import Database.PostgreSQL.Simple.Internal
32+import Database.PostgreSQL.Simple.Types (Only(..))
33+import Database.PostgreSQL.Simple.Ok
4234import qualified Database.PostgreSQL.LibPQ as PQ
4335import Database.PostgreSQL.Simple.Internal
44−import Database.PostgreSQL.Simple.Compat
4536import Database.PostgreSQL.Simple.FromField
46−import Database.PostgreSQL.Simple.Ok
47−import Database.PostgreSQL.Simple.Types ((:.)(..), Null)
48−import Database.PostgreSQL.Simple.TypeInfo
4937
50−import GHC.Generics
38+import Control.Monad.Trans.State.Strict
39+import Control.Monad.Trans.Reader
40+import Control.Monad.Trans.Class
5141
42+import Data.Vector ((!))
5243
53−-- | A collection type that can be converted from a sequence of fields.
54−-- Instances are provided for tuples up to 10 elements and lists of any length.
55−--
56−-- Note that instances can be defined outside of postgresql-simple, which is
57−-- often useful. For example, here's an instance for a user-defined pair:
58−--
59−-- @
60−-- data User = User { name :: String, fileQuota :: Int }
61−--
62−-- instance 'FromRow' User where
63−-- fromRow = User \<$\> 'field' \<*\> 'field'
64−-- @
65−--
66−-- The number of calls to 'field' must match the number of fields returned
67−-- in a single row of the query result. Otherwise, a 'ConversionFailed'
68−-- exception will be thrown.
69−--
70−-- You can also derive 'FromRow' for your data type using GHC generics, like
71−-- this:
72−--
73−-- @
74−-- \{-# LANGUAGE DeriveAnyClass \#-}
75−-- \{-# LANGUAGE DeriveGeneric \#-}
76−--
77−-- import "GHC.Generics" ('GHC.Generics.Generic')
78−-- import "Database.PostgreSQL.Simple" ('FromRow')
79−--
80−-- data User = User { name :: String, fileQuota :: Int }
81−-- deriving ('GHC.Generics.Generic', 'FromRow')
82−-- @
83−--
84−-- Note that this only works for product types (e.g. records) and does not
85−-- support sum types or recursive types.
86−--
87−-- Note that 'field' evaluates its result to WHNF, so the caveats listed in
88−-- mysql-simple and very early versions of postgresql-simple no longer apply.
89−-- Instead, look at the caveats associated with user-defined implementations
90−-- of 'fromField'.
44+import System.IO.Unsafe ( unsafePerformIO )
9145
9246class FromRow a where
9347 fromRow :: RowParser a
94− default fromRow :: (Generic a, GFromRow (Rep a)) => RowParser a
95− fromRow = to <$> gfromRow
96−
97−getvalue :: PQ.Result -> PQ.Row -> PQ.Column -> Maybe ByteString
98−getvalue result row col = unsafeDupablePerformIO (PQ.getvalue' result row col)
99−
100−nfields :: PQ.Result -> PQ.Column
101−nfields result = unsafeDupablePerformIO (PQ.nfields result)
10248
103−getTypeInfoByCol :: Row -> PQ.Column -> Conversion TypeInfo
104−getTypeInfoByCol Row{..} col =
105− Conversion $ \conn -> do
106− oid <- PQ.ftype rowresult col
107− Ok <$> getTypeInfo conn oid
108−
109−getTypenameByCol :: Row -> PQ.Column -> Conversion ByteString
110−getTypenameByCol row col = typname <$> getTypeInfoByCol row col
111−
112−fieldWith :: FieldParser a -> RowParser a
113−fieldWith fieldP = RP $ do
114− let unCol (PQ.Col x) = fromIntegral x :: Int
115− r@Row{..} <- ask
49+field :: FromField a => RowParser a
50+field = RP $ do
51+ let unCol (PQ.Col x) = fromIntegral x
52+ Row{..} <- ask
11653 column <- lift get
11754 lift (put (column + 1))
11855 let ncols = nfields rowresult
11956 if (column >= ncols)
120− then lift $ lift $ do
121− vals <- mapM (getTypenameByCol r) [0..ncols-1]
122− let err = ConversionFailed
123− (show (unCol ncols) ++ " values: " ++ show (map ellipsis vals))
124− Nothing
125− ""
57+ then do
58+ let vals = map (\c -> ( typenames ! (unCol c)
59+ , fmap ellipsis (getvalue rowresult row c) ))
60+ [0..ncols-1]
61+ convertError = ConversionFailed
62+ (show (unCol ncols) ++ " values: " ++ show vals)
12663 ("at least " ++ show (unCol column + 1)
12764 ++ " slots in target type")
12865 "mismatch between number of columns to \
12966 \convert and number in target type"
130− conversionError err
67+ lift (lift (Errors [SomeException convertError]))
13168 else do
132− let !result = rowresult
133− !typeOid = unsafeDupablePerformIO (PQ.ftype result column)
134− !field' = Field{..}
135− lift (lift (fieldP field' (getvalue result row column)))
136−
137−field :: FromField a => RowParser a
138−field = fieldWith fromField
69+ let typename = typenames ! unCol column
70+ result = rowresult
71+ field = Field{..}
72+ lift (lift (fromField field (getvalue result row column)))
13973
14074ellipsis :: ByteString -> ByteString
14175ellipsis bs
@@ -148,340 +82,114 @@ numFieldsRemaining = RP $ do
14882 column <- lift get
14983 return $! (\(PQ.Col x) -> fromIntegral x) (nfields rowresult - column)
15084
151−null :: RowParser Null
152−null = field
153−
15485instance (FromField a) => FromRow (Only a) where
155− fromRow = Only <$> field
156−
157−instance (FromField a) => FromRow (Maybe (Only a)) where
158− fromRow = (null *> pure Nothing)
159− <|> (Just <$> fromRow)
86+ fromRow = do
87+ !a <- field
88+ return (Only a)
16089
16190instance (FromField a, FromField b) => FromRow (a,b) where
162− fromRow = (,) <$> field <*> field
163−
164−instance (FromField a, FromField b) => FromRow (Maybe (a,b)) where
165− fromRow = (null *> null *> pure Nothing)
166− <|> (Just <$> fromRow)
91+ fromRow = do
92+ !a <- field
93+ !b <- field
94+ return (a,b)
16795
16896instance (FromField a, FromField b, FromField c) => FromRow (a,b,c) where
169− fromRow = (,,) <$> field <*> field <*> field
170−
171−instance (FromField a, FromField b, FromField c) => FromRow (Maybe (a,b,c)) where
172− fromRow = (null *> null *> null *> pure Nothing)
173− <|> (Just <$> fromRow)
97+ fromRow = do
98+ !a <- field
99+ !b <- field
100+ !c <- field
101+ return (a,b,c)
174102
175103instance (FromField a, FromField b, FromField c, FromField d) =>
176104 FromRow (a,b,c,d) where
177− fromRow = (,,,) <$> field <*> field <*> field <*> field
178−
179−instance (FromField a, FromField b, FromField c, FromField d) =>
180− FromRow (Maybe (a,b,c,d)) where
181− fromRow = (null *> null *> null *> null *> pure Nothing)
182− <|> (Just <$> fromRow)
105+ fromRow = do
106+ !a <- field
107+ !b <- field
108+ !c <- field
109+ !d <- field
110+ return (a,b,c,d)
183111
184112instance (FromField a, FromField b, FromField c, FromField d, FromField e) =>
185113 FromRow (a,b,c,d,e) where
186− fromRow = (,,,,) <$> field <*> field <*> field <*> field <*> field
187−
188−instance (FromField a, FromField b, FromField c, FromField d, FromField e) =>
189− FromRow (Maybe (a,b,c,d,e)) where
190− fromRow = (null *> null *> null *> null *> null *> pure Nothing)
191− <|> (Just <$> fromRow)
114+ fromRow = do
115+ !a <- field
116+ !b <- field
117+ !c <- field
118+ !d <- field
119+ !e <- field
120+ return (a,b,c,d,e)
192121
193122instance (FromField a, FromField b, FromField c, FromField d, FromField e,
194123 FromField f) =>
195124 FromRow (a,b,c,d,e,f) where
196− fromRow = (,,,,,) <$> field <*> field <*> field <*> field <*> field
197− <*> field
198−
199−instance (FromField a, FromField b, FromField c, FromField d, FromField e,
200− FromField f) =>
201− FromRow (Maybe (a,b,c,d,e,f)) where
202− fromRow = (null *> null *> null *> null *> null *>
203− null *> pure Nothing)
204− <|> (Just <$> fromRow)
125+ fromRow = do
126+ !a <- field
127+ !b <- field
128+ !c <- field
129+ !d <- field
130+ !e <- field
131+ !f <- field
132+ return (a,b,c,d,e,f)
205133
206134instance (FromField a, FromField b, FromField c, FromField d, FromField e,
207135 FromField f, FromField g) =>
208136 FromRow (a,b,c,d,e,f,g) where
209− fromRow = (,,,,,,) <$> field <*> field <*> field <*> field <*> field
210− <*> field <*> field
211−
212−instance (FromField a, FromField b, FromField c, FromField d, FromField e,
213− FromField f, FromField g) =>
214− FromRow (Maybe (a,b,c,d,e,f,g)) where
215− fromRow = (null *> null *> null *> null *> null *>
216− null *> null *> pure Nothing)
217− <|> (Just <$> fromRow)
137+ fromRow = do
138+ !a <- field
139+ !b <- field
140+ !c <- field
141+ !d <- field
142+ !e <- field
143+ !f <- field
144+ !g <- field
145+ return (a,b,c,d,e,f,g)
218146
219147instance (FromField a, FromField b, FromField c, FromField d, FromField e,
220148 FromField f, FromField g, FromField h) =>
221149 FromRow (a,b,c,d,e,f,g,h) where
222− fromRow = (,,,,,,,) <$> field <*> field <*> field <*> field <*> field
223− <*> field <*> field <*> field
224−
225−instance (FromField a, FromField b, FromField c, FromField d, FromField e,
226− FromField f, FromField g, FromField h) =>
227− FromRow (Maybe (a,b,c,d,e,f,g,h)) where
228− fromRow = (null *> null *> null *> null *> null *>
229− null *> null *> null *> pure Nothing)
230− <|> (Just <$> fromRow)
150+ fromRow = do
151+ !a <- field
152+ !b <- field
153+ !c <- field
154+ !d <- field
155+ !e <- field
156+ !f <- field
157+ !g <- field
158+ !h <- field
159+ return (a,b,c,d,e,f,g,h)
231160
232161instance (FromField a, FromField b, FromField c, FromField d, FromField e,
233162 FromField f, FromField g, FromField h, FromField i) =>
234163 FromRow (a,b,c,d,e,f,g,h,i) where
235− fromRow = (,,,,,,,,) <$> field <*> field <*> field <*> field <*> field
236− <*> field <*> field <*> field <*> field
237−
238−instance (FromField a, FromField b, FromField c, FromField d, FromField e,
239− FromField f, FromField g, FromField h, FromField i) =>
240− FromRow (Maybe (a,b,c,d,e,f,g,h,i)) where
241− fromRow = (null *> null *> null *> null *> null *>
242− null *> null *> null *> null *> pure Nothing)
243− <|> (Just <$> fromRow)
164+ fromRow = do
165+ !a <- field
166+ !b <- field
167+ !c <- field
168+ !d <- field
169+ !e <- field
170+ !f <- field
171+ !g <- field
172+ !h <- field
173+ !i <- field
174+ return (a,b,c,d,e,f,g,h,i)
244175
245176instance (FromField a, FromField b, FromField c, FromField d, FromField e,
246177 FromField f, FromField g, FromField h, FromField i, FromField j) =>
247178 FromRow (a,b,c,d,e,f,g,h,i,j) where
248− fromRow = (,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field
249− <*> field <*> field <*> field <*> field <*> field
250−
251−instance (FromField a, FromField b, FromField c, FromField d, FromField e,
252− FromField f, FromField g, FromField h, FromField i, FromField j) =>
253− FromRow (Maybe (a,b,c,d,e,f,g,h,i,j)) where
254− fromRow = (null *> null *> null *> null *> null *>
255− null *> null *> null *> null *> null *> pure Nothing)
256− <|> (Just <$> fromRow)
257−
258−instance (FromField a, FromField b, FromField c, FromField d, FromField e,
259− FromField f, FromField g, FromField h, FromField i, FromField j,
260− FromField k) =>
261− FromRow (a,b,c,d,e,f,g,h,i,j,k) where
262− fromRow = (,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field
263− <*> field <*> field <*> field <*> field <*> field
264− <*> field
265−
266−instance (FromField a, FromField b, FromField c, FromField d, FromField e,
267− FromField f, FromField g, FromField h, FromField i, FromField j,
268− FromField k) =>
269− FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k)) where
270− fromRow = (null *> null *> null *> null *> null *>
271− null *> null *> null *> null *> null *>
272− null *> pure Nothing)
273− <|> (Just <$> fromRow)
274−
275−instance (FromField a, FromField b, FromField c, FromField d, FromField e,
276− FromField f, FromField g, FromField h, FromField i, FromField j,
277− FromField k, FromField l) =>
278− FromRow (a,b,c,d,e,f,g,h,i,j,k,l) where
279− fromRow = (,,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field
280− <*> field <*> field <*> field <*> field <*> field
281− <*> field <*> field
282−
283−instance (FromField a, FromField b, FromField c, FromField d, FromField e,
284− FromField f, FromField g, FromField h, FromField i, FromField j,
285− FromField k, FromField l) =>
286− FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l)) where
287− fromRow = (null *> null *> null *> null *> null *>
288− null *> null *> null *> null *> null *>
289− null *> null *> pure Nothing)
290− <|> (Just <$> fromRow)
291−
292−instance (FromField a, FromField b, FromField c, FromField d, FromField e,
293− FromField f, FromField g, FromField h, FromField i, FromField j,
294− FromField k, FromField l, FromField m) =>
295− FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m) where
296− fromRow = (,,,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field
297− <*> field <*> field <*> field <*> field <*> field
298− <*> field <*> field <*> field
299−
300−instance (FromField a, FromField b, FromField c, FromField d, FromField e,
301− FromField f, FromField g, FromField h, FromField i, FromField j,
302− FromField k, FromField l, FromField m) =>
303− FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l,m)) where
304− fromRow = (null *> null *> null *> null *> null *>
305− null *> null *> null *> null *> null *>
306− null *> null *> null *> pure Nothing)
307− <|> (Just <$> fromRow)
308−
309−instance (FromField a, FromField b, FromField c, FromField d, FromField e,
310− FromField f, FromField g, FromField h, FromField i, FromField j,
311− FromField k, FromField l, FromField m, FromField n) =>
312− FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n) where
313− fromRow = (,,,,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field
314− <*> field <*> field <*> field <*> field <*> field
315− <*> field <*> field <*> field <*> field
316−
317−instance (FromField a, FromField b, FromField c, FromField d, FromField e,
318− FromField f, FromField g, FromField h, FromField i, FromField j,
319− FromField k, FromField l, FromField m, FromField n) =>
320− FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l,m,n)) where
321− fromRow = (null *> null *> null *> null *> null *>
322− null *> null *> null *> null *> null *>
323− null *> null *> null *> null *> pure Nothing)
324− <|> (Just <$> fromRow)
325−
326−instance (FromField a, FromField b, FromField c, FromField d, FromField e,
327− FromField f, FromField g, FromField h, FromField i, FromField j,
328− FromField k, FromField l, FromField m, FromField n, FromField o) =>
329− FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) where
330− fromRow = (,,,,,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field
331− <*> field <*> field <*> field <*> field <*> field
332− <*> field <*> field <*> field <*> field <*> field
333−
334−instance (FromField a, FromField b, FromField c, FromField d, FromField e,
335− FromField f, FromField g, FromField h, FromField i, FromField j,
336− FromField k, FromField l, FromField m, FromField n, FromField o) =>
337− FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o)) where
338− fromRow = (null *> null *> null *> null *> null *>
339− null *> null *> null *> null *> null *>
340− null *> null *> null *> null *> null *> pure Nothing)
341− <|> (Just <$> fromRow)
342−
343−instance (FromField a, FromField b, FromField c, FromField d, FromField e,
344− FromField f, FromField g, FromField h, FromField i, FromField j,
345− FromField k, FromField l, FromField m, FromField n, FromField o,
346− FromField p) =>
347− FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) where
348− fromRow = (,,,,,,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field
349− <*> field <*> field <*> field <*> field <*> field
350− <*> field <*> field <*> field <*> field <*> field
351− <*> field
352−
353−instance (FromField a, FromField b, FromField c, FromField d, FromField e,
354− FromField f, FromField g, FromField h, FromField i, FromField j,
355− FromField k, FromField l, FromField m, FromField n, FromField o,
356− FromField p) =>
357− FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p)) where
358− fromRow = (null *> null *> null *> null *> null *>
359− null *> null *> null *> null *> null *>
360− null *> null *> null *> null *> null *>
361− null *> pure Nothing)
362− <|> (Just <$> fromRow)
363−
364−instance (FromField a, FromField b, FromField c, FromField d, FromField e,
365− FromField f, FromField g, FromField h, FromField i, FromField j,
366− FromField k, FromField l, FromField m, FromField n, FromField o,
367− FromField p, FromField q) =>
368− FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q) where
369− fromRow = (,,,,,,,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field
370− <*> field <*> field <*> field <*> field <*> field
371− <*> field <*> field <*> field <*> field <*> field
372− <*> field <*> field
373−
374−instance (FromField a, FromField b, FromField c, FromField d, FromField e,
375− FromField f, FromField g, FromField h, FromField i, FromField j,
376− FromField k, FromField l, FromField m, FromField n, FromField o,
377− FromField p, FromField q) =>
378− FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q)) where
379− fromRow = (null *> null *> null *> null *> null *>
380− null *> null *> null *> null *> null *>
381− null *> null *> null *> null *> null *>
382− null *> null *> pure Nothing)
383− <|> (Just <$> fromRow)
384−
385−instance (FromField a, FromField b, FromField c, FromField d, FromField e,
386− FromField f, FromField g, FromField h, FromField i, FromField j,
387− FromField k, FromField l, FromField m, FromField n, FromField o,
388− FromField p, FromField q, FromField r) =>
389− FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r) where
390− fromRow = (,,,,,,,,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field
391− <*> field <*> field <*> field <*> field <*> field
392− <*> field <*> field <*> field <*> field <*> field
393− <*> field <*> field <*> field
394−
395−instance (FromField a, FromField b, FromField c, FromField d, FromField e,
396− FromField f, FromField g, FromField h, FromField i, FromField j,
397− FromField k, FromField l, FromField m, FromField n, FromField o,
398− FromField p, FromField q, FromField r) =>
399− FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r)) where
400− fromRow = (null *> null *> null *> null *> null *>
401− null *> null *> null *> null *> null *>
402− null *> null *> null *> null *> null *>
403− null *> null *> null *> pure Nothing)
404− <|> (Just <$> fromRow)
405−
406−instance (FromField a, FromField b, FromField c, FromField d, FromField e,
407− FromField f, FromField g, FromField h, FromField i, FromField j,
408− FromField k, FromField l, FromField m, FromField n, FromField o,
409− FromField p, FromField q, FromField r, FromField s) =>
410− FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s) where
411− fromRow = (,,,,,,,,,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field
412− <*> field <*> field <*> field <*> field <*> field
413− <*> field <*> field <*> field <*> field <*> field
414− <*> field <*> field <*> field <*> field
415−
416−instance (FromField a, FromField b, FromField c, FromField d, FromField e,
417− FromField f, FromField g, FromField h, FromField i, FromField j,
418− FromField k, FromField l, FromField m, FromField n, FromField o,
419− FromField p, FromField q, FromField r, FromField s) =>
420− FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s)) where
421− fromRow = (null *> null *> null *> null *> null *>
422− null *> null *> null *> null *> null *>
423− null *> null *> null *> null *> null *>
424− null *> null *> null *> null *> pure Nothing)
425− <|> (Just <$> fromRow)
426−
427−instance (FromField a, FromField b, FromField c, FromField d, FromField e,
428− FromField f, FromField g, FromField h, FromField i, FromField j,
429− FromField k, FromField l, FromField m, FromField n, FromField o,
430− FromField p, FromField q, FromField r, FromField s, FromField t) =>
431− FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t) where
432− fromRow = (,,,,,,,,,,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field
433− <*> field <*> field <*> field <*> field <*> field
434− <*> field <*> field <*> field <*> field <*> field
435− <*> field <*> field <*> field <*> field <*> field
436−
437−instance (FromField a, FromField b, FromField c, FromField d, FromField e,
438− FromField f, FromField g, FromField h, FromField i, FromField j,
439− FromField k, FromField l, FromField m, FromField n, FromField o,
440− FromField p, FromField q, FromField r, FromField s, FromField t) =>
441− FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t)) where
442− fromRow = (null *> null *> null *> null *> null *>
443− null *> null *> null *> null *> null *>
444− null *> null *> null *> null *> null *>
445− null *> null *> null *> null *> null *> pure Nothing)
446− <|> (Just <$> fromRow)
179+ fromRow = do
180+ !a <- field
181+ !b <- field
182+ !c <- field
183+ !d <- field
184+ !e <- field
185+ !f <- field
186+ !g <- field
187+ !h <- field
188+ !i <- field
189+ !j <- field
190+ return (a,b,c,d,e,f,g,h,i,j)
447191
448192instance FromField a => FromRow [a] where
449193 fromRow = do
450194 n <- numFieldsRemaining
451195 replicateM n field
452−
453−instance FromField a => FromRow (Maybe [a]) where
454− fromRow = do
455− n <- numFieldsRemaining
456− (replicateM_ n null *> pure Nothing) <|> (Just <$> replicateM n field)
457−
458−instance FromField a => FromRow (Vector a) where
459− fromRow = do
460− n <- numFieldsRemaining
461− V.replicateM n field
462−
463−instance FromField a => FromRow (Maybe (Vector a)) where
464− fromRow = do
465− n <- numFieldsRemaining
466− (replicateM_ n null *> pure Nothing) <|> (Just <$> V.replicateM n field)
467−
468−instance (FromRow a, FromRow b) => FromRow (a :. b) where
469− fromRow = (:.) <$> fromRow <*> fromRow
470−
471−
472−
473−-- Type class for default implementation of FromRow using generics
474−class GFromRow f where
475− gfromRow :: RowParser (f p)
476−
477−instance GFromRow f => GFromRow (M1 c i f) where
478− gfromRow = M1 <$> gfromRow
479−
480−instance (GFromRow f, GFromRow g) => GFromRow (f :*: g) where
481− gfromRow = liftA2 (:*:) gfromRow gfromRow
482−
483−instance (FromField a) => GFromRow (K1 R a) where
484− gfromRow = K1 <$> field
485−
486−instance GFromRow U1 where
487− gfromRow = pure U1
src/Database/PostgreSQL/Simple/FromRow.hs-bootdeleted−17
@@ -1,17 +0,0 @@
1−module Database.PostgreSQL.Simple.FromRow where
2−
3−import {-# SOURCE #-} Database.PostgreSQL.Simple.FromField
4−import Database.PostgreSQL.Simple.Types
5−
6−class FromRow a
7−
8−instance (FromField a) => FromRow (Only a)
9−instance (FromField a, FromField b)
10− => FromRow (a,b)
11−instance (FromField a, FromField b, FromField c, FromField d)
12− => FromRow (a,b,c,d)
13−instance (FromField a, FromField b, FromField c, FromField d, FromField e)
14− => FromRow (a,b,c,d,e)
15−instance (FromField a, FromField b, FromField c, FromField d, FromField e
16− ,FromField f)
17− => FromRow (a,b,c,d,e,f)
src/Database/PostgreSQL/Simple/HStore.hsdeleted−36
@@ -1,36 +0,0 @@
1−------------------------------------------------------------------------------
2−-- |
3−-- Module: Database.PostgreSQL.Simple.HStore
4−-- Copyright: (c) 2013 Leon P Smith
5−-- License: BSD3
6−-- Maintainer: Leon P Smith <leon@melding-monads.com>
7−-- Stability: experimental
8−--
9−-- Parsers and printers for hstore, a extended type bundled with
10−-- PostgreSQL providing finite maps from text strings to text strings.
11−-- See <https://www.postgresql.org/docs/9.5/static/hstore.html> for more
12−-- information.
13−--
14−-- Note that in order to use this type, a database superuser must
15−-- install it by running a sql script in the share directory. This
16−-- can be done on PostgreSQL 9.1 and later with the command
17−-- @CREATE EXTENSION hstore@. See
18−-- <https://www.postgresql.org/docs/9.5/static/contrib.html> for more
19−-- information.
20−--
21−------------------------------------------------------------------------------
22−
23−module Database.PostgreSQL.Simple.HStore
24− ( HStoreList(..)
25− , HStoreMap(..)
26− , ToHStore(..)
27− , HStoreBuilder
28− , toBuilder
29− , toLazyByteString
30− , hstore
31− , parseHStoreList
32− , ToHStoreText(..)
33− , HStoreText
34− ) where
35−
36−import Database.PostgreSQL.Simple.HStore.Implementation
src/Database/PostgreSQL/Simple/HStore/Implementation.hsdeleted−210
@@ -1,210 +0,0 @@
1−{-# LANGUAGE CPP, ViewPatterns, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
2−
3−------------------------------------------------------------------------------
4−-- |
5−-- Module: Database.PostgreSQL.Simple.HStore.Implementation
6−-- Copyright: (c) 2013 Leon P Smith
7−-- License: BSD3
8−-- Maintainer: Leon P Smith <leon@melding-monads.com>
9−-- Stability: experimental
10−--
11−-- This code has yet to be profiled and optimized.
12−--
13−------------------------------------------------------------------------------
14−
15−module Database.PostgreSQL.Simple.HStore.Implementation where
16−
17−import Control.Applicative
18−import qualified Data.Attoparsec.ByteString as P
19−import qualified Data.Attoparsec.ByteString.Char8 as P (isSpace_w8)
20−import qualified Data.ByteString as BS
21−import Data.ByteString.Builder (Builder, byteString, char8)
22−import qualified Data.ByteString.Builder as BU
23−import Data.ByteString.Internal (c2w, w2c)
24−import qualified Data.ByteString.Lazy as BL
25−import Data.Map(Map)
26−import qualified Data.Map as Map
27−import Data.Text(Text)
28−import qualified Data.Text as TS
29−import qualified Data.Text.Encoding as TS
30−import Data.Text.Encoding.Error(UnicodeException)
31−import qualified Data.Text.Lazy as TL
32−import Data.Typeable
33−import Data.Monoid(Monoid(..))
34−import Data.Semigroup
35−import Database.PostgreSQL.Simple.FromField
36−import Database.PostgreSQL.Simple.ToField
37−
38−class ToHStore a where
39− toHStore :: a -> HStoreBuilder
40−
41−-- | Represents valid hstore syntax.
42−data HStoreBuilder
43− = Empty
44− | Comma !Builder
45− deriving (Typeable)
46−
47−instance ToHStore HStoreBuilder where
48− toHStore = id
49−
50−toBuilder :: HStoreBuilder -> Builder
51−toBuilder x = case x of
52− Empty -> mempty
53− Comma c -> c
54−
55−toLazyByteString :: HStoreBuilder -> BL.ByteString
56−toLazyByteString x = case x of
57− Empty -> BL.empty
58− Comma c -> BU.toLazyByteString c
59−
60−instance Semigroup HStoreBuilder where
61− Empty <> x = x
62− Comma a <> x
63− = Comma (a `mappend` case x of
64− Empty -> mempty
65− Comma b -> char8 ',' `mappend` b)
66−
67−instance Monoid HStoreBuilder where
68− mempty = Empty
69−
70−class ToHStoreText a where
71− toHStoreText :: a -> HStoreText
72−
73−-- | Represents escape text, ready to be the key or value to a hstore value
74−newtype HStoreText = HStoreText Builder deriving (Typeable, Semigroup, Monoid)
75−
76−instance ToHStoreText HStoreText where
77− toHStoreText = id
78−
79−-- | Assumed to be UTF-8 encoded
80−instance ToHStoreText BS.ByteString where
81− toHStoreText str = HStoreText (escapeAppend str mempty)
82−
83−-- | Assumed to be UTF-8 encoded
84−instance ToHStoreText BL.ByteString where
85− toHStoreText = HStoreText . BL.foldrChunks escapeAppend mempty
86−
87−instance ToHStoreText TS.Text where
88− toHStoreText str = HStoreText (escapeAppend (TS.encodeUtf8 str) mempty)
89−
90−instance ToHStoreText TL.Text where
91− toHStoreText = HStoreText . TL.foldrChunks (escapeAppend . TS.encodeUtf8) mempty
92−
93−escapeAppend :: BS.ByteString -> Builder -> Builder
94−escapeAppend = loop
95− where
96− loop (BS.break quoteNeeded -> (a,b)) rest
97− = byteString a `mappend`
98− case BS.uncons b of
99− Nothing -> rest
100− Just (c,d) -> quoteChar c `mappend` loop d rest
101−
102− quoteNeeded c = c == c2w '\"' || c == c2w '\\'
103− quoteChar c
104− | c == c2w '\"' = byteString "\\\""
105− | otherwise = byteString "\\\\"
106−
107−hstore :: (ToHStoreText a, ToHStoreText b) => a -> b -> HStoreBuilder
108−hstore (toHStoreText -> (HStoreText key)) (toHStoreText -> (HStoreText val)) =
109− Comma (char8 '"' `mappend` key `mappend` byteString "\"=>\""
110− `mappend` val `mappend` char8 '"')
111−
112−instance ToField HStoreBuilder where
113− toField Empty = toField (BS.empty)
114− toField (Comma x) = toField (BU.toLazyByteString x)
115−
116−newtype HStoreList = HStoreList {fromHStoreList :: [(Text,Text)]} deriving (Typeable, Show)
117−
118−-- | hstore
119−instance ToHStore HStoreList where
120− toHStore (HStoreList xs) = mconcat (map (uncurry hstore) xs)
121−
122−instance ToField HStoreList where
123− toField xs = toField (toHStore xs)
124−
125−-- | hstore
126−instance FromField HStoreList where
127− fromField f mdat = do
128− typ <- typename f
129− if typ /= "hstore"
130− then returnError Incompatible f ""
131− else case mdat of
132− Nothing -> returnError UnexpectedNull f ""
133− Just dat ->
134− case P.parseOnly (parseHStore <* P.endOfInput) dat of
135− Left err ->
136− returnError ConversionFailed f err
137− Right (Left err) ->
138− returnError ConversionFailed f "unicode exception" <|>
139− conversionError err
140− Right (Right val) ->
141− return val
142−
143−newtype HStoreMap = HStoreMap {fromHStoreMap :: Map Text Text} deriving (Eq, Ord, Typeable, Show)
144−
145−instance ToHStore HStoreMap where
146− toHStore (HStoreMap xs) = Map.foldrWithKey f mempty xs
147− where f k v xs' = hstore k v `mappend` xs'
148−
149−instance ToField HStoreMap where
150− toField xs = toField (toHStore xs)
151−
152−instance FromField HStoreMap where
153− fromField f mdat = convert <$> fromField f mdat
154− where convert (HStoreList xs) = HStoreMap (Map.fromList xs)
155−
156−parseHStoreList :: BS.ByteString -> Either String HStoreList
157−parseHStoreList dat =
158− case P.parseOnly (parseHStore <* P.endOfInput) dat of
159− Left err -> Left (show err)
160− Right (Left err) -> Left (show err)
161− Right (Right val) -> Right val
162−
163−parseHStore :: P.Parser (Either UnicodeException HStoreList)
164−parseHStore = do
165− kvs <- P.sepBy' (skipWhiteSpace *> parseHStoreKeyVal)
166− (skipWhiteSpace *> P.word8 (c2w ','))
167− return $ HStoreList <$> sequence kvs
168−
169−parseHStoreKeyVal :: P.Parser (Either UnicodeException (Text,Text))
170−parseHStoreKeyVal = do
171− mkey <- parseHStoreText
172− case mkey of
173− Left err -> return (Left err)
174− Right key -> do
175− skipWhiteSpace
176− _ <- P.string "=>"
177− skipWhiteSpace
178− mval <- parseHStoreText
179− case mval of
180− Left err -> return (Left err)
181− Right val -> return (Right (key,val))
182−
183−
184−skipWhiteSpace :: P.Parser ()
185−skipWhiteSpace = P.skipWhile P.isSpace_w8
186−
187−parseHStoreText :: P.Parser (Either UnicodeException Text)
188−parseHStoreText = do
189− _ <- P.word8 (c2w '"')
190− mtexts <- parseHStoreTexts id
191− case mtexts of
192− Left err -> return (Left err)
193− Right texts -> do
194− _ <- P.word8 (c2w '"')
195− return (Right (TS.concat texts))
196−
197−parseHStoreTexts :: ([Text] -> [Text])
198− -> P.Parser (Either UnicodeException [Text])
199−parseHStoreTexts acc = do
200− mchunk <- TS.decodeUtf8' <$> P.takeWhile (not . isSpecialChar)
201− case mchunk of
202− Left err -> return (Left err)
203− Right chunk ->
204− (do
205− _ <- P.word8 (c2w '\\')
206− c <- TS.singleton . w2c <$> P.satisfy isSpecialChar
207− parseHStoreTexts (acc . (chunk:) . (c:))
208− ) <|> return (Right (acc [chunk]))
209− where
210− isSpecialChar c = c == c2w '\\' || c == c2w '"'
src/Database/PostgreSQL/Simple/HStore/Internal.hsdeleted−19
@@ -1,19 +0,0 @@
1−------------------------------------------------------------------------------
2−-- |
3−-- Module: Database.PostgreSQL.Simple.HStore.Internal
4−-- Copyright: (c) 2013 Leon P Smith
5−-- License: BSD3
6−-- Maintainer: Leon P Smith <leon@melding-monads.com>
7−-- Stability: experimental
8−--
9−------------------------------------------------------------------------------
10−
11−module Database.PostgreSQL.Simple.HStore.Internal
12− ( HStoreBuilder(..)
13− , HStoreText(..)
14− , parseHStore
15− , parseHStoreKeyVal
16− , parseHStoreText
17− ) where
18−
19−import Database.PostgreSQL.Simple.HStore.Implementation
src/Database/PostgreSQL/Simple/Internal.hs+66−457
@@ -1,16 +1,13 @@
1−{-# LANGUAGE CPP, BangPatterns, DoAndIfThenElse, RecordWildCards #-}
2−{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}
3−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4−{-# LANGUAGE ExistentialQuantification #-}
5−{-# LANGUAGE InstanceSigs #-}
6−
1+{-# LANGUAGE OverloadedStrings, NamedFieldPuns, RecordWildCards #-}
2+{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
73------------------------------------------------------------------------------
84-- |
95-- Module: Database.PostgreSQL.Simple.Internal
10−-- Copyright: (c) 2011-2015 Leon P Smith
6+-- Copyright: (c) 2011 Leon P Smith
117-- License: BSD3
128-- Maintainer: Leon P Smith <leon@melding-monads.com>
139-- Stability: experimental
10+-- Portability: portable
1411--
1512-- Internal bits. This interface is less stable and can change at any time.
1613-- In particular this means that while the rest of the postgresql-simple
@@ -23,40 +20,24 @@
2320
2421module Database.PostgreSQL.Simple.Internal where
2522
23+import Prelude hiding (catch)
24+
2625import Control.Applicative
2726import Control.Exception
2827import Control.Concurrent.MVar
29−import Control.Monad(MonadPlus(..))
3028import Data.ByteString(ByteString)
31−import qualified Data.ByteString as B
32−import qualified Data.ByteString.Char8 as B8
33−import Data.ByteString.Builder ( Builder, byteString )
34−import Data.Char (ord)
35−import Data.Int (Int64)
3629import qualified Data.IntMap as IntMap
37−import Data.IORef
38−import Data.Maybe(fromMaybe)
3930import Data.String
40−import qualified Data.Text as T
41−import qualified Data.Text.Encoding as TE
4231import Data.Typeable
4332import Data.Word
4433import Database.PostgreSQL.LibPQ(Oid(..))
4534import qualified Database.PostgreSQL.LibPQ as PQ
46−import Database.PostgreSQL.LibPQ(ExecStatus(..))
47−import Database.PostgreSQL.Simple.Compat ( toByteString )
35+import Database.PostgreSQL.Simple.BuiltinTypes (BuiltinType)
4836import Database.PostgreSQL.Simple.Ok
49−import Database.PostgreSQL.Simple.ToField (Action(..), inQuotes)
50−import Database.PostgreSQL.Simple.Types (Query(..))
51−import Database.PostgreSQL.Simple.TypeInfo.Types(TypeInfo)
5237import Control.Monad.Trans.State.Strict
5338import Control.Monad.Trans.Reader
54−import Control.Monad.Trans.Class
55−import GHC.Generics
56−import GHC.IO.Exception
57−#if !defined(mingw32_HOST_OS)
58−import Control.Concurrent(threadWaitRead, threadWaitWrite)
59−#endif
39+import qualified Data.Vector as V
40+import System.IO.Unsafe (unsafePerformIO)
6041
6142-- | A Field represents metadata about a particular field
6243--
@@ -67,80 +48,44 @@ import Control.Concurrent(threadWaitRead, threadWaitWrite)
6748data Field = Field {
6849 result :: !PQ.Result
6950 , column :: {-# UNPACK #-} !PQ.Column
70− , typeOid :: {-# UNPACK #-} !PQ.Oid
71− -- ^ This returns the type oid associated with the column. Analogous
72− -- to libpq's @PQftype@.
51+ , typename :: !ByteString
7352 }
7453
75−type TypeInfoCache = IntMap.IntMap TypeInfo
54+name :: Field -> Maybe ByteString
55+name Field{..} = unsafePerformIO (PQ.fname result column)
7656
77−data Connection = Connection {
78− connectionHandle :: {-# UNPACK #-} !(MVar PQ.Connection)
79− , connectionObjects :: {-# UNPACK #-} !(MVar TypeInfoCache)
80− , connectionTempNameCounter :: {-# UNPACK #-} !(IORef Int64)
81− } deriving (Typeable)
57+tableOid :: Field -> PQ.Oid
58+tableOid Field{..} = unsafePerformIO (PQ.ftable result column)
59+
60+tableColumn :: Field -> Int
61+tableColumn Field{..} = fromCol (unsafePerformIO (PQ.ftablecol result column))
62+ where
63+ fromCol (PQ.Col x) = fromIntegral x
8264
83−instance Eq Connection where
84− x == y = connectionHandle x == connectionHandle y
8565
86−-- | Superclass for postgresql exceptions
87−data SomePostgreSqlException = forall e. Exception e => SomePostgreSqlException e
88− deriving Typeable
66+format :: Field -> PQ.Format
67+format Field{..} = unsafePerformIO (PQ.fformat result column)
8968
90−postgresqlExceptionToException :: Exception e => e -> SomeException
91−postgresqlExceptionToException = toException . SomePostgreSqlException
69+typeOid :: Field -> PQ.Oid
70+typeOid Field{..} = unsafePerformIO (PQ.ftype result column)
9271
93−postgresqlExceptionFromException :: Exception e => SomeException -> Maybe e
94−postgresqlExceptionFromException x = do
95− SomePostgreSqlException a <- fromException x
96− cast a
9772
98−instance Show SomePostgreSqlException where
99− showsPrec :: Int -> SomePostgreSqlException -> ShowS
100− showsPrec p (SomePostgreSqlException e) = showsPrec p e
73+data Connection = Connection {
74+ connectionHandle :: {-# UNPACK #-} !(MVar PQ.Connection)
75+ , connectionObjects :: {-# UNPACK #-} !(MVar (IntMap.IntMap ByteString))
76+ }
10177
102−instance Exception SomePostgreSqlException where
103− displayException (SomePostgreSqlException e) = displayException e
78+data SqlType
79+ = Builtin BuiltinType
80+ | Other Oid
10481
10582data SqlError = SqlError {
10683 sqlState :: ByteString
107− , sqlExecStatus :: ExecStatus
84+ , sqlNativeError :: Int
10885 , sqlErrorMsg :: ByteString
109− , sqlErrorDetail :: ByteString
110− , sqlErrorHint :: ByteString
111− } deriving (Eq, Show, Typeable)
112−
113−fatalError :: ByteString -> SqlError
114−fatalError msg = SqlError "" FatalError msg "" ""
115−
116−instance Exception SqlError where
117− toException = postgresqlExceptionToException
118− fromException = postgresqlExceptionFromException
119−
120−
121−-- | Exception thrown if 'query' is used to perform an @INSERT@-like
122−-- operation, or 'execute' is used to perform a @SELECT@-like operation.
123−data QueryError = QueryError {
124− qeMessage :: String
125− , qeQuery :: Query
126− } deriving (Eq, Show, Typeable)
127−
128−instance Exception QueryError where
129− toException = postgresqlExceptionToException
130− fromException = postgresqlExceptionFromException
131−
132−-- | Exception thrown if a 'Query' could not be formatted correctly.
133−-- This may occur if the number of \'@?@\' characters in the query
134−-- string does not match the number of parameters provided.
135−data FormatError = FormatError {
136− fmtMessage :: String
137− , fmtQuery :: Query
138− , fmtParams :: [ByteString]
139− } deriving (Eq, Show, Typeable)
140−
141−instance Exception FormatError where
142− toException = postgresqlExceptionToException
143− fromException = postgresqlExceptionFromException
86+ } deriving (Show, Typeable)
87+
88+instance Exception SqlError
14489
14590data ConnectInfo = ConnectInfo {
14691 connectHost :: String
@@ -148,7 +93,7 @@ data ConnectInfo = ConnectInfo {
14893 , connectUser :: String
14994 , connectPassword :: String
15095 , connectDatabase :: String
151− } deriving (Generic,Eq,Read,Show,Typeable)
96+ } deriving (Eq,Read,Show,Typeable)
15297
15398-- | Default information for setting up a connection.
15499--
@@ -182,132 +127,24 @@ defaultConnectInfo = ConnectInfo {
182127connect :: ConnectInfo -> IO Connection
183128connect = connectPostgreSQL . postgreSQLConnectionString
184129
185−-- | Memory bracket around 'connect' and 'close'.
186−--
187−-- @since 0.6.5
188−withConnect :: ConnectInfo -> (Connection -> IO c) -> IO c
189−withConnect connInfo = bracket (connect connInfo) close
190−
191130-- | Attempt to make a connection based on a libpq connection string.
192−-- See <https://www.postgresql.org/docs/9.5/static/libpq-connect.html#LIBPQ-CONNSTRING>
193−-- for more information. Also note that environment variables also affect
194−-- parameters not provided, parameters provided as the empty string, and a
195−-- few other things; see
196−-- <https://www.postgresql.org/docs/9.5/static/libpq-envars.html>
197−-- for details. Here is an example with some of the most commonly used
198−-- parameters:
199−--
200−-- > host='db.somedomain.com' port=5432 ...
201−--
202−-- This attempts to connect to @db.somedomain.com:5432@. Omitting the port
203−-- will normally default to 5432.
204−--
205−-- On systems that provide unix domain sockets, omitting the host parameter
206−-- will cause libpq to attempt to connect via unix domain sockets.
207−-- The default filesystem path to the socket is constructed from the
208−-- port number and the @DEFAULT_PGSOCKET_DIR@ constant defined in the
209−-- @pg_config_manual.h@ header file. Connecting via unix sockets tends
210−-- to use the @peer@ authentication method, which is very secure and
211−-- does not require a password.
212−--
213−-- On Windows and other systems without unix domain sockets, omitting
214−-- the host will default to @localhost@.
215−--
216−-- > ... dbname='postgres' user='postgres' password='secret \' \\ pw'
217−--
218−-- This attempts to connect to a database named @postgres@ with
219−-- user @postgres@ and password @secret \' \\ pw@. Backslash
220−-- characters will have to be double-quoted in literal Haskell strings,
221−-- of course. Omitting @dbname@ and @user@ will both default to the
222−-- system username that the client process is running as.
223−--
224−-- Omitting @password@ will default to an appropriate password found
225−-- in the @pgpass@ file, or no password at all if a matching line is
226−-- not found. The path of the @pgpass@ file may be specified by setting
227−-- the @PGPASSFILE@ environment variable. See
228−-- <https://www.postgresql.org/docs/9.5/static/libpq-pgpass.html> for
229−-- more information regarding this file.
230−--
231−-- As all parameters are optional and the defaults are sensible, the
232−-- empty connection string can be useful for development and
233−-- exploratory use, assuming your system is set up appropriately.
234−--
235−-- On Unix, such a setup would typically consist of a local
236−-- postgresql server listening on port 5432, as well as a system user,
237−-- database user, and database sharing a common name, with permissions
238−-- granted to the user on the database.
239−--
240−-- On Windows, in addition you will either need @pg_hba.conf@
241−-- to specify the use of the @trust@ authentication method for
242−-- the connection, which may not be appropriate for multiuser
243−-- or production machines, or you will need to use a @pgpass@ file
244−-- with the @password@ or @md5@ authentication methods.
245−--
246−-- See <https://www.postgresql.org/docs/9.5/static/client-authentication.html>
247−-- for more information regarding the authentication process.
248−--
249−-- SSL/TLS will typically "just work" if your postgresql server supports or
250−-- requires it. However, note that libpq is trivially vulnerable to a MITM
251−-- attack without setting additional SSL connection parameters. In
252−-- particular, @sslmode@ needs to be set to @require@, @verify-ca@, or
253−-- @verify-full@ in order to perform certificate validation. When @sslmode@
254−-- is @require@, then you will also need to specify a @sslrootcert@ file,
255−-- otherwise no validation of the server's identity will be performed.
256−-- Client authentication via certificates is also possible via the
257−-- @sslcert@ and @sslkey@ parameters. See
258−-- <https://www.postgresql.org/docs/9.5/static/libpq-ssl.html>
259−-- for detailed information regarding libpq and SSL.
131+-- See <http://www.postgresql.org/docs/9.1/static/libpq-connect.html>
132+-- for more information.
260133
261134connectPostgreSQL :: ByteString -> IO Connection
262135connectPostgreSQL connstr = do
263− conn <- connectdb connstr
136+ conn <- PQ.connectdb connstr
264137 stat <- PQ.status conn
265138 case stat of
266139 PQ.ConnectionOk -> do
267140 connectionHandle <- newMVar conn
268141 connectionObjects <- newMVar (IntMap.empty)
269− connectionTempNameCounter <- newIORef 0
270− let wconn = Connection{..}
271− version <- PQ.serverVersion conn
272− let settings
273− | version < 80200 = "SET datestyle TO ISO;SET client_encoding TO UTF8"
274− | otherwise = "SET datestyle TO ISO;SET client_encoding TO UTF8;SET standard_conforming_strings TO on"
275− _ <- execute_ wconn settings
276− return wconn
142+ return Connection{..}
277143 _ -> do
278144 msg <- maybe "connectPostgreSQL error" id <$> PQ.errorMessage conn
279− throwIO $ fatalError msg
280−
281−connectdb :: ByteString -> IO PQ.Connection
282−#if defined(mingw32_HOST_OS)
283−connectdb = PQ.connectdb
284−#else
285−connectdb conninfo = do
286− conn <- PQ.connectStart conninfo
287− loop conn
288− where
289− funcName = "Database.PostgreSQL.Simple.connectPostgreSQL"
290− loop conn = do
291− status <- PQ.connectPoll conn
292− case status of
293− PQ.PollingFailed -> throwLibPQError conn "connection failed"
294− PQ.PollingReading -> do
295− mfd <- PQ.socket conn
296− case mfd of
297− Nothing -> throwIO $! fdError funcName
298− Just fd -> do
299− threadWaitRead fd
300− loop conn
301− PQ.PollingWriting -> do
302− mfd <- PQ.socket conn
303− case mfd of
304− Nothing -> throwIO $! fdError funcName
305− Just fd -> do
306− threadWaitWrite fd
307− loop conn
308− PQ.PollingOk -> return conn
309−
310−#endif
145+ throwIO $ SqlError { sqlNativeError = -1 -- FIXME?
146+ , sqlErrorMsg = msg
147+ , sqlState = "" }
311148
312149-- | Turns a 'ConnectInfo' data structure into a libpq connection string.
313150
@@ -323,7 +160,7 @@ postgreSQLConnectionString connectInfo = fromString connstr
323160
324161 str name field
325162 | null value = id
326− | otherwise = showString name . addQuotes value . space
163+ | otherwise = showString name . quote value . space
327164 where value = field connectInfo
328165
329166 num name field
@@ -331,7 +168,7 @@ postgreSQLConnectionString connectInfo = fromString connstr
331168 | otherwise = showString name . shows value . space
332169 where value = field connectInfo
333170
334− addQuotes s rest = '\'' : foldr delta ('\'' : rest) s
171+ quote str rest = '\'' : foldr delta ('\'' : rest) str
335172 where
336173 delta c cs = case c of
337174 '\\' -> '\\' : '\\' : cs
@@ -350,112 +187,23 @@ oid2int (Oid x) = fromIntegral x
350187exec :: Connection
351188 -> ByteString
352189 -> IO PQ.Result
353−#if defined(mingw32_HOST_OS)
354190exec conn sql =
355191 withConnection conn $ \h -> do
356192 mres <- PQ.exec h sql
357193 case mres of
358− Nothing -> throwLibPQError h "PQexec returned no results"
359− Just res -> return res
360−#else
361−exec conn sql =
362− withConnection conn $ \h -> do
363− success <- PQ.sendQuery h sql
364− if success
365− then awaitResult h Nothing
366− else throwLibPQError h "PQsendQuery failed"
367− where
368− awaitResult h mres = do
369− mfd <- PQ.socket h
370− case mfd of
371− Nothing -> throwIO $! fdError "Database.PostgreSQL.Simple.Internal.exec"
372− Just fd -> do
373− threadWaitRead fd
374− _ <- PQ.consumeInput h -- FIXME?
375− getResult h mres
376−
377− getResult h mres = do
378− isBusy <- PQ.isBusy h
379− if isBusy
380− then awaitResult h mres
381− else do
382− mres' <- PQ.getResult h
383− case mres' of
384− Nothing -> case mres of
385− Nothing -> throwLibPQError h "PQgetResult returned no results"
386− Just res -> return res
387− Just res -> do
388− status <- PQ.resultStatus res
389− case status of
390− -- FIXME: handle PQ.CopyBoth and PQ.SingleTuple
391− PQ.EmptyQuery -> getResult h mres'
392− PQ.CommandOk -> getResult h mres'
393− PQ.TuplesOk -> getResult h mres'
394− PQ.CopyOut -> return res
395− PQ.CopyIn -> return res
396− PQ.BadResponse -> getResult h mres'
397− PQ.NonfatalError -> getResult h mres'
398− PQ.FatalError -> getResult h mres'
399−#endif
400−
401−-- | A version of 'execute' that does not perform query substitution.
402−execute_ :: Connection -> Query -> IO Int64
403−execute_ conn q@(Query stmt) = do
404− result <- exec conn stmt
405− finishExecute conn q result
406−
407−finishExecute :: Connection -> Query -> PQ.Result -> IO Int64
408−finishExecute _conn q result = do
409− status <- PQ.resultStatus result
410− case status of
411− -- FIXME: handle PQ.CopyBoth and PQ.SingleTuple
412− PQ.EmptyQuery -> throwIO $ QueryError "execute: Empty query" q
413− PQ.CommandOk -> do
414− ncols <- PQ.nfields result
415− if ncols /= 0
416− then throwIO $ QueryError ("execute resulted in " ++ show ncols ++
417− "-column result") q
418− else do
419− nstr <- PQ.cmdTuples result
420− return $ case nstr of
421− Nothing -> 0 -- is this appropriate?
422− Just str -> mkInteger str
423− PQ.TuplesOk -> do
424− ncols <- PQ.nfields result
425− throwIO $ QueryError ("execute resulted in " ++ show ncols ++
426− "-column result") q
427− PQ.CopyOut ->
428− throwIO $ QueryError "execute: COPY TO is not supported" q
429− PQ.CopyIn ->
430− throwIO $ QueryError "execute: COPY FROM is not supported" q
431− PQ.BadResponse -> throwResultError "execute" result status
432− PQ.NonfatalError -> throwResultError "execute" result status
433− PQ.FatalError -> throwResultError "execute" result status
434− where
435− mkInteger str = B8.foldl' delta 0 str
436− where
437− delta acc c =
438− if '0' <= c && c <= '9'
439− then 10 * acc + fromIntegral (ord c - ord '0')
440− else error ("finishExecute: not an int: " ++ B8.unpack str)
441−
442−throwResultError :: ByteString -> PQ.Result -> PQ.ExecStatus -> IO a
443−throwResultError _ result status = do
444− errormsg <- fromMaybe "" <$>
445− PQ.resultErrorField result PQ.DiagMessagePrimary
446− detail <- fromMaybe "" <$>
447− PQ.resultErrorField result PQ.DiagMessageDetail
448− hint <- fromMaybe "" <$>
449− PQ.resultErrorField result PQ.DiagMessageHint
450− state' <- maybe "" id <$> PQ.resultErrorField result PQ.DiagSqlstate
451− throwIO $ SqlError { sqlState = state'
452− , sqlExecStatus = status
453− , sqlErrorMsg = errormsg
454− , sqlErrorDetail = detail
455− , sqlErrorHint = hint }
456−
457−disconnectedError :: SqlError
458−disconnectedError = fatalError "connection disconnected"
194+ Nothing -> do
195+ msg <- maybe "execute error" id <$> PQ.errorMessage h
196+ throwIO $ SqlError { sqlNativeError = -1 -- FIXME?
197+ , sqlErrorMsg = msg
198+ , sqlState = "" }
199+ Just res -> do
200+ return res
201+
202+disconnectedError = SqlError {
203+ sqlNativeError = -1,
204+ sqlErrorMsg = "connection disconnected",
205+ sqlState = ""
206+ }
459207
460208-- | Atomically perform an action with the database handle, if there is one.
461209withConnection :: Connection -> (PQ.Connection -> IO a) -> IO a
@@ -478,160 +226,21 @@ newNullConnection :: IO Connection
478226newNullConnection = do
479227 connectionHandle <- newMVar =<< PQ.newNullConnection
480228 connectionObjects <- newMVar IntMap.empty
481− connectionTempNameCounter <- newIORef 0
482229 return Connection{..}
483230
231+data RawResult = RawResult { rawField :: Field, rawData :: Maybe ByteString }
232+
484233data Row = Row {
485234 row :: {-# UNPACK #-} !PQ.Row
235+ , typenames :: !(V.Vector ByteString)
486236 , rowresult :: !PQ.Result
487237 }
488238
489−newtype RowParser a = RP { unRP :: ReaderT Row (StateT PQ.Column Conversion) a }
239+newtype RowParser a = RP { unRP :: ReaderT Row (StateT PQ.Column Ok) a }
490240 deriving ( Functor, Applicative, Alternative, Monad )
491241
492−liftRowParser :: IO a -> RowParser a
493−liftRowParser = RP . lift . lift . liftConversion
494−
495−newtype Conversion a = Conversion { runConversion :: Connection -> IO (Ok a) }
496−
497−liftConversion :: IO a -> Conversion a
498−liftConversion m = Conversion (\_ -> Ok <$> m)
499−
500−instance Functor Conversion where
501− fmap f m = Conversion $ \conn -> (fmap . fmap) f (runConversion m conn)
502−
503−instance Applicative Conversion where
504− pure a = Conversion $ \_conn -> pure (pure a)
505− mf <*> ma = Conversion $ \conn -> do
506− okf <- runConversion mf conn
507− case okf of
508− Ok f -> (fmap . fmap) f (runConversion ma conn)
509− Errors errs -> return (Errors errs)
510−
511−instance Alternative Conversion where
512− empty = Conversion $ \_conn -> pure empty
513− ma <|> mb = Conversion $ \conn -> do
514− oka <- runConversion ma conn
515− case oka of
516− Ok _ -> return oka
517− Errors _ -> (oka <|>) <$> runConversion mb conn
518−
519−instance Monad Conversion where
520− m >>= f = Conversion $ \conn -> do
521− oka <- runConversion m conn
522− case oka of
523− Ok a -> runConversion (f a) conn
524− Errors err -> return (Errors err)
525−
526−instance MonadPlus Conversion where
527− mzero = empty
528− mplus = (<|>)
529−
530−conversionMap :: (Ok a -> Ok b) -> Conversion a -> Conversion b
531−conversionMap f m = Conversion $ \conn -> f <$> runConversion m conn
532−
533−conversionError :: Exception err => err -> Conversion a
534−conversionError err = Conversion $ \_ -> return (Errors [toException err])
535−
536−newTempName :: Connection -> IO Query
537−newTempName Connection{..} = do
538− !n <- atomicModifyIORef connectionTempNameCounter
539− (\n -> let !n' = n+1 in (n', n'))
540− return $! Query $ B8.pack $ "temp" ++ show n
541−
542−-- FIXME? What error should getNotification and getCopyData throw?
543−fdError :: ByteString -> IOError
544−fdError funcName = IOError {
545− ioe_handle = Nothing,
546− ioe_type = ResourceVanished,
547− ioe_location = B8.unpack funcName,
548− ioe_description = "failed to fetch file descriptor",
549− ioe_errno = Nothing,
550− ioe_filename = Nothing
551− }
552−
553−
554−libPQError :: ByteString -> IOError
555−libPQError desc = IOError {
556− ioe_handle = Nothing,
557− ioe_type = OtherError,
558− ioe_location = "libpq",
559− ioe_description = B8.unpack desc,
560− ioe_errno = Nothing,
561− ioe_filename = Nothing
562− }
563−
564−throwLibPQError :: PQ.Connection -> ByteString -> IO a
565−throwLibPQError conn default_desc = do
566− msg <- maybe default_desc id <$> PQ.errorMessage conn
567− throwIO $! libPQError msg
568−
569−
570−fmtError :: String -> Query -> [Action] -> a
571−fmtError msg q xs = throw FormatError {
572− fmtMessage = msg
573− , fmtQuery = q
574− , fmtParams = map twiddle xs
575− }
576− where twiddle (Plain b) = toByteString b
577− twiddle (Escape s) = s
578− twiddle (EscapeByteA s) = s
579− twiddle (EscapeIdentifier s) = s
580− twiddle (Many ys) = B.concat (map twiddle ys)
581−
582−fmtErrorBs :: Query -> [Action] -> ByteString -> a
583−fmtErrorBs q xs msg = fmtError (T.unpack $ TE.decodeUtf8 msg) q xs
584−
585−-- | Quote bytestring or throw 'FormatError'
586−quote :: Query -> [Action] -> Either ByteString ByteString -> Builder
587−quote q xs = either (fmtErrorBs q xs) (inQuotes . byteString)
588−
589−buildAction :: Connection -- ^ Connection for string escaping
590− -> Query -- ^ Query for message error
591− -> [Action] -- ^ List of parameters for message error
592− -> Action -- ^ Action to build
593− -> IO Builder
594−buildAction _ _ _ (Plain b) = pure b
595−buildAction conn q xs (Escape s) = quote q xs <$> escapeStringConn conn s
596−buildAction conn q xs (EscapeByteA s) = quote q xs <$> escapeByteaConn conn s
597−buildAction conn q xs (EscapeIdentifier s) =
598− either (fmtErrorBs q xs) byteString <$> escapeIdentifier conn s
599−buildAction conn q xs (Many ys) =
600− mconcat <$> mapM (buildAction conn q xs) ys
601−
602−checkError :: PQ.Connection -> Maybe a -> IO (Either ByteString a)
603−checkError _ (Just x) = return $ Right x
604−checkError c Nothing = Left . maybe "" id <$> PQ.errorMessage c
605−
606−escapeWrap :: (PQ.Connection -> ByteString -> IO (Maybe ByteString))
607− -> Connection
608− -> ByteString
609− -> IO (Either ByteString ByteString)
610−escapeWrap f conn s =
611− withConnection conn $ \c ->
612− f c s >>= checkError c
613−
614−escapeStringConn :: Connection -> ByteString -> IO (Either ByteString ByteString)
615−escapeStringConn = escapeWrap PQ.escapeStringConn
616−
617−escapeIdentifier :: Connection -> ByteString -> IO (Either ByteString ByteString)
618−escapeIdentifier = escapeWrap PQ.escapeIdentifier
619−
620−escapeByteaConn :: Connection -> ByteString -> IO (Either ByteString ByteString)
621−escapeByteaConn = escapeWrap PQ.escapeByteaConn
622−
623−breakOnSingleQuestionMark :: ByteString -> (ByteString, ByteString)
624−breakOnSingleQuestionMark b = go (B8.empty, b)
625− where go (x,bs) = (x `B8.append` x',bs')
626− -- seperate from first QM
627− where tup@(noQ, restWithQ) = B8.break (=='?') bs
628− -- if end of query, just return
629− -- else check for second QM in 'go2'
630− (x', bs') = maybe tup go2 $
631− -- drop found QM and peek at next char
632− B8.uncons restWithQ >>= B8.uncons . snd
633− -- another QM after the first means:
634− -- take literal QM and keep going.
635− go2 ('?', t2) = go (noQ `B8.snoc` '?',t2)
636− -- Anything else means
637− go2 _ = tup
242+getvalue :: PQ.Result -> PQ.Row -> PQ.Column -> Maybe ByteString
243+getvalue result row col = unsafePerformIO (PQ.getvalue result row col)
244+
245+nfields :: PQ.Result -> PQ.Column
246+nfields result = unsafePerformIO (PQ.nfields result)
src/Database/PostgreSQL/Simple/Internal/PQResultUtils.hsdeleted−123
@@ -1,123 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−
3−------------------------------------------------------------------------------
4−-- |
5−-- Module: Database.PostgreSQL.Simple.Internal.PQResultUtils
6−-- Copyright: (c) 2011 MailRank, Inc.
7−-- (c) 2011-2012 Leon P Smith
8−-- License: BSD3
9−-- Maintainer: Leon P Smith <leon@melding-monads.com>
10−-- Stability: experimental
11−--
12−------------------------------------------------------------------------------
13−
14−
15−module Database.PostgreSQL.Simple.Internal.PQResultUtils
16− ( finishQueryWith
17− , finishQueryWithV
18− , finishQueryWithVU
19− , getRowWith
20− ) where
21−
22−import Control.Exception as E
23−import Data.ByteString (ByteString)
24−import Data.Foldable (for_)
25−import Database.PostgreSQL.Simple.FromField (ResultError(..))
26−import Database.PostgreSQL.Simple.Ok
27−import Database.PostgreSQL.Simple.Types (Query(..))
28−import Database.PostgreSQL.Simple.Internal as Base hiding (result, row)
29−import Database.PostgreSQL.Simple.TypeInfo
30−import qualified Database.PostgreSQL.LibPQ as PQ
31−import qualified Data.ByteString.Char8 as B
32−import qualified Data.Vector as V
33−import qualified Data.Vector.Mutable as MV
34−import qualified Data.Vector.Unboxed as VU
35−import qualified Data.Vector.Unboxed.Mutable as MVU
36−import Control.Monad.Trans.Reader
37−import Control.Monad.Trans.State.Strict
38−
39−finishQueryWith :: RowParser r -> Connection -> Query -> PQ.Result -> IO [r]
40−finishQueryWith parser conn q result = finishQueryWith' q result $ do
41− nrows <- PQ.ntuples result
42− ncols <- PQ.nfields result
43− forM' 0 (nrows-1) $ \row ->
44− getRowWith parser row ncols conn result
45−
46−finishQueryWithV :: RowParser r -> Connection -> Query -> PQ.Result -> IO (V.Vector r)
47−finishQueryWithV parser conn q result = finishQueryWith' q result $ do
48− nrows <- PQ.ntuples result
49− let PQ.Row nrows' = nrows
50− ncols <- PQ.nfields result
51− mv <- MV.unsafeNew (fromIntegral nrows')
52− for_ [ 0 .. nrows-1 ] $ \row -> do
53− let PQ.Row row' = row
54− value <- getRowWith parser row ncols conn result
55− MV.unsafeWrite mv (fromIntegral row') value
56− V.unsafeFreeze mv
57−
58−finishQueryWithVU :: VU.Unbox r => RowParser r -> Connection -> Query -> PQ.Result -> IO (VU.Vector r)
59−finishQueryWithVU parser conn q result = finishQueryWith' q result $ do
60− nrows <- PQ.ntuples result
61− let PQ.Row nrows' = nrows
62− ncols <- PQ.nfields result
63− mv <- MVU.unsafeNew (fromIntegral nrows')
64− for_ [ 0 .. nrows-1 ] $ \row -> do
65− let PQ.Row row' = row
66− value <- getRowWith parser row ncols conn result
67− MVU.unsafeWrite mv (fromIntegral row') value
68− VU.unsafeFreeze mv
69−
70−finishQueryWith' :: Query -> PQ.Result -> IO a -> IO a
71−finishQueryWith' q result k = do
72− status <- PQ.resultStatus result
73− case status of
74− PQ.TuplesOk -> k
75− PQ.EmptyQuery -> queryErr "query: Empty query"
76− PQ.CommandOk -> queryErr "query resulted in a command response (did you mean to use `execute` or forget a RETURNING?)"
77− PQ.CopyOut -> queryErr "query: COPY TO is not supported"
78− PQ.CopyIn -> queryErr "query: COPY FROM is not supported"
79− PQ.CopyBoth -> queryErr "query: COPY BOTH is not supported"
80− PQ.SingleTuple -> queryErr "query: single-row mode is not supported"
81− PQ.BadResponse -> throwResultError "query" result status
82− PQ.NonfatalError -> throwResultError "query" result status
83− PQ.FatalError -> throwResultError "query" result status
84− where
85− queryErr msg = throwIO $ QueryError msg q
86−
87−getRowWith :: RowParser r -> PQ.Row -> PQ.Column -> Connection -> PQ.Result -> IO r
88−getRowWith parser row ncols conn result = do
89− let rw = Row row result
90− let unCol (PQ.Col x) = fromIntegral x :: Int
91− okvc <- runConversion (runStateT (runReaderT (unRP parser) rw) 0) conn
92− case okvc of
93− Ok (val,col) | col == ncols -> return val
94− | otherwise -> do
95− vals <- forM' 0 (ncols-1) $ \c -> do
96− tinfo <- getTypeInfo conn =<< PQ.ftype result c
97− v <- PQ.getvalue result row c
98− return ( tinfo
99− , fmap ellipsis v )
100− throw (ConversionFailed
101− (show (unCol ncols) ++ " values: " ++ show vals)
102− Nothing
103− ""
104− (show (unCol col) ++ " slots in target type")
105− "mismatch between number of columns to convert and number in target type")
106− Errors [] -> throwIO $ ConversionFailed "" Nothing "" "" "unknown error"
107− Errors [x] -> throwIO x
108− Errors xs -> throwIO $ ManyErrors xs
109−
110−ellipsis :: ByteString -> ByteString
111−ellipsis bs
112− | B.length bs > 15 = B.take 10 bs `B.append` "[...]"
113− | otherwise = bs
114−
115−forM' :: (Ord n, Num n) => n -> n -> (n -> IO a) -> IO [a]
116−forM' lo hi m = loop hi []
117− where
118− loop !n !as
119− | n < lo = return as
120− | otherwise = do
121− a <- m n
122− loop (n-1) (a:as)
123−{-# INLINE forM' #-}
src/Database/PostgreSQL/Simple/LargeObjects.hs+7−14
@@ -1,23 +1,13 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
13-----------------------------------------------------------------------------
24-- |
35-- Module : Database.PostgreSQL.Simple.LargeObjects
4−-- Copyright : (c) 2011-2012 Leon P Smith
6+-- Copyright : (c) 2011 Leon P Smith
57-- License : BSD3
68--
79-- Maintainer : leon@melding-monads.com
810--
9−-- Support for PostgreSQL's Large Objects; see
10−-- <https://www.postgresql.org/docs/9.5/static/largeobjects.html> for more
11−-- information.
12−--
13−-- Note that Large Object File Descriptors are only valid within a single
14−-- database transaction, so if you are interested in using anything beyond
15−-- 'loCreat', 'loCreate', and 'loUnlink', you will need to run the entire
16−-- sequence of functions in a transaction. As 'loImport' and 'loExport'
17−-- are simply C functions that call 'loCreat', 'loOpen', 'loRead', and
18−-- 'loWrite', and do not perform any transaction handling themselves,
19−-- they also need to be wrapped in an explicit transaction.
20−--
2111-----------------------------------------------------------------------------
2212
2313module Database.PostgreSQL.Simple.LargeObjects
@@ -46,6 +36,7 @@ import qualified Data.ByteString as B
4636import Database.PostgreSQL.LibPQ (Oid(..),LoFd(..))
4737import qualified Database.PostgreSQL.LibPQ as PQ
4838import Database.PostgreSQL.Simple.Internal
39+import Foreign.C.Types (CInt)
4940import System.IO (IOMode(..),SeekMode(..))
5041
5142liftPQ :: B.ByteString -> Connection -> (PQ.Connection -> IO (Maybe a)) -> IO a
@@ -54,7 +45,9 @@ liftPQ str conn m = withConnection conn $ \c -> do
5445 case res of
5546 Nothing -> do
5647 msg <- maybe str id <$> PQ.errorMessage c
57− throwIO $ fatalError msg
48+ throwIO $ SqlError { sqlNativeError = -1 -- FIXME?
49+ , sqlErrorMsg = msg
50+ , sqlState = "" }
5851 Just x -> return x
5952
6053loCreat :: Connection -> IO Oid
src/Database/PostgreSQL/Simple/Newtypes.hsdeleted−49
@@ -1,49 +0,0 @@
1−{-# LANGUAGE DeriveFunctor #-}
2−{-# LANGUAGE DeriveDataTypeable #-}
3−-- | Module with newtypes suitable to usage with @DerivingVia@ or standalone.
4−--
5−-- The newtypes are named after packages they wrap.
6−module Database.PostgreSQL.Simple.Newtypes (
7− Aeson (..), getAeson,
8−) where
9−
10−import Data.Typeable (Typeable)
11−import Database.PostgreSQL.Simple.ToField (ToField (..))
12−import Database.PostgreSQL.Simple.FromField (FromField (..), fromJSONField)
13−
14−import qualified Data.Aeson as Aeson
15−
16−-------------------------------------------------------------------------------
17−-- aeson
18−-------------------------------------------------------------------------------
19−
20−-- | A newtype wrapper with 'ToField' and 'FromField' instances
21−-- based on 'Aeson.ToJSON' and 'Aeson.FromJSON' type classes from @aeson@.
22−--
23−-- Example using @DerivingVia@:
24−--
25−-- @
26−-- data Foo = Foo Int String
27−-- deriving stock (Eq, Show, Generic) -- GHC built int
28−-- deriving anyclass ('Aeson.FromJSON', 'Aeson.ToJSON') -- Derived using GHC Generics
29−-- deriving ('ToField', 'FromField') via 'Aeson' Foo -- DerivingVia
30−-- @
31−--
32−-- Example using 'Aeson' newtype directly, for more ad-hoc queries
33−--
34−-- @
35−-- execute conn "INSERT INTO tbl (fld) VALUES (?)" (Only ('Aeson' x))
36−-- @
37−--
38−-- @since 0.6.3
39−newtype Aeson a = Aeson a
40− deriving (Eq, Show, Read, Typeable, Functor)
41−
42−getAeson :: Aeson a -> a
43−getAeson (Aeson a) = a
44−
45−instance Aeson.ToJSON a => ToField (Aeson a) where
46− toField = toField . Aeson.encode . getAeson
47−
48−instance (Aeson.FromJSON a, Typeable a) => FromField (Aeson a) where
49− fromField f bs = fmap Aeson (fromJSONField f bs)
src/Database/PostgreSQL/Simple/Notification.hs+29−120
@@ -1,145 +1,54 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE NamedFieldPuns #-}
3−{-# LANGUAGE RecordWildCards #-}
1+{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}
42
53-----------------------------------------------------------------------------
64-- |
75-- Module : Database.PostgreSQL.Simple.Notification
8−-- Copyright : (c) 2011-2015 Leon P Smith
9−-- (c) 2012 Joey Adams
6+-- Copyright : (c) 2011 Leon P Smith
107-- License : BSD3
118--
129-- Maintainer : leon@melding-monads.com
1310-- Stability : experimental
1411--
15−-- Support for receiving asynchronous notifications via PostgreSQL's
16−-- Listen/Notify mechanism. See
17−-- <https://www.postgresql.org/docs/9.5/static/sql-notify.html> for more
18−-- information.
19−--
20−-- Note that on Windows, @getNotification@ currently uses a polling loop
21−-- of 1 second to check for more notifications, due to some inadequacies
22−-- in GHC's IO implementation and interface on that platform. See GHC
23−-- issue #7353 for more information. While this workaround is less than
24−-- ideal, notifications are still better than polling the database directly.
25−-- Notifications do not create any extra work for the backend, and are
26−-- likely cheaper on the client side as well.
27−--
28−-- <https://hackage.haskell.org/trac/ghc/ticket/7353>
29−--
3012-----------------------------------------------------------------------------
3113
3214module Database.PostgreSQL.Simple.Notification
3315 ( Notification(..)
3416 , getNotification
35− , getNotificationNonBlocking
36− , getBackendPID
3717 ) where
3818
39−import Control.Monad ( join, void )
40−import Control.Exception ( throwIO, catch )
19+import Control.Concurrent ( threadWaitRead )
20+import Control.Monad ( when )
4121import qualified Data.ByteString as B
42−import qualified Data.ByteString.Char8 as B8
4322import Database.PostgreSQL.Simple.Internal
4423import qualified Database.PostgreSQL.LibPQ as PQ
4524import System.Posix.Types ( CPid )
46−import GHC.IO.Exception ( ioe_location )
47−
48−#if defined(mingw32_HOST_OS)
49−import Control.Concurrent ( threadDelay )
50−#else
51−import GHC.Conc ( atomically )
52−import Control.Concurrent ( threadWaitReadSTM )
53−#endif
5425
55−data Notification = Notification
56− { notificationPid :: {-# UNPACK #-} !CPid
57− , notificationChannel :: {-# UNPACK #-} !B.ByteString
58− , notificationData :: {-# UNPACK #-} !B.ByteString
59− } deriving (Show, Eq)
26+data Notification = Notification
27+ { notificationPid :: CPid
28+ , notificationChannel :: B.ByteString
29+ , notificationData :: B.ByteString
30+ }
6031
61−convertNotice :: PQ.Notify -> Notification
62−convertNotice PQ.Notify{..}
63− = Notification { notificationPid = notifyBePid
64− , notificationChannel = notifyRelname
65− , notificationData = notifyExtra }
66−
67−-- | Returns a single notification. If no notifications are available,
68−-- 'getNotification' blocks until one arrives.
69−--
70−-- It is safe to call 'getNotification' on a connection that is concurrently
71−-- being used for other purposes, note however that PostgreSQL does not
72−-- deliver notifications while a connection is inside a transaction.
32+errfd = "Database.PostgreSQL.Simple.Notification.getNotification: \
33+ \failed to fetch file descriptor"
7334
7435getNotification :: Connection -> IO Notification
75−getNotification conn = join $ withConnection conn fetch
36+getNotification = loop False
7637 where
77− funcName = "Database.PostgreSQL.Simple.Notification.getNotification"
78−
79− fetch c = do
80− mmsg <- PQ.notifies c
81− case mmsg of
82− Just msg -> return (return $! convertNotice msg)
83− Nothing -> do
84− mfd <- PQ.socket c
85− case mfd of
86− Nothing -> return (throwIO $! fdError funcName)
87−#if defined(mingw32_HOST_OS)
88− -- threadWaitRead doesn't work for sockets on Windows, so just
89− -- poll for input every second (PQconsumeInput is non-blocking).
90− --
91− -- We could call select(), but FFI calls can't be interrupted
92− -- with async exceptions, whereas threadDelay can.
93− Just _fd -> do
94− return (threadDelay 1000000 >> loop)
95−#else
96− -- This case fixes the race condition above. By registering
97− -- our interest in the descriptor before we drop the lock,
98− -- there is no opportunity for the descriptor index to be
99− -- reallocated on us.
100− --
101− -- (That is, assuming there isn't concurrently executing
102− -- code that manipulates the descriptor without holding
103− -- the lock... but such a major bug is likely to exhibit
104− -- itself in an at least somewhat more dramatic fashion.)
105− Just fd -> do
106− (waitRead, _) <- threadWaitReadSTM fd
107− return $ do
108− atomically waitRead `catch` (throwIO . setIOErrorLocation)
109− loop
110−#endif
111−
112− loop = join $ withConnection conn $ \c -> do
113− void $ PQ.consumeInput c
114− fetch c
115−
116− setIOErrorLocation :: IOError -> IOError
117− setIOErrorLocation err = err { ioe_location = B8.unpack funcName }
118−
119−
120−-- | Non-blocking variant of 'getNotification'. Returns a single notification,
121−-- if available. If no notifications are available, returns 'Nothing'.
122−
123−getNotificationNonBlocking :: Connection -> IO (Maybe Notification)
124−getNotificationNonBlocking conn =
125− withConnection conn $ \c -> do
126− mmsg <- PQ.notifies c
127− case mmsg of
128− Just msg -> return $! Just $! convertNotice msg
129− Nothing -> do
130− _ <- PQ.consumeInput c
131− mmsg' <- PQ.notifies c
132− case mmsg' of
133− Just msg -> return $! Just $! convertNotice msg
134− Nothing -> return Nothing
135−
136−-- | Returns the process 'CPid' of the backend server process
137−-- handling this connection.
138−--
139−-- The backend PID is useful for debugging purposes and for comparison
140−-- to NOTIFY messages (which include the PID of the notifying backend
141−-- process). Note that the PID belongs to a process executing on the
142−-- database server host, not the local host!
143−
144−getBackendPID :: Connection -> IO CPid
145−getBackendPID conn = withConnection conn PQ.backendPID
38+ loop doConsume conn = do
39+ res <- withConnection conn $ \c -> do
40+ when doConsume (PQ.consumeInput c >> return ())
41+ mmsg <- PQ.notifies c
42+ case mmsg of
43+ Nothing -> do
44+ mfd <- PQ.socket c
45+ case mfd of
46+ Nothing -> fail errfd
47+ Just fd -> return (Left fd)
48+ Just x -> return (Right x)
49+ case res of
50+ Left fd -> threadWaitRead fd >> loop True conn
51+ Right PQ.Notify{..} -> do
52+ return Notification { notificationPid = notifyBePid
53+ , notificationChannel = notifyRelname
54+ , notificationData = notifyExtra }
src/Database/PostgreSQL/Simple/Ok.hs+12−47
@@ -1,34 +1,5 @@
11{-# LANGUAGE DeriveDataTypeable #-}
22{-# LANGUAGE DeriveFunctor #-}
3−{-# LANGUAGE CPP #-}
4−
5−------------------------------------------------------------------------------
6−-- |
7−-- Module : Database.PostgreSQL.Simple.Ok
8−-- Copyright : (c) 2012-2015 Leon P Smith
9−-- License : BSD3
10−--
11−-- Maintainer : leon@melding-monads.com
12−-- Stability : experimental
13−--
14−-- The 'Ok' type is a simple error handler, basically equivalent to
15−-- @Either [SomeException]@. This type (without the list) was used to
16−-- handle conversion errors in early versions of postgresql-simple.
17−--
18−-- One of the primary reasons why this type was introduced is that
19−-- @Either SomeException@ had not been provided an instance for 'Alternative',
20−-- and it would have been a bad idea to provide an orphaned instance for a
21−-- commonly-used type and typeclass included in @base@.
22−--
23−-- Extending the failure case to a list of 'SomeException's enables a
24−-- more sensible 'Alternative' instance definitions: '<|>' concatenates
25−-- the list of exceptions when both cases fail, and 'empty' is defined as
26−-- 'Errors []'. Though '<|>' one could pick one of two exceptions, and
27−-- throw away the other, and have 'empty' provide a generic exception,
28−-- this avoids cases where 'empty' overrides a more informative exception
29−-- and allows you to see all the different ways your computation has failed.
30−--
31−------------------------------------------------------------------------------
323
334module Database.PostgreSQL.Simple.Ok where
345
@@ -37,17 +8,16 @@ import Control.Exception
378import Control.Monad(MonadPlus(..))
389import Data.Typeable
3910
40−import qualified Control.Monad.Fail as Fail
11+newtype ManyErrors = ManyErrors [SomeException]
12+ deriving (Show, Typeable)
13+
14+instance Exception ManyErrors
4115
42−-- FIXME: [SomeException] should probably be something else, maybe
43−-- a difference list (or a tree?)
16+-- FIXME: [SomeException] should probably be a difference list
4417
4518data Ok a = Errors [SomeException] | Ok !a
4619 deriving(Show, Typeable, Functor)
4720
48−-- | Two 'Errors' cases are considered equal, regardless of what the
49−-- list of exceptions looks like.
50−
5121instance Eq a => Eq (Ok a) where
5222 Errors _ == Errors _ = True
5323 Ok a == Ok b = a == b
@@ -67,24 +37,19 @@ instance Alternative Ok where
6737 Errors _ <|> b@(Ok _) = b
6838 Errors as <|> Errors bs = Errors (as ++ bs)
6939
40+
7041instance MonadPlus Ok where
7142 mzero = empty
7243 mplus = (<|>)
7344
7445instance Monad Ok where
46+ return = Ok
47+
7548 Errors es >>= _ = Errors es
7649 Ok a >>= f = f a
50+ -- TODO: add a definition for "fail", akin to
7751
78−#if !(MIN_VERSION_base(4,13,0))
79− fail = Fail.fail
80−#endif
52+ -- fail str = Errors [SomeException (error str)]
8153
82−instance Fail.MonadFail Ok where
83− fail str = Errors [SomeException (ErrorCall str)]
84−
85−-- | a way to reify a list of exceptions into a single exception
86−
87−newtype ManyErrors = ManyErrors [SomeException]
88− deriving (Show, Typeable)
89−
90−instance Exception ManyErrors
54+ -- but *correct*, as this will throw an exception if you try to
55+ -- examine the exception.
src/Database/PostgreSQL/Simple/Param.hsnew file+206
@@ -0,0 +1,206 @@
1+{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, FlexibleInstances,
2+ OverloadedStrings #-}
3+
4+-- |
5+-- Module: Database.PostgreSQL.Simple.Param
6+-- Copyright: (c) 2011 MailRank, Inc.
7+-- (c) 2011 Leon P Smith
8+-- License: BSD3
9+-- Maintainer: Leon P Smith <leon@melding-monads.com>
10+-- Stability: experimental
11+-- Portability: portable
12+--
13+-- The 'Param' typeclass, for rendering a parameter to a SQL query.
14+
15+module Database.PostgreSQL.Simple.Param
16+ (
17+ Action(..)
18+ , Param(..)
19+ , inQuotes
20+ ) where
21+
22+import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString,
23+ toByteString)
24+import Blaze.ByteString.Builder.Char8 (fromChar)
25+import Blaze.Text (integral, double, float)
26+import Data.ByteString (ByteString)
27+import qualified Data.ByteString.Base16 as B16
28+import qualified Data.ByteString.Base16.Lazy as L16
29+import Data.Int (Int8, Int16, Int32, Int64)
30+import Data.List (intersperse)
31+import Data.Monoid (mappend)
32+import Data.Time.Calendar (Day, showGregorian)
33+import Data.Time.Clock (UTCTime)
34+import Data.Time.Format (formatTime)
35+import Data.Time.LocalTime (TimeOfDay)
36+import Data.Typeable (Typeable)
37+import Data.Word (Word, Word8, Word16, Word32, Word64)
38+import Database.PostgreSQL.Simple.Types (Binary(..), In(..), Null)
39+import System.Locale (defaultTimeLocale)
40+import qualified Blaze.ByteString.Builder.Char.Utf8 as Utf8
41+import qualified Data.ByteString as SB
42+import qualified Data.ByteString.Lazy as LB
43+import qualified Data.Text as ST
44+import qualified Data.Text.Encoding as ST
45+import qualified Data.Text.Lazy as LT
46+import qualified Database.PostgreSQL.LibPQ as PQ
47+
48+-- | How to render an element when substituting it into a query.
49+data Action =
50+ Plain Builder
51+ -- ^ Render without escaping or quoting. Use for non-text types
52+ -- such as numbers, when you are /certain/ that they will not
53+ -- introduce formatting vulnerabilities via use of characters such
54+ -- as spaces or \"@'@\".
55+ | Escape ByteString
56+ -- ^ Escape and enclose in quotes before substituting. Use for all
57+ -- text-like types, and anything else that may contain unsafe
58+ -- characters when rendered.
59+ | Many [Action]
60+ -- ^ Concatenate a series of rendering actions.
61+ deriving (Typeable)
62+
63+instance Show Action where
64+ show (Plain b) = "Plain " ++ show (toByteString b)
65+ show (Escape b) = "Escape " ++ show b
66+ show (Many b) = "Many " ++ show b
67+
68+-- | A type that may be used as a single parameter to a SQL query.
69+class Param a where
70+ render :: a -> Action
71+ -- ^ Prepare a value for substitution into a query string.
72+
73+instance Param Action where
74+ render a = a
75+ {-# INLINE render #-}
76+
77+instance (Param a) => Param (Maybe a) where
78+ render Nothing = renderNull
79+ render (Just a) = render a
80+ {-# INLINE render #-}
81+
82+instance (Param a) => Param (In [a]) where
83+ render (In []) = Plain $ fromByteString "(null)"
84+ render (In xs) = Many $
85+ Plain (fromChar '(') :
86+ (intersperse (Plain (fromChar ',')) . map render $ xs) ++
87+ [Plain (fromChar ')')]
88+
89+instance Param (Binary SB.ByteString) where
90+ render (Binary bs) = Plain $ fromByteString "'\\x" `mappend`
91+ fromByteString (B16.encode bs) `mappend`
92+ fromChar '\''
93+
94+instance Param (Binary LB.ByteString) where
95+ render (Binary bs) = Plain $ fromByteString "'\\x" `mappend`
96+ fromLazyByteString (L16.encode bs) `mappend`
97+ fromChar '\''
98+
99+renderNull :: Action
100+renderNull = Plain (fromByteString "null")
101+
102+instance Param Null where
103+ render _ = renderNull
104+ {-# INLINE render #-}
105+
106+instance Param Bool where
107+ render True = Plain (fromByteString "true")
108+ render False = Plain (fromByteString "false")
109+ {-# INLINE render #-}
110+
111+instance Param Int8 where
112+ render = Plain . integral
113+ {-# INLINE render #-}
114+
115+instance Param Int16 where
116+ render = Plain . integral
117+ {-# INLINE render #-}
118+
119+instance Param Int32 where
120+ render = Plain . integral
121+ {-# INLINE render #-}
122+
123+instance Param Int where
124+ render = Plain . integral
125+ {-# INLINE render #-}
126+
127+instance Param Int64 where
128+ render = Plain . integral
129+ {-# INLINE render #-}
130+
131+instance Param Integer where
132+ render = Plain . integral
133+ {-# INLINE render #-}
134+
135+instance Param Word8 where
136+ render = Plain . integral
137+ {-# INLINE render #-}
138+
139+instance Param Word16 where
140+ render = Plain . integral
141+ {-# INLINE render #-}
142+
143+instance Param Word32 where
144+ render = Plain . integral
145+ {-# INLINE render #-}
146+
147+instance Param Word where
148+ render = Plain . integral
149+ {-# INLINE render #-}
150+
151+instance Param Word64 where
152+ render = Plain . integral
153+ {-# INLINE render #-}
154+
155+instance Param PQ.Oid where
156+ render = Plain . integral . \(PQ.Oid x) -> x
157+ {-# INLINE render #-}
158+
159+instance Param Float where
160+ render v | isNaN v || isInfinite v = Plain (inQuotes (float v))
161+ | otherwise = Plain (float v)
162+ {-# INLINE render #-}
163+
164+instance Param Double where
165+ render v | isNaN v || isInfinite v = Plain (inQuotes (double v))
166+ | otherwise = Plain (double v)
167+ {-# INLINE render #-}
168+
169+instance Param SB.ByteString where
170+ render = Escape
171+ {-# INLINE render #-}
172+
173+instance Param LB.ByteString where
174+ render = render . SB.concat . LB.toChunks
175+ {-# INLINE render #-}
176+
177+instance Param ST.Text where
178+ render = Escape . ST.encodeUtf8
179+ {-# INLINE render #-}
180+
181+instance Param [Char] where
182+ render = Escape . toByteString . Utf8.fromString
183+ {-# INLINE render #-}
184+
185+instance Param LT.Text where
186+ render = render . LT.toStrict
187+ {-# INLINE render #-}
188+
189+instance Param UTCTime where
190+ render = Plain . Utf8.fromString . formatTime defaultTimeLocale "'%F %T%Q+00'"
191+ {-# INLINE render #-}
192+
193+instance Param Day where
194+ render = Plain . inQuotes . Utf8.fromString . showGregorian
195+ {-# INLINE render #-}
196+
197+instance Param TimeOfDay where
198+ render = Plain . inQuotes . Utf8.fromString . show
199+ {-# INLINE render #-}
200+
201+-- | Surround a string with single-quote characters: \"@'@\"
202+--
203+-- This function /does not/ perform any other escaping.
204+inQuotes :: Builder -> Builder
205+inQuotes b = quote `mappend` b `mappend` quote
206+ where quote = Utf8.fromChar '\''
src/Database/PostgreSQL/Simple/QueryParams.hsnew file+85
@@ -0,0 +1,85 @@
1+-- |
2+-- Module: Database.PostgreSQL.Simple.QueryParams
3+-- Copyright: (c) 2011 MailRank, Inc.
4+-- (c) 2011 Leon P Smith
5+-- License: BSD3
6+-- Maintainer: Leon P Smith <leon@melding-monads.com>
7+-- Stability: experimental
8+-- Portability: portable
9+--
10+-- The 'QueryParams' typeclass, for rendering a collection of
11+-- parameters to a SQL query.
12+--
13+-- Predefined instances are provided for tuples containing up to ten
14+-- elements.
15+
16+module Database.PostgreSQL.Simple.QueryParams
17+ (
18+ QueryParams(..)
19+ ) where
20+
21+import Database.PostgreSQL.Simple.Param (Action(..), Param(..))
22+import Database.PostgreSQL.Simple.Types (Only(..))
23+
24+-- | A collection type that can be turned into a list of rendering
25+-- 'Action's.
26+--
27+-- Instances should use the 'render' method of the 'Param' class
28+-- to perform conversion of each element of the collection.
29+class QueryParams a where
30+ renderParams :: a -> [Action]
31+ -- ^ Render a collection of values.
32+
33+instance QueryParams () where
34+ renderParams _ = []
35+
36+instance (Param a) => QueryParams (Only a) where
37+ renderParams (Only v) = [render v]
38+
39+instance (Param a, Param b) => QueryParams (a,b) where
40+ renderParams (a,b) = [render a, render b]
41+
42+instance (Param a, Param b, Param c) => QueryParams (a,b,c) where
43+ renderParams (a,b,c) = [render a, render b, render c]
44+
45+instance (Param a, Param b, Param c, Param d) => QueryParams (a,b,c,d) where
46+ renderParams (a,b,c,d) = [render a, render b, render c, render d]
47+
48+instance (Param a, Param b, Param c, Param d, Param e)
49+ => QueryParams (a,b,c,d,e) where
50+ renderParams (a,b,c,d,e) =
51+ [render a, render b, render c, render d, render e]
52+
53+instance (Param a, Param b, Param c, Param d, Param e, Param f)
54+ => QueryParams (a,b,c,d,e,f) where
55+ renderParams (a,b,c,d,e,f) =
56+ [render a, render b, render c, render d, render e, render f]
57+
58+instance (Param a, Param b, Param c, Param d, Param e, Param f, Param g)
59+ => QueryParams (a,b,c,d,e,f,g) where
60+ renderParams (a,b,c,d,e,f,g) =
61+ [render a, render b, render c, render d, render e, render f, render g]
62+
63+instance (Param a, Param b, Param c, Param d, Param e, Param f, Param g,
64+ Param h)
65+ => QueryParams (a,b,c,d,e,f,g,h) where
66+ renderParams (a,b,c,d,e,f,g,h) =
67+ [render a, render b, render c, render d, render e, render f, render g,
68+ render h]
69+
70+instance (Param a, Param b, Param c, Param d, Param e, Param f, Param g,
71+ Param h, Param i)
72+ => QueryParams (a,b,c,d,e,f,g,h,i) where
73+ renderParams (a,b,c,d,e,f,g,h,i) =
74+ [render a, render b, render c, render d, render e, render f, render g,
75+ render h, render i]
76+
77+instance (Param a, Param b, Param c, Param d, Param e, Param f, Param g,
78+ Param h, Param i, Param j)
79+ => QueryParams (a,b,c,d,e,f,g,h,i,j) where
80+ renderParams (a,b,c,d,e,f,g,h,i,j) =
81+ [render a, render b, render c, render d, render e, render f, render g,
82+ render h, render i, render j]
83+
84+instance (Param a) => QueryParams [a] where
85+ renderParams = map render
src/Database/PostgreSQL/Simple/Range.hsdeleted−317
@@ -1,317 +0,0 @@
1−{-# LANGUAGE DeriveDataTypeable #-}
2−{-# LANGUAGE DeriveFunctor #-}
3−{-# LANGUAGE OverloadedStrings #-}
4−{-# LANGUAGE FlexibleInstances #-}
5−
6−------------------------------------------------------------------------------
7−-- |
8−-- Module: Database.PostgreSQL.Simple.Range
9−-- Copyright: (c) 2014-2015 Leonid Onokhov
10−-- (c) 2014-2015 Leon P Smith
11−-- License: BSD3
12−-- Maintainer: Leon P Smith <leon@melding-monads.com>
13−--
14−------------------------------------------------------------------------------
15−
16−module Database.PostgreSQL.Simple.Range
17− ( RangeBound(..)
18− , PGRange(..)
19− , empty
20− , isEmpty, isEmptyBy
21− , contains, containsBy
22− , fromFieldRange
23− ) where
24−
25−import Control.Applicative hiding (empty)
26−import Data.Attoparsec.ByteString.Char8 (Parser, parseOnly)
27−import qualified Data.Attoparsec.ByteString.Char8 as A
28−import qualified Data.ByteString as B
29−import Data.ByteString.Builder
30− ( Builder, byteString, lazyByteString, char8
31− , intDec, int8Dec, int16Dec, int32Dec, int64Dec, integerDec
32− , wordDec, word8Dec, word16Dec, word32Dec, word64Dec
33− , doubleDec, floatDec )
34−import Data.Int (Int16, Int32, Int64,
35− Int8)
36−import Data.Function (on)
37−import Data.Monoid (mempty)
38−import Data.Scientific (Scientific)
39−import qualified Data.Text.Lazy.Builder as LT
40−import qualified Data.Text.Lazy.Encoding as LT
41−import Data.Time.Compat (Day, LocalTime,
42− NominalDiffTime,
43− TimeOfDay, UTCTime,
44− ZonedTime,
45− zonedTimeToUTC)
46−import Data.Typeable (Typeable)
47−import Data.Word (Word, Word16, Word32,
48− Word64, Word8)
49−
50−import Database.PostgreSQL.Simple.Compat (scientificBuilder, (<>), toByteString)
51−import Database.PostgreSQL.Simple.FromField
52−import Database.PostgreSQL.Simple.Time
53− hiding (PosInfinity, NegInfinity)
54−-- import qualified Database.PostgreSQL.Simple.Time as Time
55−import Database.PostgreSQL.Simple.ToField
56−
57−-- | Represents boundary of a range
58−data RangeBound a = NegInfinity
59− | Inclusive !a
60− | Exclusive !a
61− | PosInfinity
62− deriving (Show, Typeable, Eq, Functor)
63−
64−-- | Generic range type
65−data PGRange a = PGRange !(RangeBound a) !(RangeBound a)
66− deriving (Show, Typeable, Functor)
67−
68−empty :: PGRange a
69−empty = PGRange PosInfinity NegInfinity
70−
71−instance Ord a => Eq (PGRange a) where
72− x == y = eq x y || (isEmpty x && isEmpty y)
73− where eq (PGRange a m) (PGRange b n) = a == b && m == n
74−
75−isEmptyBy :: (a -> a -> Ordering) -> PGRange a -> Bool
76−isEmptyBy cmp v =
77− case v of
78− (PGRange PosInfinity _) -> True
79− (PGRange _ NegInfinity) -> True
80− (PGRange NegInfinity _) -> False
81− (PGRange _ PosInfinity) -> False
82− (PGRange (Inclusive x) (Inclusive y)) -> cmp x y == GT
83− (PGRange (Inclusive x) (Exclusive y)) -> cmp x y /= LT
84− (PGRange (Exclusive x) (Inclusive y)) -> cmp x y /= LT
85− (PGRange (Exclusive x) (Exclusive y)) -> cmp x y /= LT
86−
87−-- | Is a range empty? If this returns 'True', then the 'contains'
88−-- predicate will always return 'False'. However, if this returns
89−-- 'False', it is not necessarily true that there exists a point for
90−-- which 'contains' returns 'True'.
91−-- Consider @'PGRange' ('Excludes' 2) ('Excludes' 3) :: PGRange Int@,
92−-- for example.
93−isEmpty :: Ord a => PGRange a -> Bool
94−isEmpty = isEmptyBy compare
95−
96−
97−-- | Does a range contain a given point? Note that in some cases, this may
98−-- not correspond exactly with a server-side computation. Consider @UTCTime@
99−-- for example, which has a resolution of a picosecond, whereas postgresql's
100−-- @timestamptz@ types have a resolution of a microsecond. Putting such
101−-- Haskell values into the database will result in them being rounded, which
102−-- can change the value of the containment predicate.
103−
104−contains :: Ord a => PGRange a -> (a -> Bool)
105−contains = containsBy compare
106−
107−containsBy :: (a -> a -> Ordering) -> PGRange a -> (a -> Bool)
108−containsBy cmp rng x =
109− case rng of
110− PGRange _lb NegInfinity -> False
111− PGRange lb ub -> checkLB lb x && checkUB ub x
112− where
113− checkLB lb y =
114− case lb of
115− NegInfinity -> True
116− PosInfinity -> False
117− Inclusive a -> cmp a y /= GT
118− Exclusive a -> cmp a y == LT
119−
120− checkUB ub y =
121− case ub of
122− NegInfinity -> False
123− PosInfinity -> True
124− Inclusive z -> cmp y z /= GT
125− Exclusive z -> cmp y z == LT
126−
127−lowerBound :: Parser (a -> RangeBound a)
128−lowerBound = (A.char '(' *> pure Exclusive) <|> (A.char '[' *> pure Inclusive)
129−{-# INLINE lowerBound #-}
130−
131−upperBound :: Parser (a -> RangeBound a)
132−upperBound = (A.char ')' *> pure Exclusive) <|> (A.char ']' *> pure Inclusive)
133−{-# INLINE upperBound #-}
134−
135−-- | Generic range parser
136−pgrange :: Parser (RangeBound B.ByteString, RangeBound B.ByteString)
137−pgrange = do
138− lb <- lowerBound
139− v1 <- (A.char ',' *> "") <|> (rangeElem (==',') <* A.char ',')
140− v2 <- rangeElem $ \c -> c == ')' || c == ']'
141− ub <- upperBound
142− A.endOfInput
143− let low = if B.null v1 then NegInfinity else lb v1
144− up = if B.null v2 then PosInfinity else ub v2
145− return (low, up)
146−
147−rangeElem :: (Char -> Bool) -> Parser B.ByteString
148−rangeElem end = (A.char '"' *> doubleQuoted)
149− <|> A.takeTill end
150−{-# INLINE rangeElem #-}
151−
152−-- | Simple double quoted value parser
153−doubleQuoted :: Parser B.ByteString
154−doubleQuoted = toByteString <$> go mempty
155− where
156− go acc = do
157− h <- byteString <$> A.takeTill (\c -> c == '\\' || c == '"')
158− let rest = do
159− start <- A.anyChar
160− case start of
161− '\\' -> do
162− c <- A.anyChar
163− go (acc <> h <> char8 c)
164− '"' -> (A.char '"' *> go (acc <> h <> char8 '"'))
165− <|> pure (acc <> h)
166− _ -> error "impossible in doubleQuoted"
167− rest
168−
169−rangeToBuilder :: Ord a => (a -> Builder) -> PGRange a -> Builder
170−rangeToBuilder = rangeToBuilderBy compare
171−
172−-- | Generic range to builder for plain values
173−rangeToBuilderBy :: (a -> a -> Ordering) -> (a -> Builder) -> PGRange a -> Builder
174−rangeToBuilderBy cmp f x =
175− if isEmptyBy cmp x
176− then byteString "'empty'"
177− else let (PGRange a b) = x
178− in buildLB a <> buildUB b
179− where
180− buildLB NegInfinity = byteString "'[,"
181− buildLB (Inclusive v) = byteString "'[\"" <> f v <> byteString "\","
182− buildLB (Exclusive v) = byteString "'(\"" <> f v <> byteString "\","
183− buildLB PosInfinity = error "impossible in rangeToBuilder"
184−
185− buildUB NegInfinity = error "impossible in rangeToBuilder"
186− buildUB (Inclusive v) = char8 '"' <> f v <> byteString "\"]'"
187− buildUB (Exclusive v) = char8 '"' <> f v <> byteString "\")'"
188− buildUB PosInfinity = byteString "]'"
189−{-# INLINE rangeToBuilder #-}
190−
191−
192−instance (FromField a, Typeable a) => FromField (PGRange a) where
193− fromField = fromFieldRange fromField
194−
195−fromFieldRange :: Typeable a => FieldParser a -> FieldParser (PGRange a)
196−fromFieldRange fromField' f mdat = do
197− info <- typeInfo f
198− case info of
199− Range{} ->
200− let f' = f { typeOid = typoid (rngsubtype info) }
201− in case mdat of
202− Nothing -> returnError UnexpectedNull f ""
203− Just "empty" -> pure $ empty
204− Just bs ->
205− let parseIt NegInfinity = pure NegInfinity
206− parseIt (Inclusive v) = Inclusive <$> fromField' f' (Just v)
207− parseIt (Exclusive v) = Exclusive <$> fromField' f' (Just v)
208− parseIt PosInfinity = pure PosInfinity
209− in case parseOnly pgrange bs of
210− Left e -> returnError ConversionFailed f e
211− Right (lb,ub) -> PGRange <$> parseIt lb <*> parseIt ub
212− _ -> returnError Incompatible f ""
213−
214−
215−instance ToField (PGRange Int8) where
216− toField = Plain . rangeToBuilder int8Dec
217− {-# INLINE toField #-}
218−
219−instance ToField (PGRange Int16) where
220− toField = Plain . rangeToBuilder int16Dec
221− {-# INLINE toField #-}
222−
223−instance ToField (PGRange Int32) where
224− toField = Plain . rangeToBuilder int32Dec
225− {-# INLINE toField #-}
226−
227−instance ToField (PGRange Int) where
228− toField = Plain . rangeToBuilder intDec
229− {-# INLINE toField #-}
230−
231−instance ToField (PGRange Int64) where
232− toField = Plain . rangeToBuilder int64Dec
233− {-# INLINE toField #-}
234−
235−instance ToField (PGRange Integer) where
236− toField = Plain . rangeToBuilder integerDec
237− {-# INLINE toField #-}
238−
239−instance ToField (PGRange Word8) where
240− toField = Plain . rangeToBuilder word8Dec
241− {-# INLINE toField #-}
242−
243−instance ToField (PGRange Word16) where
244− toField = Plain . rangeToBuilder word16Dec
245− {-# INLINE toField #-}
246−
247−instance ToField (PGRange Word32) where
248− toField = Plain . rangeToBuilder word32Dec
249− {-# INLINE toField #-}
250−
251−instance ToField (PGRange Word) where
252− toField = Plain . rangeToBuilder wordDec
253− {-# INLINE toField #-}
254−
255−instance ToField (PGRange Word64) where
256− toField = Plain . rangeToBuilder word64Dec
257− {-# INLINE toField #-}
258−
259−instance ToField (PGRange Float) where
260− toField = Plain . rangeToBuilder floatDec
261− {-# INLINE toField #-}
262−
263−instance ToField (PGRange Double) where
264− toField = Plain . rangeToBuilder doubleDec
265− {-# INLINE toField #-}
266−
267−instance ToField (PGRange Scientific) where
268− toField = Plain . rangeToBuilder f
269− where
270− f = lazyByteString . LT.encodeUtf8 . LT.toLazyText . scientificBuilder
271− {-# INLINE toField #-}
272−
273−instance ToField (PGRange UTCTime) where
274− toField = Plain . rangeToBuilder utcTimeToBuilder
275− {-# INLINE toField #-}
276−
277−instance ToField (PGRange ZonedTime) where
278− toField = Plain . rangeToBuilderBy cmpZonedTime zonedTimeToBuilder
279− {-# INLINE toField #-}
280−
281−cmpZonedTime :: ZonedTime -> ZonedTime -> Ordering
282−cmpZonedTime = compare `on` zonedTimeToUTC -- FIXME: optimize
283−
284−instance ToField (PGRange LocalTime) where
285− toField = Plain . rangeToBuilder localTimeToBuilder
286− {-# INLINE toField #-}
287−
288−instance ToField (PGRange Day) where
289− toField = Plain . rangeToBuilder dayToBuilder
290− {-# INLINE toField #-}
291−
292−instance ToField (PGRange TimeOfDay) where
293− toField = Plain . rangeToBuilder timeOfDayToBuilder
294− {-# INLINE toField #-}
295−
296−instance ToField (PGRange UTCTimestamp) where
297− toField = Plain . rangeToBuilder utcTimestampToBuilder
298− {-# INLINE toField #-}
299−
300−instance ToField (PGRange ZonedTimestamp) where
301− toField = Plain . rangeToBuilderBy cmpZonedTimestamp zonedTimestampToBuilder
302− {-# INLINE toField #-}
303−
304−cmpZonedTimestamp :: ZonedTimestamp -> ZonedTimestamp -> Ordering
305−cmpZonedTimestamp = compare `on` (zonedTimeToUTC <$>)
306−
307−instance ToField (PGRange LocalTimestamp) where
308− toField = Plain . rangeToBuilder localTimestampToBuilder
309− {-# INLINE toField #-}
310−
311−instance ToField (PGRange Date) where
312− toField = Plain . rangeToBuilder dateToBuilder
313− {-# INLINE toField #-}
314−
315−instance ToField (PGRange NominalDiffTime) where
316− toField = Plain . rangeToBuilder nominalDiffTimeToBuilder
317− {-# INLINE toField #-}
src/Database/PostgreSQL/Simple/SqlQQ.hs+23−37
@@ -1,13 +1,7 @@
1−{-# LANGUAGE CPP #-}
2−#if __GLASGOW_HASKELL__ >= 800
3−{-# LANGUAGE TemplateHaskellQuotes #-}
4−#else
5−{-# LANGUAGE TemplateHaskell #-}
6−#endif
71------------------------------------------------------------------------------
82-- |
93-- Module: Database.PostgreSQL.Simple.SqlQQ
10−-- Copyright: (c) 2011-2012 Leon P Smith
4+-- Copyright: (c) 2011 Leon P Smith
115-- License: BSD3
126-- Maintainer: Leon P Smith <leon@melding-monads.com>
137-- Stability: experimental
@@ -15,11 +9,10 @@
159------------------------------------------------------------------------------
1610
1711module Database.PostgreSQL.Simple.SqlQQ (sql) where
18−import Database.PostgreSQL.Simple.Types (Query)
12+
1913import Language.Haskell.TH
2014import Language.Haskell.TH.Quote
2115import Data.Char
22−import Data.String
2316
2417-- | 'sql' is a quasiquoter that eases the syntactic burden
2518-- of writing big sql statements in Haskell source code. For example:
@@ -34,18 +27,16 @@ import Data.String
3427-- > LIMIT 100 |]
3528-- > (beginTime,endTime,string)
3629--
37−-- This quasiquoter returns a literal string expression of type 'Query',
38−-- and attempts to minimize whitespace; otherwise the above query would
39−-- consist of approximately half whitespace when sent to the database
40−-- backend. It also recognizes and strips out standard sql comments "--".
30+-- This quasiquoter attempts to mimimize whitespace; otherwise the
31+-- above query would consist of approximately half whitespace when sent
32+-- to the database backend.
4133--
4234-- The implementation of the whitespace reducer is currently incomplete.
4335-- Thus it can mess up your syntax in cases where whitespace should be
4436-- preserved as-is. It does preserve whitespace inside standard SQL string
4537-- literals. But it can get confused by the non-standard PostgreSQL string
4638-- literal syntax (which is the default setting in PostgreSQL 8 and below),
47−-- the extended escape string syntax, quoted identifiers, and other similar
48−-- constructs.
39+-- the extended escape string syntax, and other similar constructs.
4940--
5041-- Of course, this caveat only applies to text written inside the SQL
5142-- quasiquoter; whitespace reduction is a compile-time computation and
@@ -57,34 +48,29 @@ import Data.String
5748
5849sql :: QuasiQuoter
5950sql = QuasiQuoter
60− { quotePat = error "Database.PostgreSQL.Simple.SqlQQ.sql: quasiquoter used in pattern context"
61− , quoteType = error "Database.PostgreSQL.Simple.SqlQQ.sql: quasiquoter used in type context"
51+ { quotePat = error "Database.PostgreSQL.Simple.SqlQQ.sql:\
52+ \ quasiquoter used in pattern context"
53+ , quoteType = error "Database.PostgreSQL.Simple.SqlQQ.sql:\
54+ \ quasiquoter used in type context"
6255 , quoteExp = sqlExp
63− , quoteDec = error "Database.PostgreSQL.Simple.SqlQQ.sql: quasiquoter used in declaration context"
56+ , quoteDec = error "Database.PostgreSQL.Simple.SqlQQ.sql:\
57+ \ quasiquoter used in declaration context"
6458 }
6559
6660sqlExp :: String -> Q Exp
67−sqlExp = appE [| fromString :: String -> Query |] . stringE . minimizeSpace
68−
69−minimizeSpace :: String -> String
70−minimizeSpace = drop 1 . reduceSpace
61+sqlExp = stringE . outstring . dropSpace
7162 where
72− needsReduced [] = False
73− needsReduced ('-':'-':_) = True
74− needsReduced (x:_) = isSpace x
75−
76− reduceSpace xs =
77− case dropWhile isSpace xs of
78− [] -> []
79− ('-':'-':ys) -> reduceSpace (dropWhile (/= '\n') ys)
80− ys -> ' ' : insql ys
63+ dropSpace = dropWhile isSpace
8164
82− insql ('\'':xs) = '\'' : instring xs
83− insql xs | needsReduced xs = reduceSpace xs
84− insql (x:xs) = x : insql xs
85− insql [] = []
65+ outstring ('\'':xs) = '\'' : instring xs
66+ outstring (x:xs) | isSpace x = case dropSpace xs of
67+ [] -> []
68+ ys -> ' ' : outstring ys
69+ | otherwise = x : outstring xs
70+ outstring [] = []
8671
8772 instring ('\'':'\'':xs) = '\'':'\'': instring xs
88− instring ('\'':xs) = '\'': insql xs
73+ instring ('\'':xs) = '\'': outstring xs
8974 instring (x:xs) = x : instring xs
90− instring [] = error "Database.PostgreSQL.Simple.SqlQQ.sql: string literal not terminated"
75+ instring [] = error "Database.PostgreSQL.Simple.SqlQQ.sql:\
76+ \ string literal not terminated"
src/Database/PostgreSQL/Simple/Time.hsdeleted−246
@@ -1,246 +0,0 @@
1−{- |
2−Module: Database.PostgreSQL.Simple.Time
3−Copyright: (c) 2012-2015 Leon P Smith
4−License: BSD3
5−Maintainer: Leon P Smith <leon@melding-monads.com>
6−Stability: experimental
7−
8−This module provides time types that supports positive and negative
9−infinity, as well as some functions for converting to and from strings.
10−
11−Also, this module also contains commentary regarding postgresql's timestamp
12−types, civil timekeeping in general, and how it relates to
13−postgresql-simple. You can read more about PostgreSQL's date and time types
14−at <https://www.postgresql.org/docs/9.5/static/datatype-datetime.html>,
15−and the IANA time zone database at <https://en.wikipedia.org/wiki/Tz_database>.
16−
17−Stack Overflow also has some excellent commentary on time, if it is a
18−wiki page or a highly upvoted question and answer. If the answer regarding
19−time has not received about a hundred upvotes at least, then the answer is
20−almost invariably completely and painfully wrong, even if it's the chosen
21−answer or the most highly upvoted answer to a question.
22−
23−PostgreSQL's @timestamp with time zone@ (hereafter, @timestamptz@) can be
24−converted to Haskell's 'Data.Time.UTCTime' and 'Data.Time.ZonedTime' types,
25−because values of these types represent a self-contained, unambiguous point
26−in time. PostgreSQL's @timestamp without time zone@ (hereafter, @timestamp@)
27−can be converted to Haskell's 'Data.Time.LocalTime', because values of these
28−types are ambiguous by themselves, and require context to disambiguate.
29−
30−While this behavior may be superficially counterintuitive because the
31−names might suggest otherwise, this behavior is correct. In fact,
32−the \"timezone\" language in both the postgresql and haskell types would
33−be better read as \"offset (from UTC)\", thus we have postgresql's
34−\"timestamp with offset\" corresponding to Haskell's \"time with the
35−offset \'zero\'\" and Haskell's \"time with an offset (that might be
36−nonzero)\". Similarly, postgresql's \"timestamp without an offset\"
37−corresponds to Haskell's \"local time (without an offset)\".
38−
39−It's important to distinguish between an offset, a standard time, and
40−a time zone. An offset is simply a difference of a local time from UTC,
41−such as @+00@, @-05@, or @+05:30@. A standard time specifies an offset
42−(which may vary throughout the year, due to daylight savings) that a
43−region follows, such as Universal Coordinated Time (UTC), Eastern Standard
44−Time\/Eastern Daylight Time (EST\/EDT), or India Standard Time (IST).
45−And a time zone, much like a standard time, is a function from
46−timestamps to offsets.
47−
48−A time zone is different from a standard time because different regions
49−inside a standard time can be governed by different civil authorities with
50−different laws and thus have different histories of civil time. An IANA
51−time zone is any region of the world that has had the same history of
52−civil time since @1970-01-01 00:00+00@.
53−
54−For example, as of today, both @America\/New_York@ and
55−@America\/Indiana\/Indianapolis@ are on the EST\/EDT time standard, but
56−Indiana used to be on Central Standard Time until 1942, and did not observe
57−daylight savings time (EST only) until 2006. Thus, the choice between
58−these two time zones still matters if you are dealing with timestamps
59−prior to 2006, and could become relevant again if (most of) Indiana
60−moves back to Central Time. (Of course, if the Central to Eastern switch
61−was the only difference, then these two time zones would be the same in
62−IANA's eyes, due to their cutoff date of 1970-01-01.)
63−
64−Getting back to practicalities, PostgreSQL's @timestamptz@ type does not
65−actually store an offset; rather, it uses the offset provided to calculate
66−UTC, and stores the timestamp as UTC. If an offset is not provided, the
67−given timestamp is assumed to be a local time for whatever the @timezone@
68−variable is set to, and the IANA TZ database is consulted to calculate an
69−offset from UTC for the time in question.
70−
71−Note that while most (local timestamp, time zone) pairs correspond to exactly
72−one UTC timestamp, some correspond to two UTC timestamps, while others
73−correspond to none at all. The ambiguous case occurs when the civil time
74−is rolled back, making a calendar day longer than 24 hours. In this case,
75−PostgreSQL silently chooses the second, later possibility. The inconsistent
76−case occurs when the civil time is moved forward, making a calendar day less
77−than 24 hours. In this case, PostgreSQL silently assumes the local time
78−was read off a clock that had not been moved forward at the prescribed time,
79−and moves the clock forward for you. Thus, converting from local time
80−to UTC need not be monotonic, if these inconsistent cases are allowed.
81−
82−When retrieving a @timestamptz@, the backend looks at the @time zone@
83−connection variable and then consults the IANA TZ database to calculate
84−an offset for the timestamp in the given time zone.
85−
86−Note that while some of the information contained in the IANA TZ database
87−is a bit of a standardized fiction, the conversion from UTC time to a
88−(local time, offset) pair in a particular time zone is always unambiguous,
89−and the result can always be unambiguously converted back to UTC. Thus,
90−postgresql-simple can interpret such a result as a 'Data.Time.ZonedTime',
91−or use the offset to convert back to 'Data.Time.UTCTime'.
92−
93−By contrast, the @timestamp@ type ignores any offsets provided to it,
94−and never sends back an offset. Thus, postgresql-simple equates this
95−with 'Data.Time.LocalTime', which has no concept of an offset. One can
96−convert between @timestamptz@ and @timestamp@ using the @AT TIME ZONE@
97−operator, whose semantics also demonstrates that @timestamptz@ is
98−'Data.Time.UTCTime' whereas @timestamp@ is 'Data.Time.LocalTime'.
99−
100−PostgreSQL's @timezone@ is a per-connection variable that by default is
101−initialized to @\'localtime\'@, which normally corresponds to the server's
102−time zone. However, this default can be modified on the server side for an
103−entire cluster, or on a per-user or per-database basis. Moreover, a client
104−can modify their instance of the variable at any time, and can apply that
105−change to the remaining duration of the connection, the current transaction,
106−or the execution context of a server-side function. In addition, upon
107−connection initialization, the libpq client checks for the existence of
108−the @PGTZ@ environment variable, and if it exists, modifies @timezone@
109−accordingly.
110−
111−With a few caveats, postgresql-simple is designed so that you can both send
112−and receive timestamps with the server and get a correct result, no matter
113−what the @timezone@ setting is. But it is important to understand the caveats:
114−
115−1. The correctness of server-side computations can depend on the @timezone@
116− setting. Examples include adding an @interval@ to a @timestamptz@, or
117− type casting between @timestamp@ and @timestamptz@, or applying
118− the @DATE@ function to a @timestamptz@.
119−
120−2. The (localtime, offset) pair contained in a 'Data.Time.ZonedTime' result
121− will depend on the @timezone@ setting, although the result will always
122− represent the same instant in time regardless of the time zone.
123−
124−3. Sending a 'Data.Time.LocalTime' and interpreting it as a @timestamptz@
125− can be useful, as it will be converted to UTC via the tz database,
126− but correctness will depend on the @timezone@ setting. You may prefer
127− to use an explicit @AT TIME ZONE@ conversion instead, which would avoid
128− this contextual dependence.
129−
130−Furthermore, although these following points don't involve the @timezone@
131−setting, they are related to the last point above:
132−
133−1. Sending a 'Data.Time.UTCTime' and interpreting it as a @timestamp@ can
134− be useful. In practice, the most common context used to disambiguate
135− @timestamp@ is that it represents UTC, and this coding technique will
136− work as expected in this situation.
137−
138−2. Sending a 'Data.Time.ZonedTime' and interpreting it as a @timestamp@ is
139− almost always the wrong thing to do, as the offset will be ignored and
140− discarded. This is likely to lead to inconsistencies in the database,
141− and may lead to partial data loss.
142−
143−When dealing with local timestamps that refer to the future, it is often
144−useful to store it as a local time in a @timestamp@ column and store the
145−time zone in a second column. One reason to do this is so that you can
146−convert to UTC on the fly as needed, and be protected against future changes
147−to the TZ database due to changes in local time standards. In any case,
148−'Data.Time.ZonedTime' is not suitable for this application, because despite
149−its name, it represents an offset and not a time zone. Time zones can change;
150−offsets do not. In reality, we can't convert a local timestamp that occurs
151−sufficiently far in the future to UTC, because we don't know how to do it yet.
152−
153−There are a few limitations and caveats that one might need to be aware
154−of with the current implementation when dealing with older timestamps:
155−
156−For sufficiently old timestamps in almost all time zones, the IANA TZ
157−database specifies offsets from UTC that is not an integral number of
158−minutes. This corresponds to local mean time; that is, astronomical
159−time in the city that defines the time zone. Different time zones moved
160−away from local mean time to a standard time at different points in
161−history, so \"sufficiently old\" depends on the time zone in question.
162−
163−Thus, when retrieving a @timestamptz@ postgresql will in some cases
164−provide seconds in the offset. For example:
165−
166−@
167−$ psql
168−psql (9.4.5)
169−Type \"help\" for help.
170−
171−lpsmith=> SET timezone TO \'America/New_York\';
172−SET
173−lpsmith=> VALUES (\'1883-11-18 16:59:59+00\'::timestamptz),
174− (\'1883-11-18 17:00:00+00\'::timestamptz);
175− column1
176−------------------------------
177− 1883-11-18 12:03:57-04:56:02
178− 1883-11-18 12:00:00-05
179−(2 rows)
180−@
181−
182−Both of these timestamps can be parsed as a 'Data.Time.UTCTime' type,
183−however 'Data.Time.ZonedTime' will fail on the former timestamp.
184−Because 'Data.Time.ZonedTime' assumes that offsets are an integer number
185−of minutes, there isn't an particularly good solution here.
186−
187−PostgreSQL, like most software, uses the proleptic Gregorian calendar
188−for its date calculations, extending the Gregorian calendar backwards
189−in time before its introduction and pretending that the Julian calendar
190−does not exist. For most purposes, the adoption of the Gregorian calendar
191−ranges from @1582-10-15@ to @1923-03-01@, depending on location and
192−sometimes even political allegiances within a single location.
193−
194−Timestamps BCE are not supported. For example, PostgreSQL
195−will emit \"@0045-01-01 BC@\" for the first proleptic Gregorian day of
196−the year the Roman Empire adopted the Julian Calendar, but
197−postgresql-simple does not (yet?) have the ability to either parse or
198−generate this syntax. Unfortunately this syntax isn't convenient to
199−print or especially parse.
200−
201−Also, postgresql itself cannot parse or print dates before @4714-11-24 BC@,
202−which is the Julian date on the proleptic Gregorian Calendar. Although
203−postgresql's timestamp types are perfectly capable of representing timestamps
204−nearly 300,000 years in the past, using this would require postgresql-simple
205−and other client programs to support binary parameters and results.
206−
207−Dealing with years BCE is also complicated slightly by the fact that
208−Haskell's time library has a year \"0000\", which is a convention often
209−used by astronomers, while postgresql adopts the more historically
210−accurate convention that there is no year zero, but rather \"1 BCE\"
211−was immediately followed by \"1 CE\".
212−
213−-}
214−
215−module Database.PostgreSQL.Simple.Time
216− ( Unbounded(..)
217− , Date
218− , UTCTimestamp
219− , ZonedTimestamp
220− , LocalTimestamp
221− , parseDay
222− , parseUTCTime
223− , parseZonedTime
224− , parseLocalTime
225− , parseTimeOfDay
226− , parseDate
227− , parseUTCTimestamp
228− , parseZonedTimestamp
229− , parseLocalTimestamp
230− , parseCalendarDiffTime
231− , dayToBuilder
232− , utcTimeToBuilder
233− , zonedTimeToBuilder
234− , localTimeToBuilder
235− , timeOfDayToBuilder
236− , timeZoneToBuilder
237− , dateToBuilder
238− , utcTimestampToBuilder
239− , zonedTimestampToBuilder
240− , localTimestampToBuilder
241− , unboundedToBuilder
242− , nominalDiffTimeToBuilder
243− , calendarDiffTimeToBuilder
244− ) where
245−
246−import Database.PostgreSQL.Simple.Time.Implementation
src/Database/PostgreSQL/Simple/Time/Implementation.hsdeleted−176
@@ -1,176 +0,0 @@
1−------------------------------------------------------------------------------
2−-- |
3−-- Module: Database.PostgreSQL.Simple.Time.Implementation
4−-- Copyright: (c) 2012-2015 Leon P Smith
5−-- License: BSD3
6−-- Maintainer: Leon P Smith <leon@melding-monads.com>
7−-- Stability: experimental
8−--
9−------------------------------------------------------------------------------
10−
11−{-# LANGUAGE DeriveDataTypeable, DeriveFunctor #-}
12−
13−module Database.PostgreSQL.Simple.Time.Implementation where
14−
15−import Prelude hiding (take)
16−import Data.ByteString.Builder(Builder, byteString)
17−import Data.ByteString.Builder.Prim(primBounded)
18−import Control.Arrow((***))
19−import Control.Applicative
20−import qualified Data.ByteString as B
21−import Data.Time.Compat (LocalTime, UTCTime, ZonedTime, Day, TimeOfDay, TimeZone, NominalDiffTime, utc)
22−import Data.Time.LocalTime.Compat (CalendarDiffTime)
23−import Data.Typeable
24−import Data.Maybe (fromMaybe)
25−import qualified Data.Attoparsec.ByteString.Char8 as A
26−import Database.PostgreSQL.Simple.Compat ((<>))
27−import qualified Database.PostgreSQL.Simple.Time.Internal.Parser as TP
28−import qualified Database.PostgreSQL.Simple.Time.Internal.Printer as TPP
29−
30−data Unbounded a
31− = NegInfinity
32− | Finite !a
33− | PosInfinity
34− deriving (Eq, Ord, Typeable, Functor)
35−
36−instance Show a => Show (Unbounded a) where
37− showsPrec prec x rest
38− = case x of
39− NegInfinity -> "-infinity" <> rest
40− Finite time -> showsPrec prec time rest
41− PosInfinity -> "infinity" <> rest
42−
43−instance Read a => Read (Unbounded a) where
44− readsPrec prec = readParen False $ \str -> case str of
45− ('-':'i':'n':'f':'i':'n':'i':'t':'y':xs) -> [(NegInfinity,xs)]
46− ( 'i':'n':'f':'i':'n':'i':'t':'y':xs) -> [(PosInfinity,xs)]
47− xs -> map (Finite *** id) (readsPrec prec xs)
48−
49−type LocalTimestamp = Unbounded LocalTime
50−type UTCTimestamp = Unbounded UTCTime
51−type ZonedTimestamp = Unbounded ZonedTime
52−type Date = Unbounded Day
53−
54−parseUTCTime :: B.ByteString -> Either String UTCTime
55−parseUTCTime = A.parseOnly (getUTCTime <* A.endOfInput)
56−
57−parseZonedTime :: B.ByteString -> Either String ZonedTime
58−parseZonedTime = A.parseOnly (getZonedTime <* A.endOfInput)
59−
60−parseLocalTime :: B.ByteString -> Either String LocalTime
61−parseLocalTime = A.parseOnly (getLocalTime <* A.endOfInput)
62−
63−parseDay :: B.ByteString -> Either String Day
64−parseDay = A.parseOnly (getDay <* A.endOfInput)
65−
66−parseTimeOfDay :: B.ByteString -> Either String TimeOfDay
67−parseTimeOfDay = A.parseOnly (getTimeOfDay <* A.endOfInput)
68−
69−parseUTCTimestamp :: B.ByteString -> Either String UTCTimestamp
70−parseUTCTimestamp = A.parseOnly (getUTCTimestamp <* A.endOfInput)
71−
72−parseZonedTimestamp :: B.ByteString -> Either String ZonedTimestamp
73−parseZonedTimestamp = A.parseOnly (getZonedTimestamp <* A.endOfInput)
74−
75−parseLocalTimestamp :: B.ByteString -> Either String LocalTimestamp
76−parseLocalTimestamp = A.parseOnly (getLocalTimestamp <* A.endOfInput)
77−
78−parseDate :: B.ByteString -> Either String Date
79−parseDate = A.parseOnly (getDate <* A.endOfInput)
80−
81−parseCalendarDiffTime :: B.ByteString -> Either String CalendarDiffTime
82−parseCalendarDiffTime = A.parseOnly (getCalendarDiffTime <* A.endOfInput)
83−
84−getUnbounded :: A.Parser a -> A.Parser (Unbounded a)
85−getUnbounded getFinite
86− = (pure NegInfinity <* A.string "-infinity")
87− <|> (pure PosInfinity <* A.string "infinity")
88− <|> (Finite <$> getFinite)
89−
90−getDay :: A.Parser Day
91−getDay = TP.day
92−
93−getDate :: A.Parser Date
94−getDate = getUnbounded getDay
95−
96−getTimeOfDay :: A.Parser TimeOfDay
97−getTimeOfDay = TP.timeOfDay
98−
99−getLocalTime :: A.Parser LocalTime
100−getLocalTime = TP.localTime
101−
102−getLocalTimestamp :: A.Parser LocalTimestamp
103−getLocalTimestamp = getUnbounded getLocalTime
104−
105−getTimeZone :: A.Parser TimeZone
106−getTimeZone = fromMaybe utc <$> TP.timeZone
107−
108−type TimeZoneHMS = (Int,Int,Int)
109−
110−getTimeZoneHMS :: A.Parser TimeZoneHMS
111−getTimeZoneHMS = munge <$> TP.timeZoneHMS
112− where
113− munge Nothing = (0,0,0)
114− munge (Just (TP.UTCOffsetHMS h m s)) = (h,m,s)
115−
116−localToUTCTimeOfDayHMS :: TimeZoneHMS -> TimeOfDay -> (Integer, TimeOfDay)
117−localToUTCTimeOfDayHMS (dh, dm, ds) tod =
118− TP.localToUTCTimeOfDayHMS (TP.UTCOffsetHMS dh dm ds) tod
119−
120−getZonedTime :: A.Parser ZonedTime
121−getZonedTime = TP.zonedTime
122−
123−getZonedTimestamp :: A.Parser ZonedTimestamp
124−getZonedTimestamp = getUnbounded getZonedTime
125−
126−getUTCTime :: A.Parser UTCTime
127−getUTCTime = TP.utcTime
128−
129−getUTCTimestamp :: A.Parser UTCTimestamp
130−getUTCTimestamp = getUnbounded getUTCTime
131−
132−getCalendarDiffTime :: A.Parser CalendarDiffTime
133−getCalendarDiffTime = TP.calendarDiffTime
134−
135−dayToBuilder :: Day -> Builder
136−dayToBuilder = primBounded TPP.day
137−
138−timeOfDayToBuilder :: TimeOfDay -> Builder
139−timeOfDayToBuilder = primBounded TPP.timeOfDay
140−
141−timeZoneToBuilder :: TimeZone -> Builder
142−timeZoneToBuilder = primBounded TPP.timeZone
143−
144−utcTimeToBuilder :: UTCTime -> Builder
145−utcTimeToBuilder = primBounded TPP.utcTime
146−
147−zonedTimeToBuilder :: ZonedTime -> Builder
148−zonedTimeToBuilder = primBounded TPP.zonedTime
149−
150−localTimeToBuilder :: LocalTime -> Builder
151−localTimeToBuilder = primBounded TPP.localTime
152−
153−unboundedToBuilder :: (a -> Builder) -> (Unbounded a -> Builder)
154−unboundedToBuilder finiteToBuilder unbounded
155− = case unbounded of
156− NegInfinity -> byteString "-infinity"
157− Finite a -> finiteToBuilder a
158− PosInfinity -> byteString "infinity"
159−
160−utcTimestampToBuilder :: UTCTimestamp -> Builder
161−utcTimestampToBuilder = unboundedToBuilder utcTimeToBuilder
162−
163−zonedTimestampToBuilder :: ZonedTimestamp -> Builder
164−zonedTimestampToBuilder = unboundedToBuilder zonedTimeToBuilder
165−
166−localTimestampToBuilder :: LocalTimestamp -> Builder
167−localTimestampToBuilder = unboundedToBuilder localTimeToBuilder
168−
169−dateToBuilder :: Date -> Builder
170−dateToBuilder = unboundedToBuilder dayToBuilder
171−
172−nominalDiffTimeToBuilder :: NominalDiffTime -> Builder
173−nominalDiffTimeToBuilder = TPP.nominalDiffTime
174−
175−calendarDiffTimeToBuilder :: CalendarDiffTime -> Builder
176−calendarDiffTimeToBuilder = TPP.calendarDiffTime
src/Database/PostgreSQL/Simple/Time/Internal.hsdeleted−27
@@ -1,27 +0,0 @@
1−------------------------------------------------------------------------------
2−-- |
3−-- Module: Database.PostgreSQL.Simple.Time.Internal
4−-- Copyright: (c) 2012 Leon P Smith
5−-- License: BSD3
6−-- Maintainer: Leon P Smith <leon@melding-monads.com>
7−-- Stability: experimental
8−--
9−------------------------------------------------------------------------------
10−
11−module Database.PostgreSQL.Simple.Time.Internal
12− ( getDay
13− , getDate
14− , getTimeOfDay
15− , getLocalTime
16− , getLocalTimestamp
17− , getTimeZone
18− , getZonedTime
19− , getZonedTimestamp
20− , getUTCTime
21− , getUTCTimestamp
22− , TimeZoneHMS
23− , getTimeZoneHMS
24− , localToUTCTimeOfDayHMS
25− ) where
26−
27−import Database.PostgreSQL.Simple.Time.Implementation
src/Database/PostgreSQL/Simple/Time/Internal/Parser.hsdeleted−204
@@ -1,204 +0,0 @@
1−{-# LANGUAGE 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 <leon@melding-monads.com>
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− , calendarDiffTime
25− ) where
26−
27−import Control.Applicative ((<$>), (<*>), (<*), (*>))
28−import Database.PostgreSQL.Simple.Compat (toPico)
29−import Data.Attoparsec.ByteString.Char8 as A
30−import Data.Bits ((.&.))
31−import Data.ByteString (ByteString)
32−import Data.Char (ord)
33−import Data.Fixed (Pico)
34−import Data.Int (Int64)
35−import Data.Maybe (fromMaybe)
36−import Data.Time.Calendar.Compat (Day, fromGregorianValid, addDays)
37−import Data.Time.Clock.Compat (UTCTime(..))
38−import Data.Time.Format.ISO8601.Compat (iso8601ParseM)
39−import Data.Time.LocalTime.Compat (CalendarDiffTime)
40−import qualified Data.ByteString.Char8 as B8
41−import qualified Data.Time.LocalTime.Compat as Local
42−
43−-- | Parse a date of the form @YYYY-MM-DD@.
44−day :: Parser Day
45−day = do
46− y <- decimal <* char '-'
47− m <- twoDigits <* char '-'
48− d <- twoDigits
49− maybe (fail "invalid date") return (fromGregorianValid y m d)
50−
51−-- | Parse a two-digit integer (e.g. day of month, hour).
52−twoDigits :: Parser Int
53−twoDigits = do
54− a <- digit
55− b <- digit
56− let c2d c = ord c .&. 15
57− return $! c2d a * 10 + c2d b
58−
59−-- | Parse a time of the form @HH:MM[:SS[.SSS]]@.
60−timeOfDay :: Parser Local.TimeOfDay
61−timeOfDay = do
62− h <- twoDigits <* char ':'
63− m <- twoDigits
64− mc <- peekChar
65− s <- case mc of
66− Just ':' -> anyChar *> seconds
67− _ -> return 0
68− if h < 24 && m < 60 && s <= 60
69− then return (Local.TimeOfDay h m s)
70− else fail "invalid time"
71−
72−-- | Parse a count of seconds, with the integer part being two digits
73−-- long.
74−seconds :: Parser Pico
75−seconds = do
76− real <- twoDigits
77− mc <- peekChar
78− case mc of
79− Just '.' -> do
80− t <- anyChar *> takeWhile1 isDigit
81− return $! parsePicos (fromIntegral real) t
82− _ -> return $! fromIntegral real
83− where
84− parsePicos :: Int64 -> B8.ByteString -> Pico
85− parsePicos a0 t = toPico (fromIntegral (t' * 10^n))
86− where n = max 0 (12 - B8.length t)
87− t' = B8.foldl' (\a c -> 10 * a + fromIntegral (ord c .&. 15)) a0
88− (B8.take 12 t)
89−
90−-- | Parse a time zone, and return 'Nothing' if the offset from UTC is
91−-- zero. (This makes some speedups possible.)
92−timeZone :: Parser (Maybe Local.TimeZone)
93−timeZone = do
94− ch <- satisfy $ \c -> c == '+' || c == '-' || c == 'Z'
95− if ch == 'Z'
96− then return Nothing
97− else do
98− h <- twoDigits
99− mm <- peekChar
100− m <- case mm of
101− Just ':' -> anyChar *> twoDigits
102− _ -> return 0
103− let off | ch == '-' = negate off0
104− | otherwise = off0
105− off0 = h * 60 + m
106− case undefined of
107− _ | off == 0 ->
108− return Nothing
109− | h > 23 || m > 59 ->
110− fail "invalid time zone offset"
111− | otherwise ->
112− let !tz = Local.minutesToTimeZone off
113− in return (Just tz)
114−
115−data UTCOffsetHMS = UTCOffsetHMS {-# UNPACK #-} !Int {-# UNPACK #-} !Int {-# UNPACK #-} !Int
116−
117−-- | Parse a time zone, and return 'Nothing' if the offset from UTC is
118−-- zero. (This makes some speedups possible.)
119−timeZoneHMS :: Parser (Maybe UTCOffsetHMS)
120−timeZoneHMS = do
121− ch <- satisfy $ \c -> c == '+' || c == '-' || c == 'Z'
122− if ch == 'Z'
123− then return Nothing
124− else do
125− h <- twoDigits
126− m <- maybeTwoDigits
127− s <- maybeTwoDigits
128− case undefined of
129− _ | h == 0 && m == 0 && s == 0 ->
130− return Nothing
131− | h > 23 || m >= 60 || s >= 60 ->
132− fail "invalid time zone offset"
133− | otherwise ->
134− if ch == '+'
135− then let !tz = UTCOffsetHMS h m s
136− in return (Just tz)
137− else let !tz = UTCOffsetHMS (-h) (-m) (-s)
138− in return (Just tz)
139− where
140− maybeTwoDigits = do
141− ch <- peekChar
142− case ch of
143− Just ':' -> anyChar *> twoDigits
144− _ -> return 0
145−
146−localToUTCTimeOfDayHMS :: UTCOffsetHMS -> Local.TimeOfDay -> (Integer, Local.TimeOfDay)
147−localToUTCTimeOfDayHMS (UTCOffsetHMS dh dm ds) (Local.TimeOfDay h m s) =
148− (\ !a !b -> (a,b)) dday (Local.TimeOfDay h'' m'' s'')
149− where
150− s' = s - fromIntegral ds
151− (!s'', m')
152− | s' < 0 = (s' + 60, m - dm - 1)
153− | s' >= 60 = (s' - 60, m - dm + 1)
154− | otherwise = (s' , m - dm )
155− (!m'', h')
156− | m' < 0 = (m' + 60, h - dh - 1)
157− | m' >= 60 = (m' - 60, h - dh + 1)
158− | otherwise = (m' , h - dh )
159− (!h'', dday)
160− | h' < 0 = (h' + 24, -1)
161− | h' >= 24 = (h' - 24, 1)
162− | otherwise = (h' , 0)
163−
164−
165−-- | Parse a date and time, of the form @YYYY-MM-DD HH:MM:SS@.
166−-- The space may be replaced with a @T@. The number of seconds may be
167−-- followed by a fractional component.
168−localTime :: Parser Local.LocalTime
169−localTime = Local.LocalTime <$> day <* daySep <*> timeOfDay
170− where daySep = satisfy (\c -> c == ' ' || c == 'T')
171−
172−-- | Behaves as 'zonedTime', but converts any time zone offset into a
173−-- UTC time.
174−utcTime :: Parser UTCTime
175−utcTime = do
176− (Local.LocalTime d t) <- localTime
177− mtz <- timeZoneHMS
178− case mtz of
179− Nothing -> let !tt = Local.timeOfDayToTime t
180− in return (UTCTime d tt)
181− Just tz -> let !(dd,t') = localToUTCTimeOfDayHMS tz t
182− !d' = addDays dd d
183− !tt = Local.timeOfDayToTime t'
184− in return (UTCTime d' tt)
185−
186−-- | Parse a date with time zone info. Acceptable formats:
187−--
188−-- @YYYY-MM-DD HH:MM:SS Z@
189−--
190−-- The first space may instead be a @T@, and the second space is
191−-- optional. The @Z@ represents UTC. The @Z@ may be replaced with a
192−-- time zone offset of the form @+0000@ or @-08:00@, where the first
193−-- two digits are hours, the @:@ is optional and the second two digits
194−-- (also optional) are minutes.
195−zonedTime :: Parser Local.ZonedTime
196−zonedTime = Local.ZonedTime <$> localTime <*> (fromMaybe utc <$> timeZone)
197−
198−utc :: Local.TimeZone
199−utc = Local.TimeZone 0 False ""
200−
201−calendarDiffTime :: Parser CalendarDiffTime
202−calendarDiffTime = do
203− contents <- takeByteString
204− iso8601ParseM $ B8.unpack contents
src/Database/PostgreSQL/Simple/Time/Internal/Printer.hsdeleted−135
@@ -1,135 +0,0 @@
1−{-# LANGUAGE BangPatterns, ViewPatterns #-}
2−
3−------------------------------------------------------------------------------
4−-- Module: Database.PostgreSQL.Simple.Time.Internal.Printer
5−-- Copyright: (c) 2012-2015 Leon P Smith
6−-- License: BSD3
7−-- Maintainer: Leon P Smith <leon@melding-monads.com>
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− , calendarDiffTime
21− ) where
22−
23−import Control.Arrow ((>>>))
24−import Data.ByteString.Builder (Builder, byteString, integerDec)
25−import Data.ByteString.Builder.Prim
26− ( liftFixedToBounded, (>$<), (>*<)
27− , BoundedPrim, primBounded, condB, emptyB, FixedPrim, char8, int32Dec)
28−import Data.Char ( chr )
29−import Data.Int ( Int32, Int64 )
30−import Data.String (fromString)
31−import Data.Time.Compat
32− ( UTCTime(..), ZonedTime(..), LocalTime(..), NominalDiffTime
33− , Day, toGregorian, TimeOfDay(..), timeToTimeOfDay
34− , TimeZone, timeZoneMinutes )
35−import Data.Time.Format.ISO8601.Compat (iso8601Show)
36−import Data.Time.LocalTime.Compat (CalendarDiffTime)
37−import Database.PostgreSQL.Simple.Compat ((<>), fromPico)
38−import Unsafe.Coerce (unsafeCoerce)
39−
40−liftB :: FixedPrim a -> BoundedPrim a
41−liftB = liftFixedToBounded
42−
43−digit :: FixedPrim Int
44−digit = (\x -> chr (x + 48)) >$< char8
45−
46−digits2 :: FixedPrim Int
47−digits2 = (`quotRem` 10) >$< (digit >*< digit)
48−
49−digits3 :: FixedPrim Int
50−digits3 = (`quotRem` 10) >$< (digits2 >*< digit)
51−
52−digits4 :: FixedPrim Int
53−digits4 = (`quotRem` 10) >$< (digits3 >*< digit)
54−
55−frac :: BoundedPrim Int64
56−frac = condB (== 0) emptyB ((,) '.' >$< (liftB char8 >*< trunc12))
57− where
58− trunc12 :: BoundedPrim Int64
59− trunc12 = (`quotRem` 1000000) >$<
60− condB (\(_,y) -> y == 0)
61− (fst >$< trunc6)
62− (liftB digits6 >*< trunc6)
63−
64− digitB = liftB digit
65−
66− digits6 = (fromIntegral >>> (`quotRem` 10)) >$< (digits5 >*< digit)
67− digits5 = (`quotRem` 10) >$< (digits4 >*< digit)
68−
69− trunc6 = (fromIntegral >>> (`quotRem` 100000)) >$< (digitB >*< trunc5)
70− trunc5 = condB (== 0) emptyB ((`quotRem` 10000) >$< (digitB >*< trunc4))
71− trunc4 = condB (== 0) emptyB ((`quotRem` 1000) >$< (digitB >*< trunc3))
72− trunc3 = condB (== 0) emptyB ((`quotRem` 100) >$< (digitB >*< trunc2))
73− trunc2 = condB (== 0) emptyB ((`quotRem` 10) >$< (digitB >*< trunc1))
74− trunc1 = condB (== 0) emptyB digitB
75−
76−
77−year :: BoundedPrim Int32
78−year = condB (>= 10000) int32Dec (checkBCE >$< liftB digits4)
79− where
80− checkBCE :: Int32 -> Int
81− checkBCE y
82− | y > 0 = fromIntegral y
83− | otherwise = error msg
84−
85− msg = "Database.PostgreSQL.Simple.Time.Printer.year: years BCE not supported"
86−
87−day :: BoundedPrim Day
88−day = toYMD >$< (year >*< liftB (char8 >*< digits2 >*< char8 >*< digits2))
89− where
90− toYMD (toGregorian -> (fromIntegral -> !y, !m,!d)) = (y,('-',(m,('-',d))))
91−
92−timeOfDay :: BoundedPrim TimeOfDay
93−timeOfDay = f >$< (hh_mm_ >*< ss)
94− where
95− f (TimeOfDay h m s) = ((h,(':',(m,':'))),s)
96−
97− hh_mm_ = liftB (digits2 >*< char8 >*< digits2 >*< char8)
98−
99− ss = (\s -> fromIntegral (fromPico s) `quotRem` 1000000000000) >$<
100− (liftB (fromIntegral >$< digits2) >*< frac)
101−
102−timeZone :: BoundedPrim TimeZone
103−timeZone = timeZoneMinutes >$< tz
104− where
105− tz = condB (>= 0) ((,) '+' >$< tzh) ((,) '-' . negate >$< tzh)
106−
107− tzh = liftB char8 >*< ((`quotRem` 60) >$< (liftB digits2 >*< tzm))
108−
109− tzm = condB (==0) emptyB ((,) ':' >$< liftB (char8 >*< digits2))
110−
111−utcTime :: BoundedPrim UTCTime
112−utcTime = f >$< (day >*< liftB char8 >*< timeOfDay >*< liftB char8)
113− where f (UTCTime d (timeToTimeOfDay -> tod)) = (d,(' ',(tod,'Z')))
114−
115−localTime :: BoundedPrim LocalTime
116−localTime = f >$< (day >*< liftB char8 >*< timeOfDay)
117− where f (LocalTime d tod) = (d, (' ', tod))
118−
119−zonedTime :: BoundedPrim ZonedTime
120−zonedTime = f >$< (localTime >*< timeZone)
121− where f (ZonedTime lt tz) = (lt, tz)
122−
123−
124−nominalDiffTime :: NominalDiffTime -> Builder
125−nominalDiffTime xy = integerDec x <> primBounded frac (abs (fromIntegral y))
126− where
127− (x,y) = fromPico (unsafeCoerce xy) `quotRem` 1000000000000
128−
129−calendarDiffTime :: CalendarDiffTime -> Builder
130−calendarDiffTime = byteString
131− . fromString
132− -- from the docs: "Beware: fromString truncates multi-byte characters to octets".
133− -- However, I think this is a safe usage, because ISO8601-encoding seems restricted
134− -- to ASCII output.
135− . iso8601Show
src/Database/PostgreSQL/Simple/ToField.hsdeleted−393
@@ -1,393 +0,0 @@
1−{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-}
2−{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
3−{-# LANGUAGE PolyKinds #-}
4−
5−------------------------------------------------------------------------------
6−-- |
7−-- Module: Database.PostgreSQL.Simple.ToField
8−-- Copyright: (c) 2011 MailRank, Inc.
9−-- (c) 2011-2012 Leon P Smith
10−-- License: BSD3
11−-- Maintainer: Leon P Smith <leon@melding-monads.com>
12−-- Stability: experimental
13−--
14−-- The 'ToField' typeclass, for rendering a parameter to a SQL query.
15−--
16−------------------------------------------------------------------------------
17−
18−module Database.PostgreSQL.Simple.ToField
19− (
20− Action(..)
21− , ToField(..)
22− , toJSONField
23− , inQuotes
24− ) where
25−
26−import Control.Applicative (Const(Const))
27−import qualified Data.Aeson as JSON
28−import Data.ByteString (ByteString)
29−import Data.ByteString.Builder
30− ( Builder, byteString, char8, stringUtf8
31− , intDec, int8Dec, int16Dec, int32Dec, int64Dec, integerDec
32− , wordDec, word8Dec, word16Dec, word32Dec, word64Dec
33− , floatDec, doubleDec
34− )
35−import Data.Functor.Identity (Identity(Identity))
36−import Data.Int (Int8, Int16, Int32, Int64)
37−import Data.List (intersperse)
38−import Data.Monoid (mappend)
39−import Data.Time.Compat (Day, TimeOfDay, LocalTime, UTCTime, ZonedTime, NominalDiffTime)
40−import Data.Time.LocalTime.Compat (CalendarDiffTime)
41−import Data.Typeable (Typeable)
42−import Data.Word (Word, Word8, Word16, Word32, Word64)
43−import {-# SOURCE #-} Database.PostgreSQL.Simple.ToRow
44−import Database.PostgreSQL.Simple.Types
45−import Database.PostgreSQL.Simple.Compat (toByteString)
46−
47−import qualified Data.ByteString as SB
48−import qualified Data.ByteString.Lazy as LB
49−import Data.CaseInsensitive (CI)
50−import qualified Data.CaseInsensitive as CI
51−import qualified Data.Text as ST
52−import qualified Data.Text.Encoding as ST
53−import qualified Data.Text.Lazy as LT
54−import qualified Data.Text.Lazy.Builder as LT
55−import Data.UUID.Types (UUID)
56−import qualified Data.UUID.Types as UUID
57−import Data.Vector (Vector)
58−import qualified Data.Vector as V
59−import qualified Database.PostgreSQL.LibPQ as PQ
60−import Database.PostgreSQL.Simple.Time
61−import Data.Scientific (Scientific)
62−import Data.Text.Lazy.Builder.Scientific (scientificBuilder)
63−import Foreign.C.Types (CUInt(..))
64−
65−-- | How to render an element when substituting it into a query.
66−data Action =
67− Plain Builder
68− -- ^ Render without escaping or quoting. Use for non-text types
69− -- such as numbers, when you are /certain/ that they will not
70− -- introduce formatting vulnerabilities via use of characters such
71− -- as spaces or \"@'@\".
72− | Escape ByteString
73− -- ^ Escape and enclose in quotes before substituting. Use for all
74− -- text-like types, and anything else that may contain unsafe
75− -- characters when rendered.
76− | EscapeByteA ByteString
77− -- ^ Escape binary data for use as a @bytea@ literal. Include surrounding
78− -- quotes. This is used by the 'Binary' newtype wrapper.
79− | EscapeIdentifier ByteString
80− -- ^ Escape before substituting. Use for all sql identifiers like
81− -- table, column names, etc. This is used by the 'Identifier' newtype
82− -- wrapper.
83− | Many [Action]
84− -- ^ Concatenate a series of rendering actions.
85− deriving (Typeable)
86−
87−instance Show Action where
88− show (Plain b) = "Plain " ++ show (toByteString b)
89− show (Escape b) = "Escape " ++ show b
90− show (EscapeByteA b) = "EscapeByteA " ++ show b
91− show (EscapeIdentifier b) = "EscapeIdentifier " ++ show b
92− show (Many b) = "Many " ++ show b
93−
94−-- | A type that may be used as a single parameter to a SQL query.
95−class ToField a where
96− toField :: a -> Action
97− -- ^ Prepare a value for substitution into a query string.
98−
99−instance ToField Action where
100− toField a = a
101− {-# INLINE toField #-}
102−
103−instance (ToField a) => ToField (Const a b) where
104− toField (Const a) = toField a
105− {-# INLINE toField #-}
106−
107−instance (ToField a) => ToField (Identity a) where
108− toField (Identity a) = toField a
109− {-# INLINE toField #-}
110−
111−instance (ToField a) => ToField (Maybe a) where
112− toField Nothing = renderNull
113− toField (Just a) = toField a
114− {-# INLINE toField #-}
115−
116−instance (ToField a) => ToField (In [a]) where
117− toField (In []) = Plain $ byteString "(null)"
118− toField (In xs) = Many $
119− Plain (char8 '(') :
120− (intersperse (Plain (char8 ',')) . map toField $ xs) ++
121− [Plain (char8 ')')]
122−
123−renderNull :: Action
124−renderNull = Plain (byteString "null")
125−
126−instance ToField Null where
127− toField _ = renderNull
128− {-# INLINE toField #-}
129−
130−instance ToField Default where
131− toField _ = Plain (byteString "default")
132− {-# INLINE toField #-}
133−
134−instance ToField Bool where
135− toField True = Plain (byteString "true")
136− toField False = Plain (byteString "false")
137− {-# INLINE toField #-}
138−
139−instance ToField Int8 where
140− toField = Plain . int8Dec
141− {-# INLINE toField #-}
142−
143−instance ToField Int16 where
144− toField = Plain . int16Dec
145− {-# INLINE toField #-}
146−
147−instance ToField Int32 where
148− toField = Plain . int32Dec
149− {-# INLINE toField #-}
150−
151−instance ToField Int where
152− toField = Plain . intDec
153− {-# INLINE toField #-}
154−
155−instance ToField Int64 where
156− toField = Plain . int64Dec
157− {-# INLINE toField #-}
158−
159−instance ToField Integer where
160− toField = Plain . integerDec
161− {-# INLINE toField #-}
162−
163−instance ToField Word8 where
164− toField = Plain . word8Dec
165− {-# INLINE toField #-}
166−
167−instance ToField Word16 where
168− toField = Plain . word16Dec
169− {-# INLINE toField #-}
170−
171−instance ToField Word32 where
172− toField = Plain . word32Dec
173− {-# INLINE toField #-}
174−
175−instance ToField Word where
176− toField = Plain . wordDec
177− {-# INLINE toField #-}
178−
179−instance ToField Word64 where
180− toField = Plain . word64Dec
181− {-# INLINE toField #-}
182−
183−instance ToField PQ.Oid where
184− toField = Plain . \(PQ.Oid (CUInt x)) -> word32Dec x
185− {-# INLINE toField #-}
186−
187−instance ToField Float where
188− toField v | isNaN v || isInfinite v = Plain (inQuotes (floatDec v))
189− | otherwise = Plain (floatDec v)
190− {-# INLINE toField #-}
191−
192−instance ToField Double where
193− toField v | isNaN v || isInfinite v = Plain (inQuotes (doubleDec v))
194− | otherwise = Plain (doubleDec v)
195− {-# INLINE toField #-}
196−
197−instance ToField Scientific where
198− toField x = toField (LT.toLazyText (scientificBuilder x))
199− {-# INLINE toField #-}
200−
201−instance ToField (Binary SB.ByteString) where
202− toField (Binary bs) = EscapeByteA bs
203− {-# INLINE toField #-}
204−
205−instance ToField (Binary LB.ByteString) where
206− toField (Binary bs) = (EscapeByteA . SB.concat . LB.toChunks) bs
207− {-# INLINE toField #-}
208−
209−instance ToField Identifier where
210− toField (Identifier bs) = EscapeIdentifier (ST.encodeUtf8 bs)
211− {-# INLINE toField #-}
212−
213−instance ToField QualifiedIdentifier where
214− toField (QualifiedIdentifier (Just s) t) =
215− Many [ EscapeIdentifier (ST.encodeUtf8 s)
216− , Plain (char8 '.')
217− , EscapeIdentifier (ST.encodeUtf8 t)
218− ]
219− toField (QualifiedIdentifier Nothing t) =
220− EscapeIdentifier (ST.encodeUtf8 t)
221− {-# INLINE toField #-}
222−
223−instance ToField SB.ByteString where
224− toField = Escape
225− {-# INLINE toField #-}
226−
227−instance ToField LB.ByteString where
228− toField = toField . SB.concat . LB.toChunks
229− {-# INLINE toField #-}
230−
231−instance ToField ST.Text where
232− toField = Escape . ST.encodeUtf8
233− {-# INLINE toField #-}
234−
235−instance ToField [Char] where
236− toField = Escape . toByteString . stringUtf8
237− {-# INLINE toField #-}
238−
239−instance ToField LT.Text where
240− toField = toField . LT.toStrict
241− {-# INLINE toField #-}
242−
243−-- | citext
244−instance ToField (CI ST.Text) where
245− toField = toField . CI.original
246− {-# INLINE toField #-}
247−
248−-- | citext
249−instance ToField (CI LT.Text) where
250− toField = toField . LT.toStrict . CI.original
251− {-# INLINE toField #-}
252−
253−instance ToField UTCTime where
254− toField = Plain . inQuotes . utcTimeToBuilder
255− {-# INLINE toField #-}
256−
257−instance ToField ZonedTime where
258− toField = Plain . inQuotes . zonedTimeToBuilder
259− {-# INLINE toField #-}
260−
261−instance ToField LocalTime where
262− toField = Plain . inQuotes . localTimeToBuilder
263− {-# INLINE toField #-}
264−
265−instance ToField Day where
266− toField = Plain . inQuotes . dayToBuilder
267− {-# INLINE toField #-}
268−
269−instance ToField TimeOfDay where
270− toField = Plain . inQuotes . timeOfDayToBuilder
271− {-# INLINE toField #-}
272−
273−instance ToField UTCTimestamp where
274− toField = Plain . inQuotes . utcTimestampToBuilder
275− {-# INLINE toField #-}
276−
277−instance ToField ZonedTimestamp where
278− toField = Plain . inQuotes . zonedTimestampToBuilder
279− {-# INLINE toField #-}
280−
281−instance ToField LocalTimestamp where
282− toField = Plain . inQuotes . localTimestampToBuilder
283− {-# INLINE toField #-}
284−
285−instance ToField Date where
286− toField = Plain . inQuotes . dateToBuilder
287− {-# INLINE toField #-}
288−
289−instance ToField NominalDiffTime where
290− toField = Plain . inQuotes . nominalDiffTimeToBuilder
291− {-# INLINE toField #-}
292−
293−instance ToField CalendarDiffTime where
294− toField = Plain . inQuotes . calendarDiffTimeToBuilder
295− {-# INLINE toField #-}
296−
297−instance (ToField a) => ToField (PGArray a) where
298− toField pgArray =
299− case fromPGArray pgArray of
300− [] -> Plain (byteString "'{}'")
301− xs -> Many $
302− Plain (byteString "ARRAY[") :
303− (intersperse (Plain (char8 ',')) . map toField $ xs) ++
304− [Plain (char8 ']')]
305− -- Because the ARRAY[...] input syntax is being used, it is possible
306− -- that the use of type-specific separator characters is unnecessary.
307−
308−instance (ToField a) => ToField (Vector a) where
309− toField = toField . PGArray . V.toList
310−
311−instance ToField UUID where
312− toField = Plain . inQuotes . byteString . UUID.toASCIIBytes
313−
314−instance ToField JSON.Value where
315− toField = toField . JSON.encode
316−
317−-- | Convert a Haskell value to JSON using 'JSON.toEncoding'.
318−--
319−-- This can be used as the default implementation for the 'toField'
320−-- method for Haskell types that have a JSON representation in
321−-- PostgreSQL.
322−toJSONField :: JSON.ToJSON a => a -> Action
323−toJSONField = toField . JSON.encode
324−
325−-- | Surround a string with single-quote characters: \"@'@\"
326−--
327−-- This function /does not/ perform any other escaping.
328−inQuotes :: Builder -> Builder
329−inQuotes b = quote `mappend` b `mappend` quote
330− where quote = char8 '\''
331−
332−interleaveFoldr :: (a -> [b] -> [b]) -> b -> [b] -> [a] -> [b]
333−interleaveFoldr f b bs' as = foldr (\a bs -> b : f a bs) bs' as
334−{-# INLINE interleaveFoldr #-}
335−
336−instance ToRow a => ToField (Values a) where
337− toField (Values types rows) =
338− case rows of
339− [] -> case types of
340− [] -> error norows
341− (_:_) -> values $ typedRow (repeat (lit "null"))
342− types
343− [lit " LIMIT 0)"]
344− (_:_) -> case types of
345− [] -> values $ untypedRows rows [litC ')']
346− (_:_) -> values $ typedRows rows types [litC ')']
347− where
348− funcname = "Database.PostgreSQL.Simple.toField :: Values a -> Action"
349− norows = funcname ++ " either values or types must be non-empty"
350− emptyrow = funcname ++ " each row must contain at least one column"
351− lit = Plain . byteString
352− litC = Plain . char8
353− values x = Many (lit "(VALUES ": x)
354−
355− typedField :: (Action, QualifiedIdentifier) -> [Action] -> [Action]
356− typedField (val,typ) rest = val : lit "::" : toField typ : rest
357−
358− typedRow :: [Action] -> [QualifiedIdentifier] -> [Action] -> [Action]
359− typedRow (val:vals) (typ:typs) rest =
360− litC '(' :
361− typedField (val,typ) ( interleaveFoldr
362− typedField
363− (litC ',')
364− (litC ')' : rest)
365− (zip vals typs) )
366− typedRow _ _ _ = error emptyrow
367−
368− untypedRow :: [Action] -> [Action] -> [Action]
369− untypedRow (val:vals) rest =
370− litC '(' : val :
371− interleaveFoldr
372− (:)
373− (litC ',')
374− (litC ')' : rest)
375− vals
376− untypedRow _ _ = error emptyrow
377−
378− typedRows :: ToRow a => [a] -> [QualifiedIdentifier] -> [Action] -> [Action]
379− typedRows [] _ _ = error funcname
380− typedRows (val:vals) typs rest =
381− typedRow (toRow val) typs (multiRows vals rest)
382−
383− untypedRows :: ToRow a => [a] -> [Action] -> [Action]
384− untypedRows [] _ = error funcname
385− untypedRows (val:vals) rest =
386− untypedRow (toRow val) (multiRows vals rest)
387−
388− multiRows :: ToRow a => [a] -> [Action] -> [Action]
389− multiRows vals rest = interleaveFoldr
390− (untypedRow . toRow)
391− (litC ',')
392− rest
393− vals
src/Database/PostgreSQL/Simple/ToField.hs-bootdeleted−30
@@ -1,30 +0,0 @@
1−module Database.PostgreSQL.Simple.ToField where
2−
3−import Database.PostgreSQL.Simple.Types
4−import Data.ByteString.Builder(Builder)
5−import Data.ByteString(ByteString)
6−
7−-- | How to render an element when substituting it into a query.
8−data Action =
9− Plain Builder
10− -- ^ Render without escaping or quoting. Use for non-text types
11− -- such as numbers, when you are /certain/ that they will not
12− -- introduce formatting vulnerabilities via use of characters such
13− -- as spaces or \"@'@\".
14− | Escape ByteString
15− -- ^ Escape and enclose in quotes before substituting. Use for all
16− -- text-like types, and anything else that may contain unsafe
17− -- characters when rendered.
18− | EscapeByteA ByteString
19− -- ^ Escape binary data for use as a @bytea@ literal. Include surrounding
20− -- quotes. This is used by the 'Binary' newtype wrapper.
21− | EscapeIdentifier ByteString
22− -- ^ Escape before substituting. Use for all sql identifiers like
23− -- table, column names, etc. This is used by the 'Identifier' newtype
24− -- wrapper.
25− | Many [Action]
26− -- ^ Concatenate a series of rendering actions.
27−
28−class ToField a
29−
30−instance ToField Oid
src/Database/PostgreSQL/Simple/ToRow.hsdeleted−219
@@ -1,219 +0,0 @@
1−{-# LANGUAGE DefaultSignatures, FlexibleInstances, FlexibleContexts #-}
2−------------------------------------------------------------------------------
3−-- |
4−-- Module: Database.PostgreSQL.Simple.ToRow
5−-- Copyright: (c) 2011 MailRank, Inc.
6−-- (c) 2011-2012 Leon P Smith
7−-- License: BSD3
8−-- Maintainer: Leon P Smith <leon@melding-monads.com>
9−-- Stability: experimental
10−--
11−-- The 'ToRow' typeclass, for rendering a collection of
12−-- parameters to a SQL query.
13−--
14−-- Predefined instances are provided for tuples containing up to ten
15−-- elements.
16−--
17−------------------------------------------------------------------------------
18−
19−module Database.PostgreSQL.Simple.ToRow
20− (
21− ToRow(..)
22− ) where
23−
24−import Database.PostgreSQL.Simple.ToField (Action(..), ToField(..))
25−import Database.PostgreSQL.Simple.Types (Only(..), (:.)(..))
26−import GHC.Generics
27−
28−-- | A collection type that can be turned into a list of rendering
29−-- 'Action's.
30−--
31−-- Instances should use the 'toField' method of the 'ToField' class
32−-- to perform conversion of each element of the collection.
33−--
34−-- You can derive 'ToRow' for your data type using GHC generics, like this:
35−--
36−-- @
37−-- \{-# LANGUAGE DeriveAnyClass \#-}
38−-- \{-# LANGUAGE DeriveGeneric \#-}
39−--
40−-- import "GHC.Generics" ('GHC.Generics.Generic')
41−-- import "Database.PostgreSQL.Simple" ('ToRow')
42−--
43−-- data User = User { name :: String, fileQuota :: Int }
44−-- deriving ('GHC.Generics.Generic', 'ToRow')
45−-- @
46−--
47−-- Note that this only works for product types (e.g. records) and does not
48−-- support sum types or recursive types.
49−class ToRow a where
50− toRow :: a -> [Action]
51− default toRow :: (Generic a, GToRow (Rep a)) => a -> [Action]
52− toRow = gtoRow . from
53− -- ^ ToField a collection of values.
54−
55−instance ToRow () where
56− toRow _ = []
57−
58−instance (ToField a) => ToRow (Only a) where
59− toRow (Only v) = [toField v]
60−
61−instance (ToField a, ToField b) => ToRow (a,b) where
62− toRow (a,b) = [toField a, toField b]
63−
64−instance (ToField a, ToField b, ToField c) => ToRow (a,b,c) where
65− toRow (a,b,c) = [toField a, toField b, toField c]
66−
67−instance (ToField a, ToField b, ToField c, ToField d) => ToRow (a,b,c,d) where
68− toRow (a,b,c,d) = [toField a, toField b, toField c, toField d]
69−
70−instance (ToField a, ToField b, ToField c, ToField d, ToField e)
71− => ToRow (a,b,c,d,e) where
72− toRow (a,b,c,d,e) =
73− [toField a, toField b, toField c, toField d, toField e]
74−
75−instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f)
76− => ToRow (a,b,c,d,e,f) where
77− toRow (a,b,c,d,e,f) =
78− [toField a, toField b, toField c, toField d, toField e, toField f]
79−
80−instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,
81− ToField g)
82− => ToRow (a,b,c,d,e,f,g) where
83− toRow (a,b,c,d,e,f,g) =
84− [toField a, toField b, toField c, toField d, toField e, toField f,
85− toField g]
86−
87−instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,
88− ToField g, ToField h)
89− => ToRow (a,b,c,d,e,f,g,h) where
90− toRow (a,b,c,d,e,f,g,h) =
91− [toField a, toField b, toField c, toField d, toField e, toField f,
92− toField g, toField h]
93−
94−instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,
95− ToField g, ToField h, ToField i)
96− => ToRow (a,b,c,d,e,f,g,h,i) where
97− toRow (a,b,c,d,e,f,g,h,i) =
98− [toField a, toField b, toField c, toField d, toField e, toField f,
99− toField g, toField h, toField i]
100−
101−instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,
102− ToField g, ToField h, ToField i, ToField j)
103− => ToRow (a,b,c,d,e,f,g,h,i,j) where
104− toRow (a,b,c,d,e,f,g,h,i,j) =
105− [toField a, toField b, toField c, toField d, toField e, toField f,
106− toField g, toField h, toField i, toField j]
107−
108−instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,
109− ToField g, ToField h, ToField i, ToField j, ToField k)
110− => ToRow (a,b,c,d,e,f,g,h,i,j,k) where
111− toRow (a,b,c,d,e,f,g,h,i,j,k) =
112− [toField a, toField b, toField c, toField d, toField e, toField f,
113− toField g, toField h, toField i, toField j, toField k]
114−
115−instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,
116− ToField g, ToField h, ToField i, ToField j, ToField k, ToField l)
117− => ToRow (a,b,c,d,e,f,g,h,i,j,k,l) where
118− toRow (a,b,c,d,e,f,g,h,i,j,k,l) =
119− [toField a, toField b, toField c, toField d, toField e, toField f,
120− toField g, toField h, toField i, toField j, toField k, toField l]
121−
122−instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,
123− ToField g, ToField h, ToField i, ToField j, ToField k, ToField l,
124− ToField m)
125− => ToRow (a,b,c,d,e,f,g,h,i,j,k,l,m) where
126− toRow (a,b,c,d,e,f,g,h,i,j,k,l,m) =
127− [toField a, toField b, toField c, toField d, toField e, toField f,
128− toField g, toField h, toField i, toField j, toField k, toField l,
129− toField m]
130−
131−instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,
132− ToField g, ToField h, ToField i, ToField j, ToField k, ToField l,
133− ToField m, ToField n)
134− => ToRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n) where
135− toRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n) =
136− [toField a, toField b, toField c, toField d, toField e, toField f,
137− toField g, toField h, toField i, toField j, toField k, toField l,
138− toField m, toField n]
139−
140−instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,
141− ToField g, ToField h, ToField i, ToField j, ToField k, ToField l,
142− ToField m, ToField n, ToField o)
143− => ToRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) where
144− toRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) =
145− [toField a, toField b, toField c, toField d, toField e, toField f,
146− toField g, toField h, toField i, toField j, toField k, toField l,
147− toField m, toField n, toField o]
148−
149−instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,
150− ToField g, ToField h, ToField i, ToField j, ToField k, ToField l,
151− ToField m, ToField n, ToField o, ToField p)
152− => ToRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) where
153− toRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) =
154− [toField a, toField b, toField c, toField d, toField e, toField f,
155− toField g, toField h, toField i, toField j, toField k, toField l,
156− toField m, toField n, toField o, toField p]
157−
158−instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,
159− ToField g, ToField h, ToField i, ToField j, ToField k, ToField l,
160− ToField m, ToField n, ToField o, ToField p, ToField q)
161− => ToRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q) where
162− toRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q) =
163− [toField a, toField b, toField c, toField d, toField e, toField f,
164− toField g, toField h, toField i, toField j, toField k, toField l,
165− toField m, toField n, toField o, toField p, toField q]
166−
167−instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,
168− ToField g, ToField h, ToField i, ToField j, ToField k, ToField l,
169− ToField m, ToField n, ToField o, ToField p, ToField q, ToField r)
170− => ToRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r) where
171− toRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r) =
172− [toField a, toField b, toField c, toField d, toField e, toField f,
173− toField g, toField h, toField i, toField j, toField k, toField l,
174− toField m, toField n, toField o, toField p, toField q, toField r]
175−
176−instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,
177− ToField g, ToField h, ToField i, ToField j, ToField k, ToField l,
178− ToField m, ToField n, ToField o, ToField p, ToField q, ToField r,
179− ToField s)
180− => ToRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s) where
181− toRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s) =
182− [toField a, toField b, toField c, toField d, toField e, toField f,
183− toField g, toField h, toField i, toField j, toField k, toField l,
184− toField m, toField n, toField o, toField p, toField q, toField r,
185− toField s]
186−
187−instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,
188− ToField g, ToField h, ToField i, ToField j, ToField k, ToField l,
189− ToField m, ToField n, ToField o, ToField p, ToField q, ToField r,
190− ToField s, ToField t)
191− => ToRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t) where
192− toRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t) =
193− [toField a, toField b, toField c, toField d, toField e, toField f,
194− toField g, toField h, toField i, toField j, toField k, toField l,
195− toField m, toField n, toField o, toField p, toField q, toField r,
196− toField s, toField t]
197−
198−instance (ToField a) => ToRow [a] where
199− toRow = map toField
200−
201−instance (ToRow a, ToRow b) => ToRow (a :. b) where
202− toRow (a :. b) = toRow a ++ toRow b
203−
204−
205−-- Type class for default implementation of ToRow using generics
206−class GToRow f where
207− gtoRow :: f p -> [Action]
208−
209−instance GToRow f => GToRow (M1 c i f) where
210− gtoRow (M1 x) = gtoRow x
211−
212−instance (GToRow f, GToRow g) => GToRow (f :*: g) where
213− gtoRow (f :*: g) = gtoRow f ++ gtoRow g
214−
215−instance (ToField a) => GToRow (K1 R a) where
216− gtoRow (K1 a) = [toField a]
217−
218−instance GToRow U1 where
219− gtoRow _ = []
src/Database/PostgreSQL/Simple/ToRow.hs-bootdeleted−18
@@ -1,18 +0,0 @@
1−{-# LANGUAGE DefaultSignatures, FlexibleInstances, FlexibleContexts #-}
2−module Database.PostgreSQL.Simple.ToRow (
3− ToRow(..)
4− ) where
5−
6−import Database.PostgreSQL.Simple.Types
7−import {-# SOURCE #-} Database.PostgreSQL.Simple.ToField
8−import GHC.Generics
9−
10−class ToRow a where
11− toRow :: a -> [Action]
12− default toRow :: (Generic a, GToRow (Rep a)) => a -> [Action]
13− toRow = gtoRow . from
14−
15−class GToRow f where
16− gtoRow :: f p -> [Action]
17−
18−instance ToField a => ToRow (Only a)
src/Database/PostgreSQL/Simple/Transaction.hsdeleted−264
@@ -1,264 +0,0 @@
1−{-# LANGUAGE RecordWildCards, ScopedTypeVariables #-}
2−
3−------------------------------------------------------------------------------
4−-- |
5−-- Module: Database.PostgreSQL.Simple.Transaction
6−-- Copyright: (c) 2011-2013 Leon P Smith
7−-- (c) 2013 Joey Adams
8−-- License: BSD3
9−-- Maintainer: Leon P Smith <leon@melding-monads.com>
10−--
11−------------------------------------------------------------------------------
12−
13−module Database.PostgreSQL.Simple.Transaction
14− (
15− -- * Transaction handling
16− withTransaction
17− , withTransactionLevel
18− , withTransactionMode
19− , withTransactionModeRetry
20− , withTransactionModeRetry'
21− , withTransactionSerializable
22− , TransactionMode(..)
23− , IsolationLevel(..)
24− , ReadWriteMode(..)
25− , defaultTransactionMode
26− , defaultIsolationLevel
27− , defaultReadWriteMode
28−-- , Base.autocommit
29− , begin
30− , beginLevel
31− , beginMode
32− , commit
33− , rollback
34−
35− -- * Savepoint
36− , withSavepoint
37− , Savepoint
38− , newSavepoint
39− , releaseSavepoint
40− , rollbackToSavepoint
41− , rollbackToAndReleaseSavepoint
42−
43− -- * Error predicates
44− , isSerializationError
45− , isNoActiveTransactionError
46− , isFailedTransactionError
47− ) where
48−
49−import qualified Control.Exception as E
50−import qualified Data.ByteString as B
51−import Database.PostgreSQL.Simple.Internal
52−import Database.PostgreSQL.Simple.Types
53−import Database.PostgreSQL.Simple.Errors
54−import Database.PostgreSQL.Simple.Compat (mask, (<>))
55−
56−
57−-- | Of the four isolation levels defined by the SQL standard,
58−-- these are the three levels distinguished by PostgreSQL as of version 9.0.
59−-- See <https://www.postgresql.org/docs/9.5/static/transaction-iso.html>
60−-- for more information. Note that prior to PostgreSQL 9.0, 'RepeatableRead'
61−-- was equivalent to 'Serializable'.
62−
63−data IsolationLevel
64− = DefaultIsolationLevel -- ^ the isolation level will be taken from
65− -- PostgreSQL's per-connection
66− -- @default_transaction_isolation@ variable,
67− -- which is initialized according to the
68− -- server's config. The default configuration
69− -- is 'ReadCommitted'.
70− | ReadCommitted
71− | RepeatableRead
72− | Serializable
73− deriving (Show, Eq, Ord, Enum, Bounded)
74−
75−data ReadWriteMode
76− = DefaultReadWriteMode -- ^ the read-write mode will be taken from
77− -- PostgreSQL's per-connection
78− -- @default_transaction_read_only@ variable,
79− -- which is initialized according to the
80− -- server's config. The default configuration
81− -- is 'ReadWrite'.
82− | ReadWrite
83− | ReadOnly
84− deriving (Show, Eq, Ord, Enum, Bounded)
85−
86−data TransactionMode = TransactionMode {
87− isolationLevel :: !IsolationLevel,
88− readWriteMode :: !ReadWriteMode
89− } deriving (Show, Eq)
90−
91−defaultTransactionMode :: TransactionMode
92−defaultTransactionMode = TransactionMode
93− defaultIsolationLevel
94− defaultReadWriteMode
95−
96−defaultIsolationLevel :: IsolationLevel
97−defaultIsolationLevel = DefaultIsolationLevel
98−
99−defaultReadWriteMode :: ReadWriteMode
100−defaultReadWriteMode = DefaultReadWriteMode
101−
102−-- | Execute an action inside a SQL transaction.
103−--
104−-- This function initiates a transaction with a \"@begin
105−-- transaction@\" statement, then executes the supplied action. If
106−-- the action succeeds, the transaction will be completed with
107−-- 'Base.commit' before this function returns.
108−--
109−-- If the action throws /any/ kind of exception (not just a
110−-- PostgreSQL-related exception), the transaction will be rolled back using
111−-- 'rollback', then the exception will be rethrown.
112−--
113−-- For nesting transactions, see 'withSavepoint'.
114−withTransaction :: Connection -> IO a -> IO a
115−withTransaction = withTransactionMode defaultTransactionMode
116−
117−-- | Execute an action inside of a 'Serializable' transaction. If a
118−-- serialization failure occurs, roll back the transaction and try again.
119−-- Be warned that this may execute the IO action multiple times.
120−--
121−-- A 'Serializable' transaction creates the illusion that your program has
122−-- exclusive access to the database. This means that, even in a concurrent
123−-- setting, you can perform queries in sequence without having to worry about
124−-- what might happen between one statement and the next.
125−--
126−-- Think of it as STM, but without @retry@.
127−withTransactionSerializable :: Connection -> IO a -> IO a
128−withTransactionSerializable =
129− withTransactionModeRetry
130− TransactionMode
131− { isolationLevel = Serializable
132− , readWriteMode = ReadWrite
133− }
134− isSerializationError
135−
136−-- | Execute an action inside a SQL transaction with a given isolation level.
137−withTransactionLevel :: IsolationLevel -> Connection -> IO a -> IO a
138−withTransactionLevel lvl
139− = withTransactionMode defaultTransactionMode { isolationLevel = lvl }
140−
141−-- | Execute an action inside a SQL transaction with a given transaction mode.
142−withTransactionMode :: TransactionMode -> Connection -> IO a -> IO a
143−withTransactionMode mode conn act =
144− mask $ \restore -> do
145− beginMode mode conn
146− r <- restore act `E.onException` rollback_ conn
147− commit conn
148− return r
149−
150−-- | 'withTransactionModeRetry'' but with the exception type pinned to 'SqlError'.
151−withTransactionModeRetry :: TransactionMode -> (SqlError -> Bool) -> Connection -> IO a -> IO a
152−withTransactionModeRetry = withTransactionModeRetry'
153−
154−-- | Like 'withTransactionMode', but also takes a custom callback to
155−-- determine if a transaction should be retried if an exception occurs.
156−-- If the callback returns 'True', then the transaction will be retried.
157−-- If the callback returns 'False', or an exception other than an @e@
158−-- occurs then the transaction will be rolled back and the exception rethrown.
159−--
160−-- This is used to implement 'withTransactionSerializable'.
161−withTransactionModeRetry' :: forall a e. E.Exception e => TransactionMode -> (e -> Bool) -> Connection -> IO a -> IO a
162−withTransactionModeRetry' mode shouldRetry conn act =
163− mask $ \restore ->
164− retryLoop $ E.try $ do
165− a <- restore act `E.onException` rollback_ conn
166− commit conn
167− return a
168− where
169− retryLoop :: IO (Either e a) -> IO a
170− retryLoop act' = do
171− beginMode mode conn
172− r <- act'
173− case r of
174− Left e ->
175− case shouldRetry e of
176− True -> retryLoop act'
177− False -> E.throwIO e
178− Right a ->
179− return a
180−
181−-- | Rollback a transaction.
182−rollback :: Connection -> IO ()
183−rollback conn = execute_ conn "ROLLBACK" >> return ()
184−
185−-- | Rollback a transaction, ignoring any @IOErrors@
186−rollback_ :: Connection -> IO ()
187−rollback_ conn = rollback conn `E.catch` \(_ :: IOError) -> return ()
188−
189−-- | Commit a transaction.
190−commit :: Connection -> IO ()
191−commit conn = execute_ conn "COMMIT" >> return ()
192−
193−-- | Begin a transaction.
194−begin :: Connection -> IO ()
195−begin = beginMode defaultTransactionMode
196−
197−-- | Begin a transaction with a given isolation level
198−beginLevel :: IsolationLevel -> Connection -> IO ()
199−beginLevel lvl = beginMode defaultTransactionMode { isolationLevel = lvl }
200−
201−-- | Begin a transaction with a given transaction mode
202−beginMode :: TransactionMode -> Connection -> IO ()
203−beginMode mode conn = do
204− _ <- execute_ conn $! Query (B.concat ["BEGIN", isolevel, readmode])
205− return ()
206− where
207− isolevel = case isolationLevel mode of
208− DefaultIsolationLevel -> ""
209− ReadCommitted -> " ISOLATION LEVEL READ COMMITTED"
210− RepeatableRead -> " ISOLATION LEVEL REPEATABLE READ"
211− Serializable -> " ISOLATION LEVEL SERIALIZABLE"
212− readmode = case readWriteMode mode of
213− DefaultReadWriteMode -> ""
214− ReadWrite -> " READ WRITE"
215− ReadOnly -> " READ ONLY"
216−
217−------------------------------------------------------------------------
218−-- Savepoint
219−
220−-- | Create a savepoint, and roll back to it if an error occurs. This may only
221−-- be used inside of a transaction, and provides a sort of
222−-- \"nested transaction\".
223−--
224−-- See <https://www.postgresql.org/docs/9.5/static/sql-savepoint.html>
225−withSavepoint :: Connection -> IO a -> IO a
226−withSavepoint conn body =
227− mask $ \restore -> do
228− sp <- newSavepoint conn
229− r <- restore body `E.onException` rollbackToAndReleaseSavepoint conn sp
230− releaseSavepoint conn sp `E.catch` \err ->
231− if isFailedTransactionError err
232− then rollbackToAndReleaseSavepoint conn sp
233− else E.throwIO err
234− return r
235−
236−-- | Create a new savepoint. This may only be used inside of a transaction.
237−newSavepoint :: Connection -> IO Savepoint
238−newSavepoint conn = do
239− name <- newTempName conn
240− _ <- execute_ conn ("SAVEPOINT " <> name)
241− return (Savepoint name)
242−
243−-- | Destroy a savepoint, but retain its effects.
244−--
245−-- Warning: this will throw a 'SqlError' matching 'isFailedTransactionError' if
246−-- the transaction is aborted due to an error. 'commit' would merely warn and
247−-- roll back.
248−releaseSavepoint :: Connection -> Savepoint -> IO ()
249−releaseSavepoint conn (Savepoint name) =
250− execute_ conn ("RELEASE SAVEPOINT " <> name) >> return ()
251−
252−-- | Roll back to a savepoint. This will not release the savepoint.
253−rollbackToSavepoint :: Connection -> Savepoint -> IO ()
254−rollbackToSavepoint conn (Savepoint name) =
255− execute_ conn ("ROLLBACK TO SAVEPOINT " <> name) >> return ()
256−
257−-- | Roll back to a savepoint and release it. This is like calling
258−-- 'rollbackToSavepoint' followed by 'releaseSavepoint', but avoids a
259−-- round trip to the database server.
260−rollbackToAndReleaseSavepoint :: Connection -> Savepoint -> IO ()
261−rollbackToAndReleaseSavepoint conn (Savepoint name) =
262− execute_ conn sql >> return ()
263− where
264− sql = "ROLLBACK TO SAVEPOINT " <> name <> "; RELEASE SAVEPOINT " <> name
src/Database/PostgreSQL/Simple/TypeInfo.hsdeleted−121
@@ -1,121 +0,0 @@
1−{-# LANGUAGE RecordWildCards #-}
2−
3−------------------------------------------------------------------------------
4−-- |
5−-- Module: Database.PostgreSQL.Simple.TypeInfo
6−-- Copyright: (c) 2013 Leon P Smith
7−-- License: BSD3
8−-- Maintainer: Leon P Smith <leon@melding-monads.com>
9−-- Stability: experimental
10−--
11−-- This module provides convenient and efficient access to parts of the
12−-- @pg_type@ metatable. At the moment, this requires PostgreSQL 8.4 if
13−-- you need to work with types that do not appear in
14−-- 'Database.PostgreSQL.Simple.TypeInfo.Static'.
15−--
16−-- The current scheme could be more efficient, especially for some use
17−-- cases. In particular, connection pools that use many user-added
18−-- types and connect to a set of servers with identical (or at least
19−-- compatible) @pg_type@ and associated tables could share a common
20−-- typeinfo cache, thus saving memory and communication between the
21−-- client and server.
22−--
23−------------------------------------------------------------------------------
24−
25−module Database.PostgreSQL.Simple.TypeInfo
26− ( getTypeInfo
27− , TypeInfo(..)
28− , Attribute(..)
29− ) where
30−
31−import qualified Data.ByteString as B
32−import qualified Data.IntMap as IntMap
33−import qualified Data.Vector as V
34−import qualified Data.Vector.Mutable as MV
35−import Control.Concurrent.MVar
36−import Control.Exception (throw)
37−
38−import qualified Database.PostgreSQL.LibPQ as PQ
39−import {-# SOURCE #-} Database.PostgreSQL.Simple
40−import Database.PostgreSQL.Simple.Internal
41−import Database.PostgreSQL.Simple.Types
42−import Database.PostgreSQL.Simple.TypeInfo.Types
43−import Database.PostgreSQL.Simple.TypeInfo.Static
44−
45−-- | Returns the metadata of the type with a particular oid. To find
46−-- this data, 'getTypeInfo' first consults postgresql-simple's
47−-- built-in 'staticTypeInfo' table, then checks the connection's
48−-- typeinfo cache. Finally, the database's 'pg_type' table will
49−-- be queried only if necessary, and the result will be stored
50−-- in the connections's cache.
51−
52−getTypeInfo :: Connection -> PQ.Oid -> IO TypeInfo
53−getTypeInfo conn@Connection{..} oid' =
54− case staticTypeInfo oid' of
55− Just name' -> return name'
56− Nothing -> modifyMVar connectionObjects $ getTypeInfo' conn oid'
57−
58−getTypeInfo' :: Connection -> PQ.Oid -> TypeInfoCache
59− -> IO (TypeInfoCache, TypeInfo)
60−getTypeInfo' conn oid' oidmap =
61− case IntMap.lookup (oid2int oid') oidmap of
62− Just typeinfo -> return (oidmap, typeinfo)
63− Nothing -> do
64− names <- query conn "SELECT oid, typcategory, typdelim, typname,\
65− \ typelem, typrelid\
66− \ FROM pg_type WHERE oid = ?"
67− (Only oid')
68− (oidmap', typeInfo) <-
69− case names of
70− [] -> return $ throw (fatalError "invalid type oid")
71− [(typoid, typcategory, typdelim, typname, typelem_, typrelid)] -> do
72− case typcategory of
73− 'A' -> do
74− (oidmap', typelem) <- getTypeInfo' conn typelem_ oidmap
75− let !typeInfo = Array{..}
76− return $! (oidmap', typeInfo)
77− 'R' -> do
78− rngsubtypeOids <- query conn "SELECT rngsubtype\
79− \ FROM pg_range\
80− \ WHERE rngtypid = ?"
81− (Only oid')
82− case rngsubtypeOids of
83− [Only rngsubtype_] -> do
84− (oidmap', rngsubtype) <-
85− getTypeInfo' conn rngsubtype_ oidmap
86− let !typeInfo = Range{..}
87− return $! (oidmap', typeInfo)
88− _ -> fail "range subtype query failed to return exactly one result"
89− 'C' -> do
90− cols <- query conn "SELECT attname, atttypid\
91− \ FROM pg_attribute\
92− \ WHERE attrelid = ?\
93− \ AND attnum > 0\
94− \ AND NOT attisdropped\
95− \ ORDER BY attnum"
96− (Only typrelid)
97− vec <- MV.new $! length cols
98− (oidmap', attributes) <- getAttInfos conn cols oidmap vec 0
99− let !typeInfo = Composite{..}
100− return $! (oidmap', typeInfo)
101− _ -> do
102− let !typeInfo = Basic{..}
103− return $! (oidmap, typeInfo)
104− _ -> fail "typename query returned more than one result"
105− -- oid is a primary key, so the query should
106− -- never return more than one result
107− let !oidmap'' = IntMap.insert (oid2int oid') typeInfo oidmap'
108− return $! (oidmap'', typeInfo)
109−
110−getAttInfos :: Connection -> [(B.ByteString, PQ.Oid)] -> TypeInfoCache
111− -> MV.IOVector Attribute -> Int
112− -> IO (TypeInfoCache, V.Vector Attribute)
113−getAttInfos conn cols oidmap vec n =
114− case cols of
115− [] -> do
116− !attributes <- V.unsafeFreeze vec
117− return $! (oidmap, attributes)
118− ((attname, attTypeOid):xs) -> do
119− (oidmap', atttype) <- getTypeInfo' conn attTypeOid oidmap
120− MV.write vec n $! Attribute{..}
121− getAttInfos conn xs oidmap' vec (n+1)
src/Database/PostgreSQL/Simple/TypeInfo/Macro.hsdeleted−53
@@ -1,53 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−#if __GLASGOW_HASKELL__ >= 800
3−{-# LANGUAGE TemplateHaskellQuotes #-}
4−#else
5−{-# LANGUAGE TemplateHaskell #-}
6−#endif
7−
8−------------------------------------------------------------------------------
9−-- |
10−-- Module: Database.PostgreSQL.Simple.TypeInfo.Macro
11−-- Copyright: (c) 2013 Leon P Smith
12−-- License: BSD3
13−-- Maintainer: Leon P Smith <leon@melding-monads.com>
14−-- Stability: experimental
15−--
16−-- A Template Haskell macro for efficiently checking membership in
17−-- a set of type oids.
18−--
19−------------------------------------------------------------------------------
20−
21−module Database.PostgreSQL.Simple.TypeInfo.Macro
22− ( mkCompats
23− , inlineTypoid
24− ) where
25−
26−import Database.PostgreSQL.Simple.TypeInfo.Static
27−import Database.PostgreSQL.Simple.Types (Oid(..))
28−import Language.Haskell.TH
29−
30−-- | Returns an expression that has type @'Oid' -> 'Bool'@, true if the
31−-- oid is equal to any one of the 'typoid's of the given 'TypeInfo's.
32−mkCompats :: [TypeInfo] -> ExpQ
33−mkCompats tys = do
34− x <- newName "x"
35− lamE [conP 'Oid [varP x]] $ caseE (varE x) (map alt tys ++ [catchAll])
36− where
37− alt :: TypeInfo -> MatchQ
38− alt ty = match (inlineTypoidP ty) (normalB [| True |]) []
39−
40− catchAll :: MatchQ
41− catchAll = match wildP (normalB [| False |]) []
42−
43−-- | Literally substitute the 'typoid' of a 'TypeInfo' expression.
44−-- Returns an expression of type 'Oid'. Useful because GHC tends
45−-- not to fold constants.
46−inlineTypoid :: TypeInfo -> ExpQ
47−inlineTypoid ty = conE 'Oid `appE` litE (getTypoid ty)
48−
49−inlineTypoidP :: TypeInfo -> PatQ
50−inlineTypoidP ty = litP (getTypoid ty)
51−
52−getTypoid :: TypeInfo -> Lit
53−getTypoid ty = let (Oid x) = typoid ty in integerL (fromIntegral x)
src/Database/PostgreSQL/Simple/TypeInfo/Static.hsdeleted−1802
@@ -1,1802 +0,0 @@
1−------------------------------------------------------------------------------
2−-- |
3−-- Module: Database.PostgreSQL.Simple.TypeInfo
4−-- Copyright: (c) 2011-2012 Leon P Smith
5−-- License: BSD3
6−-- Maintainer: Leon P Smith <leon@melding-monads.com>
7−-- Stability: experimental
8−--
9−-- This module contains portions of the @pg_type@ table that are relevant
10−-- to postgresql-simple and are believed to not change between PostgreSQL
11−-- versions.
12−--
13−------------------------------------------------------------------------------
14−
15−-- Note that this file is generated by tools/GenTypeInfo.hs, and should
16−-- not be edited directly
17−
18−module Database.PostgreSQL.Simple.TypeInfo.Static
19− ( TypeInfo(..)
20− , staticTypeInfo
21− , bool
22− , boolOid
23− , bytea
24− , byteaOid
25− , char
26− , charOid
27− , name
28− , nameOid
29− , int8
30− , int8Oid
31− , int2
32− , int2Oid
33− , int4
34− , int4Oid
35− , regproc
36− , regprocOid
37− , text
38− , textOid
39− , oid
40− , oidOid
41− , tid
42− , tidOid
43− , xid
44− , xidOid
45− , cid
46− , cidOid
47− , xml
48− , xmlOid
49− , point
50− , pointOid
51− , lseg
52− , lsegOid
53− , path
54− , pathOid
55− , box
56− , boxOid
57− , polygon
58− , polygonOid
59− , line
60− , lineOid
61− , cidr
62− , cidrOid
63− , float4
64− , float4Oid
65− , float8
66− , float8Oid
67− , unknown
68− , unknownOid
69− , circle
70− , circleOid
71− , money
72− , moneyOid
73− , macaddr
74− , macaddrOid
75− , inet
76− , inetOid
77− , bpchar
78− , bpcharOid
79− , varchar
80− , varcharOid
81− , date
82− , dateOid
83− , time
84− , timeOid
85− , timestamp
86− , timestampOid
87− , timestamptz
88− , timestamptzOid
89− , interval
90− , intervalOid
91− , timetz
92− , timetzOid
93− , bit
94− , bitOid
95− , varbit
96− , varbitOid
97− , numeric
98− , numericOid
99− , refcursor
100− , refcursorOid
101− , record
102− , recordOid
103− , void
104− , voidOid
105− , array_record
106− , array_recordOid
107− , regprocedure
108− , regprocedureOid
109− , regoper
110− , regoperOid
111− , regoperator
112− , regoperatorOid
113− , regclass
114− , regclassOid
115− , regtype
116− , regtypeOid
117− , uuid
118− , uuidOid
119− , json
120− , jsonOid
121− , jsonb
122− , jsonbOid
123− , int2vector
124− , int2vectorOid
125− , oidvector
126− , oidvectorOid
127− , array_xml
128− , array_xmlOid
129− , array_json
130− , array_jsonOid
131− , array_line
132− , array_lineOid
133− , array_cidr
134− , array_cidrOid
135− , array_circle
136− , array_circleOid
137− , array_money
138− , array_moneyOid
139− , array_bool
140− , array_boolOid
141− , array_bytea
142− , array_byteaOid
143− , array_char
144− , array_charOid
145− , array_name
146− , array_nameOid
147− , array_int2
148− , array_int2Oid
149− , array_int2vector
150− , array_int2vectorOid
151− , array_int4
152− , array_int4Oid
153− , array_regproc
154− , array_regprocOid
155− , array_text
156− , array_textOid
157− , array_tid
158− , array_tidOid
159− , array_xid
160− , array_xidOid
161− , array_cid
162− , array_cidOid
163− , array_oidvector
164− , array_oidvectorOid
165− , array_bpchar
166− , array_bpcharOid
167− , array_varchar
168− , array_varcharOid
169− , array_int8
170− , array_int8Oid
171− , array_point
172− , array_pointOid
173− , array_lseg
174− , array_lsegOid
175− , array_path
176− , array_pathOid
177− , array_box
178− , array_boxOid
179− , array_float4
180− , array_float4Oid
181− , array_float8
182− , array_float8Oid
183− , array_polygon
184− , array_polygonOid
185− , array_oid
186− , array_oidOid
187− , array_macaddr
188− , array_macaddrOid
189− , array_inet
190− , array_inetOid
191− , array_timestamp
192− , array_timestampOid
193− , array_date
194− , array_dateOid
195− , array_time
196− , array_timeOid
197− , array_timestamptz
198− , array_timestamptzOid
199− , array_interval
200− , array_intervalOid
201− , array_numeric
202− , array_numericOid
203− , array_timetz
204− , array_timetzOid
205− , array_bit
206− , array_bitOid
207− , array_varbit
208− , array_varbitOid
209− , array_refcursor
210− , array_refcursorOid
211− , array_regprocedure
212− , array_regprocedureOid
213− , array_regoper
214− , array_regoperOid
215− , array_regoperator
216− , array_regoperatorOid
217− , array_regclass
218− , array_regclassOid
219− , array_regtype
220− , array_regtypeOid
221− , array_uuid
222− , array_uuidOid
223− , array_jsonb
224− , array_jsonbOid
225− , int4range
226− , int4rangeOid
227− , _int4range
228− , _int4rangeOid
229− , numrange
230− , numrangeOid
231− , _numrange
232− , _numrangeOid
233− , tsrange
234− , tsrangeOid
235− , _tsrange
236− , _tsrangeOid
237− , tstzrange
238− , tstzrangeOid
239− , _tstzrange
240− , _tstzrangeOid
241− , daterange
242− , daterangeOid
243− , _daterange
244− , _daterangeOid
245− , int8range
246− , int8rangeOid
247− , _int8range
248− , _int8rangeOid
249− ) where
250−
251−import Database.PostgreSQL.LibPQ (Oid(..))
252−import Database.PostgreSQL.Simple.TypeInfo.Types
253−
254−staticTypeInfo :: Oid -> Maybe TypeInfo
255−staticTypeInfo (Oid x) = case x of
256− 16 -> Just bool
257− 17 -> Just bytea
258− 18 -> Just char
259− 19 -> Just name
260− 20 -> Just int8
261− 21 -> Just int2
262− 23 -> Just int4
263− 24 -> Just regproc
264− 25 -> Just text
265− 26 -> Just oid
266− 27 -> Just tid
267− 28 -> Just xid
268− 29 -> Just cid
269− 142 -> Just xml
270− 600 -> Just point
271− 601 -> Just lseg
272− 602 -> Just path
273− 603 -> Just box
274− 604 -> Just polygon
275− 628 -> Just line
276− 650 -> Just cidr
277− 700 -> Just float4
278− 701 -> Just float8
279− 705 -> Just unknown
280− 718 -> Just circle
281− 790 -> Just money
282− 829 -> Just macaddr
283− 869 -> Just inet
284− 1042 -> Just bpchar
285− 1043 -> Just varchar
286− 1082 -> Just date
287− 1083 -> Just time
288− 1114 -> Just timestamp
289− 1184 -> Just timestamptz
290− 1186 -> Just interval
291− 1266 -> Just timetz
292− 1560 -> Just bit
293− 1562 -> Just varbit
294− 1700 -> Just numeric
295− 1790 -> Just refcursor
296− 2249 -> Just record
297− 2278 -> Just void
298− 2287 -> Just array_record
299− 2202 -> Just regprocedure
300− 2203 -> Just regoper
301− 2204 -> Just regoperator
302− 2205 -> Just regclass
303− 2206 -> Just regtype
304− 2950 -> Just uuid
305− 114 -> Just json
306− 3802 -> Just jsonb
307− 22 -> Just int2vector
308− 30 -> Just oidvector
309− 143 -> Just array_xml
310− 199 -> Just array_json
311− 629 -> Just array_line
312− 651 -> Just array_cidr
313− 719 -> Just array_circle
314− 791 -> Just array_money
315− 1000 -> Just array_bool
316− 1001 -> Just array_bytea
317− 1002 -> Just array_char
318− 1003 -> Just array_name
319− 1005 -> Just array_int2
320− 1006 -> Just array_int2vector
321− 1007 -> Just array_int4
322− 1008 -> Just array_regproc
323− 1009 -> Just array_text
324− 1010 -> Just array_tid
325− 1011 -> Just array_xid
326− 1012 -> Just array_cid
327− 1013 -> Just array_oidvector
328− 1014 -> Just array_bpchar
329− 1015 -> Just array_varchar
330− 1016 -> Just array_int8
331− 1017 -> Just array_point
332− 1018 -> Just array_lseg
333− 1019 -> Just array_path
334− 1020 -> Just array_box
335− 1021 -> Just array_float4
336− 1022 -> Just array_float8
337− 1027 -> Just array_polygon
338− 1028 -> Just array_oid
339− 1040 -> Just array_macaddr
340− 1041 -> Just array_inet
341− 1115 -> Just array_timestamp
342− 1182 -> Just array_date
343− 1183 -> Just array_time
344− 1185 -> Just array_timestamptz
345− 1187 -> Just array_interval
346− 1231 -> Just array_numeric
347− 1270 -> Just array_timetz
348− 1561 -> Just array_bit
349− 1563 -> Just array_varbit
350− 2201 -> Just array_refcursor
351− 2207 -> Just array_regprocedure
352− 2208 -> Just array_regoper
353− 2209 -> Just array_regoperator
354− 2210 -> Just array_regclass
355− 2211 -> Just array_regtype
356− 2951 -> Just array_uuid
357− 3807 -> Just array_jsonb
358− 3904 -> Just int4range
359− 3905 -> Just _int4range
360− 3906 -> Just numrange
361− 3907 -> Just _numrange
362− 3908 -> Just tsrange
363− 3909 -> Just _tsrange
364− 3910 -> Just tstzrange
365− 3911 -> Just _tstzrange
366− 3912 -> Just daterange
367− 3913 -> Just _daterange
368− 3926 -> Just int8range
369− 3927 -> Just _int8range
370− _ -> Nothing
371−
372−bool :: TypeInfo
373−bool = Basic {
374− typoid = boolOid,
375− typcategory = 'B',
376− typdelim = ',',
377− typname = "bool"
378− }
379−
380−boolOid :: Oid
381−boolOid = Oid 16
382−{-# INLINE boolOid #-}
383−
384−bytea :: TypeInfo
385−bytea = Basic {
386− typoid = byteaOid,
387− typcategory = 'U',
388− typdelim = ',',
389− typname = "bytea"
390− }
391−
392−byteaOid :: Oid
393−byteaOid = Oid 17
394−{-# INLINE byteaOid #-}
395−
396−char :: TypeInfo
397−char = Basic {
398− typoid = charOid,
399− typcategory = 'S',
400− typdelim = ',',
401− typname = "char"
402− }
403−
404−charOid :: Oid
405−charOid = Oid 18
406−{-# INLINE charOid #-}
407−
408−name :: TypeInfo
409−name = Basic {
410− typoid = nameOid,
411− typcategory = 'S',
412− typdelim = ',',
413− typname = "name"
414− }
415−
416−nameOid :: Oid
417−nameOid = Oid 19
418−{-# INLINE nameOid #-}
419−
420−int8 :: TypeInfo
421−int8 = Basic {
422− typoid = int8Oid,
423− typcategory = 'N',
424− typdelim = ',',
425− typname = "int8"
426− }
427−
428−int8Oid :: Oid
429−int8Oid = Oid 20
430−{-# INLINE int8Oid #-}
431−
432−int2 :: TypeInfo
433−int2 = Basic {
434− typoid = int2Oid,
435− typcategory = 'N',
436− typdelim = ',',
437− typname = "int2"
438− }
439−
440−int2Oid :: Oid
441−int2Oid = Oid 21
442−{-# INLINE int2Oid #-}
443−
444−int4 :: TypeInfo
445−int4 = Basic {
446− typoid = int4Oid,
447− typcategory = 'N',
448− typdelim = ',',
449− typname = "int4"
450− }
451−
452−int4Oid :: Oid
453−int4Oid = Oid 23
454−{-# INLINE int4Oid #-}
455−
456−regproc :: TypeInfo
457−regproc = Basic {
458− typoid = regprocOid,
459− typcategory = 'N',
460− typdelim = ',',
461− typname = "regproc"
462− }
463−
464−regprocOid :: Oid
465−regprocOid = Oid 24
466−{-# INLINE regprocOid #-}
467−
468−text :: TypeInfo
469−text = Basic {
470− typoid = textOid,
471− typcategory = 'S',
472− typdelim = ',',
473− typname = "text"
474− }
475−
476−textOid :: Oid
477−textOid = Oid 25
478−{-# INLINE textOid #-}
479−
480−oid :: TypeInfo
481−oid = Basic {
482− typoid = oidOid,
483− typcategory = 'N',
484− typdelim = ',',
485− typname = "oid"
486− }
487−
488−oidOid :: Oid
489−oidOid = Oid 26
490−{-# INLINE oidOid #-}
491−
492−tid :: TypeInfo
493−tid = Basic {
494− typoid = tidOid,
495− typcategory = 'U',
496− typdelim = ',',
497− typname = "tid"
498− }
499−
500−tidOid :: Oid
501−tidOid = Oid 27
502−{-# INLINE tidOid #-}
503−
504−xid :: TypeInfo
505−xid = Basic {
506− typoid = xidOid,
507− typcategory = 'U',
508− typdelim = ',',
509− typname = "xid"
510− }
511−
512−xidOid :: Oid
513−xidOid = Oid 28
514−{-# INLINE xidOid #-}
515−
516−cid :: TypeInfo
517−cid = Basic {
518− typoid = cidOid,
519− typcategory = 'U',
520− typdelim = ',',
521− typname = "cid"
522− }
523−
524−cidOid :: Oid
525−cidOid = Oid 29
526−{-# INLINE cidOid #-}
527−
528−xml :: TypeInfo
529−xml = Basic {
530− typoid = xmlOid,
531− typcategory = 'U',
532− typdelim = ',',
533− typname = "xml"
534− }
535−
536−xmlOid :: Oid
537−xmlOid = Oid 142
538−{-# INLINE xmlOid #-}
539−
540−point :: TypeInfo
541−point = Basic {
542− typoid = pointOid,
543− typcategory = 'G',
544− typdelim = ',',
545− typname = "point"
546− }
547−
548−pointOid :: Oid
549−pointOid = Oid 600
550−{-# INLINE pointOid #-}
551−
552−lseg :: TypeInfo
553−lseg = Basic {
554− typoid = lsegOid,
555− typcategory = 'G',
556− typdelim = ',',
557− typname = "lseg"
558− }
559−
560−lsegOid :: Oid
561−lsegOid = Oid 601
562−{-# INLINE lsegOid #-}
563−
564−path :: TypeInfo
565−path = Basic {
566− typoid = pathOid,
567− typcategory = 'G',
568− typdelim = ',',
569− typname = "path"
570− }
571−
572−pathOid :: Oid
573−pathOid = Oid 602
574−{-# INLINE pathOid #-}
575−
576−box :: TypeInfo
577−box = Basic {
578− typoid = boxOid,
579− typcategory = 'G',
580− typdelim = ';',
581− typname = "box"
582− }
583−
584−boxOid :: Oid
585−boxOid = Oid 603
586−{-# INLINE boxOid #-}
587−
588−polygon :: TypeInfo
589−polygon = Basic {
590− typoid = polygonOid,
591− typcategory = 'G',
592− typdelim = ',',
593− typname = "polygon"
594− }
595−
596−polygonOid :: Oid
597−polygonOid = Oid 604
598−{-# INLINE polygonOid #-}
599−
600−line :: TypeInfo
601−line = Basic {
602− typoid = lineOid,
603− typcategory = 'G',
604− typdelim = ',',
605− typname = "line"
606− }
607−
608−lineOid :: Oid
609−lineOid = Oid 628
610−{-# INLINE lineOid #-}
611−
612−cidr :: TypeInfo
613−cidr = Basic {
614− typoid = cidrOid,
615− typcategory = 'I',
616− typdelim = ',',
617− typname = "cidr"
618− }
619−
620−cidrOid :: Oid
621−cidrOid = Oid 650
622−{-# INLINE cidrOid #-}
623−
624−float4 :: TypeInfo
625−float4 = Basic {
626− typoid = float4Oid,
627− typcategory = 'N',
628− typdelim = ',',
629− typname = "float4"
630− }
631−
632−float4Oid :: Oid
633−float4Oid = Oid 700
634−{-# INLINE float4Oid #-}
635−
636−float8 :: TypeInfo
637−float8 = Basic {
638− typoid = float8Oid,
639− typcategory = 'N',
640− typdelim = ',',
641− typname = "float8"
642− }
643−
644−float8Oid :: Oid
645−float8Oid = Oid 701
646−{-# INLINE float8Oid #-}
647−
648−unknown :: TypeInfo
649−unknown = Basic {
650− typoid = unknownOid,
651− typcategory = 'X',
652− typdelim = ',',
653− typname = "unknown"
654− }
655−
656−unknownOid :: Oid
657−unknownOid = Oid 705
658−{-# INLINE unknownOid #-}
659−
660−circle :: TypeInfo
661−circle = Basic {
662− typoid = circleOid,
663− typcategory = 'G',
664− typdelim = ',',
665− typname = "circle"
666− }
667−
668−circleOid :: Oid
669−circleOid = Oid 718
670−{-# INLINE circleOid #-}
671−
672−money :: TypeInfo
673−money = Basic {
674− typoid = moneyOid,
675− typcategory = 'N',
676− typdelim = ',',
677− typname = "money"
678− }
679−
680−moneyOid :: Oid
681−moneyOid = Oid 790
682−{-# INLINE moneyOid #-}
683−
684−macaddr :: TypeInfo
685−macaddr = Basic {
686− typoid = macaddrOid,
687− typcategory = 'U',
688− typdelim = ',',
689− typname = "macaddr"
690− }
691−
692−macaddrOid :: Oid
693−macaddrOid = Oid 829
694−{-# INLINE macaddrOid #-}
695−
696−inet :: TypeInfo
697−inet = Basic {
698− typoid = inetOid,
699− typcategory = 'I',
700− typdelim = ',',
701− typname = "inet"
702− }
703−
704−inetOid :: Oid
705−inetOid = Oid 869
706−{-# INLINE inetOid #-}
707−
708−bpchar :: TypeInfo
709−bpchar = Basic {
710− typoid = bpcharOid,
711− typcategory = 'S',
712− typdelim = ',',
713− typname = "bpchar"
714− }
715−
716−bpcharOid :: Oid
717−bpcharOid = Oid 1042
718−{-# INLINE bpcharOid #-}
719−
720−varchar :: TypeInfo
721−varchar = Basic {
722− typoid = varcharOid,
723− typcategory = 'S',
724− typdelim = ',',
725− typname = "varchar"
726− }
727−
728−varcharOid :: Oid
729−varcharOid = Oid 1043
730−{-# INLINE varcharOid #-}
731−
732−date :: TypeInfo
733−date = Basic {
734− typoid = dateOid,
735− typcategory = 'D',
736− typdelim = ',',
737− typname = "date"
738− }
739−
740−dateOid :: Oid
741−dateOid = Oid 1082
742−{-# INLINE dateOid #-}
743−
744−time :: TypeInfo
745−time = Basic {
746− typoid = timeOid,
747− typcategory = 'D',
748− typdelim = ',',
749− typname = "time"
750− }
751−
752−timeOid :: Oid
753−timeOid = Oid 1083
754−{-# INLINE timeOid #-}
755−
756−timestamp :: TypeInfo
757−timestamp = Basic {
758− typoid = timestampOid,
759− typcategory = 'D',
760− typdelim = ',',
761− typname = "timestamp"
762− }
763−
764−timestampOid :: Oid
765−timestampOid = Oid 1114
766−{-# INLINE timestampOid #-}
767−
768−timestamptz :: TypeInfo
769−timestamptz = Basic {
770− typoid = timestamptzOid,
771− typcategory = 'D',
772− typdelim = ',',
773− typname = "timestamptz"
774− }
775−
776−timestamptzOid :: Oid
777−timestamptzOid = Oid 1184
778−{-# INLINE timestamptzOid #-}
779−
780−interval :: TypeInfo
781−interval = Basic {
782− typoid = intervalOid,
783− typcategory = 'T',
784− typdelim = ',',
785− typname = "interval"
786− }
787−
788−intervalOid :: Oid
789−intervalOid = Oid 1186
790−{-# INLINE intervalOid #-}
791−
792−timetz :: TypeInfo
793−timetz = Basic {
794− typoid = timetzOid,
795− typcategory = 'D',
796− typdelim = ',',
797− typname = "timetz"
798− }
799−
800−timetzOid :: Oid
801−timetzOid = Oid 1266
802−{-# INLINE timetzOid #-}
803−
804−bit :: TypeInfo
805−bit = Basic {
806− typoid = bitOid,
807− typcategory = 'V',
808− typdelim = ',',
809− typname = "bit"
810− }
811−
812−bitOid :: Oid
813−bitOid = Oid 1560
814−{-# INLINE bitOid #-}
815−
816−varbit :: TypeInfo
817−varbit = Basic {
818− typoid = varbitOid,
819− typcategory = 'V',
820− typdelim = ',',
821− typname = "varbit"
822− }
823−
824−varbitOid :: Oid
825−varbitOid = Oid 1562
826−{-# INLINE varbitOid #-}
827−
828−numeric :: TypeInfo
829−numeric = Basic {
830− typoid = numericOid,
831− typcategory = 'N',
832− typdelim = ',',
833− typname = "numeric"
834− }
835−
836−numericOid :: Oid
837−numericOid = Oid 1700
838−{-# INLINE numericOid #-}
839−
840−refcursor :: TypeInfo
841−refcursor = Basic {
842− typoid = refcursorOid,
843− typcategory = 'U',
844− typdelim = ',',
845− typname = "refcursor"
846− }
847−
848−refcursorOid :: Oid
849−refcursorOid = Oid 1790
850−{-# INLINE refcursorOid #-}
851−
852−record :: TypeInfo
853−record = Basic {
854− typoid = recordOid,
855− typcategory = 'P',
856− typdelim = ',',
857− typname = "record"
858− }
859−
860−recordOid :: Oid
861−recordOid = Oid 2249
862−{-# INLINE recordOid #-}
863−
864−void :: TypeInfo
865−void = Basic {
866− typoid = voidOid,
867− typcategory = 'P',
868− typdelim = ',',
869− typname = "void"
870− }
871−
872−voidOid :: Oid
873−voidOid = Oid 2278
874−{-# INLINE voidOid #-}
875−
876−array_record :: TypeInfo
877−array_record = Array {
878− typoid = array_recordOid,
879− typcategory = 'P',
880− typdelim = ',',
881− typname = "_record",
882− typelem = record
883− }
884−
885−array_recordOid :: Oid
886−array_recordOid = Oid 2287
887−{-# INLINE array_recordOid #-}
888−
889−regprocedure :: TypeInfo
890−regprocedure = Basic {
891− typoid = regprocedureOid,
892− typcategory = 'N',
893− typdelim = ',',
894− typname = "regprocedure"
895− }
896−
897−regprocedureOid :: Oid
898−regprocedureOid = Oid 2202
899−{-# INLINE regprocedureOid #-}
900−
901−regoper :: TypeInfo
902−regoper = Basic {
903− typoid = regoperOid,
904− typcategory = 'N',
905− typdelim = ',',
906− typname = "regoper"
907− }
908−
909−regoperOid :: Oid
910−regoperOid = Oid 2203
911−{-# INLINE regoperOid #-}
912−
913−regoperator :: TypeInfo
914−regoperator = Basic {
915− typoid = regoperatorOid,
916− typcategory = 'N',
917− typdelim = ',',
918− typname = "regoperator"
919− }
920−
921−regoperatorOid :: Oid
922−regoperatorOid = Oid 2204
923−{-# INLINE regoperatorOid #-}
924−
925−regclass :: TypeInfo
926−regclass = Basic {
927− typoid = regclassOid,
928− typcategory = 'N',
929− typdelim = ',',
930− typname = "regclass"
931− }
932−
933−regclassOid :: Oid
934−regclassOid = Oid 2205
935−{-# INLINE regclassOid #-}
936−
937−regtype :: TypeInfo
938−regtype = Basic {
939− typoid = regtypeOid,
940− typcategory = 'N',
941− typdelim = ',',
942− typname = "regtype"
943− }
944−
945−regtypeOid :: Oid
946−regtypeOid = Oid 2206
947−{-# INLINE regtypeOid #-}
948−
949−uuid :: TypeInfo
950−uuid = Basic {
951− typoid = uuidOid,
952− typcategory = 'U',
953− typdelim = ',',
954− typname = "uuid"
955− }
956−
957−uuidOid :: Oid
958−uuidOid = Oid 2950
959−{-# INLINE uuidOid #-}
960−
961−json :: TypeInfo
962−json = Basic {
963− typoid = jsonOid,
964− typcategory = 'U',
965− typdelim = ',',
966− typname = "json"
967− }
968−
969−jsonOid :: Oid
970−jsonOid = Oid 114
971−{-# INLINE jsonOid #-}
972−
973−jsonb :: TypeInfo
974−jsonb = Basic {
975− typoid = jsonbOid,
976− typcategory = 'U',
977− typdelim = ',',
978− typname = "jsonb"
979− }
980−
981−jsonbOid :: Oid
982−jsonbOid = Oid 3802
983−{-# INLINE jsonbOid #-}
984−
985−int2vector :: TypeInfo
986−int2vector = Array {
987− typoid = int2vectorOid,
988− typcategory = 'A',
989− typdelim = ',',
990− typname = "int2vector",
991− typelem = int2
992− }
993−
994−int2vectorOid :: Oid
995−int2vectorOid = Oid 22
996−{-# INLINE int2vectorOid #-}
997−
998−oidvector :: TypeInfo
999−oidvector = Array {
1000− typoid = oidvectorOid,
1001− typcategory = 'A',
1002− typdelim = ',',
1003− typname = "oidvector",
1004− typelem = oid
1005− }
1006−
1007−oidvectorOid :: Oid
1008−oidvectorOid = Oid 30
1009−{-# INLINE oidvectorOid #-}
1010−
1011−array_xml :: TypeInfo
1012−array_xml = Array {
1013− typoid = array_xmlOid,
1014− typcategory = 'A',
1015− typdelim = ',',
1016− typname = "_xml",
1017− typelem = xml
1018− }
1019−
1020−array_xmlOid :: Oid
1021−array_xmlOid = Oid 143
1022−{-# INLINE array_xmlOid #-}
1023−
1024−array_json :: TypeInfo
1025−array_json = Array {
1026− typoid = array_jsonOid,
1027− typcategory = 'A',
1028− typdelim = ',',
1029− typname = "_json",
1030− typelem = json
1031− }
1032−
1033−array_jsonOid :: Oid
1034−array_jsonOid = Oid 199
1035−{-# INLINE array_jsonOid #-}
1036−
1037−array_line :: TypeInfo
1038−array_line = Array {
1039− typoid = array_lineOid,
1040− typcategory = 'A',
1041− typdelim = ',',
1042− typname = "_line",
1043− typelem = line
1044− }
1045−
1046−array_lineOid :: Oid
1047−array_lineOid = Oid 629
1048−{-# INLINE array_lineOid #-}
1049−
1050−array_cidr :: TypeInfo
1051−array_cidr = Array {
1052− typoid = array_cidrOid,
1053− typcategory = 'A',
1054− typdelim = ',',
1055− typname = "_cidr",
1056− typelem = cidr
1057− }
1058−
1059−array_cidrOid :: Oid
1060−array_cidrOid = Oid 651
1061−{-# INLINE array_cidrOid #-}
1062−
1063−array_circle :: TypeInfo
1064−array_circle = Array {
1065− typoid = array_circleOid,
1066− typcategory = 'A',
1067− typdelim = ',',
1068− typname = "_circle",
1069− typelem = circle
1070− }
1071−
1072−array_circleOid :: Oid
1073−array_circleOid = Oid 719
1074−{-# INLINE array_circleOid #-}
1075−
1076−array_money :: TypeInfo
1077−array_money = Array {
1078− typoid = array_moneyOid,
1079− typcategory = 'A',
1080− typdelim = ',',
1081− typname = "_money",
1082− typelem = money
1083− }
1084−
1085−array_moneyOid :: Oid
1086−array_moneyOid = Oid 791
1087−{-# INLINE array_moneyOid #-}
1088−
1089−array_bool :: TypeInfo
1090−array_bool = Array {
1091− typoid = array_boolOid,
1092− typcategory = 'A',
1093− typdelim = ',',
1094− typname = "_bool",
1095− typelem = bool
1096− }
1097−
1098−array_boolOid :: Oid
1099−array_boolOid = Oid 1000
1100−{-# INLINE array_boolOid #-}
1101−
1102−array_bytea :: TypeInfo
1103−array_bytea = Array {
1104− typoid = array_byteaOid,
1105− typcategory = 'A',
1106− typdelim = ',',
1107− typname = "_bytea",
1108− typelem = bytea
1109− }
1110−
1111−array_byteaOid :: Oid
1112−array_byteaOid = Oid 1001
1113−{-# INLINE array_byteaOid #-}
1114−
1115−array_char :: TypeInfo
1116−array_char = Array {
1117− typoid = array_charOid,
1118− typcategory = 'A',
1119− typdelim = ',',
1120− typname = "_char",
1121− typelem = char
1122− }
1123−
1124−array_charOid :: Oid
1125−array_charOid = Oid 1002
1126−{-# INLINE array_charOid #-}
1127−
1128−array_name :: TypeInfo
1129−array_name = Array {
1130− typoid = array_nameOid,
1131− typcategory = 'A',
1132− typdelim = ',',
1133− typname = "_name",
1134− typelem = name
1135− }
1136−
1137−array_nameOid :: Oid
1138−array_nameOid = Oid 1003
1139−{-# INLINE array_nameOid #-}
1140−
1141−array_int2 :: TypeInfo
1142−array_int2 = Array {
1143− typoid = array_int2Oid,
1144− typcategory = 'A',
1145− typdelim = ',',
1146− typname = "_int2",
1147− typelem = int2
1148− }
1149−
1150−array_int2Oid :: Oid
1151−array_int2Oid = Oid 1005
1152−{-# INLINE array_int2Oid #-}
1153−
1154−array_int2vector :: TypeInfo
1155−array_int2vector = Array {
1156− typoid = array_int2vectorOid,
1157− typcategory = 'A',
1158− typdelim = ',',
1159− typname = "_int2vector",
1160− typelem = int2vector
1161− }
1162−
1163−array_int2vectorOid :: Oid
1164−array_int2vectorOid = Oid 1006
1165−{-# INLINE array_int2vectorOid #-}
1166−
1167−array_int4 :: TypeInfo
1168−array_int4 = Array {
1169− typoid = array_int4Oid,
1170− typcategory = 'A',
1171− typdelim = ',',
1172− typname = "_int4",
1173− typelem = int4
1174− }
1175−
1176−array_int4Oid :: Oid
1177−array_int4Oid = Oid 1007
1178−{-# INLINE array_int4Oid #-}
1179−
1180−array_regproc :: TypeInfo
1181−array_regproc = Array {
1182− typoid = array_regprocOid,
1183− typcategory = 'A',
1184− typdelim = ',',
1185− typname = "_regproc",
1186− typelem = regproc
1187− }
1188−
1189−array_regprocOid :: Oid
1190−array_regprocOid = Oid 1008
1191−{-# INLINE array_regprocOid #-}
1192−
1193−array_text :: TypeInfo
1194−array_text = Array {
1195− typoid = array_textOid,
1196− typcategory = 'A',
1197− typdelim = ',',
1198− typname = "_text",
1199− typelem = text
1200− }
1201−
1202−array_textOid :: Oid
1203−array_textOid = Oid 1009
1204−{-# INLINE array_textOid #-}
1205−
1206−array_tid :: TypeInfo
1207−array_tid = Array {
1208− typoid = array_tidOid,
1209− typcategory = 'A',
1210− typdelim = ',',
1211− typname = "_tid",
1212− typelem = tid
1213− }
1214−
1215−array_tidOid :: Oid
1216−array_tidOid = Oid 1010
1217−{-# INLINE array_tidOid #-}
1218−
1219−array_xid :: TypeInfo
1220−array_xid = Array {
1221− typoid = array_xidOid,
1222− typcategory = 'A',
1223− typdelim = ',',
1224− typname = "_xid",
1225− typelem = xid
1226− }
1227−
1228−array_xidOid :: Oid
1229−array_xidOid = Oid 1011
1230−{-# INLINE array_xidOid #-}
1231−
1232−array_cid :: TypeInfo
1233−array_cid = Array {
1234− typoid = array_cidOid,
1235− typcategory = 'A',
1236− typdelim = ',',
1237− typname = "_cid",
1238− typelem = cid
1239− }
1240−
1241−array_cidOid :: Oid
1242−array_cidOid = Oid 1012
1243−{-# INLINE array_cidOid #-}
1244−
1245−array_oidvector :: TypeInfo
1246−array_oidvector = Array {
1247− typoid = array_oidvectorOid,
1248− typcategory = 'A',
1249− typdelim = ',',
1250− typname = "_oidvector",
1251− typelem = oidvector
1252− }
1253−
1254−array_oidvectorOid :: Oid
1255−array_oidvectorOid = Oid 1013
1256−{-# INLINE array_oidvectorOid #-}
1257−
1258−array_bpchar :: TypeInfo
1259−array_bpchar = Array {
1260− typoid = array_bpcharOid,
1261− typcategory = 'A',
1262− typdelim = ',',
1263− typname = "_bpchar",
1264− typelem = bpchar
1265− }
1266−
1267−array_bpcharOid :: Oid
1268−array_bpcharOid = Oid 1014
1269−{-# INLINE array_bpcharOid #-}
1270−
1271−array_varchar :: TypeInfo
1272−array_varchar = Array {
1273− typoid = array_varcharOid,
1274− typcategory = 'A',
1275− typdelim = ',',
1276− typname = "_varchar",
1277− typelem = varchar
1278− }
1279−
1280−array_varcharOid :: Oid
1281−array_varcharOid = Oid 1015
1282−{-# INLINE array_varcharOid #-}
1283−
1284−array_int8 :: TypeInfo
1285−array_int8 = Array {
1286− typoid = array_int8Oid,
1287− typcategory = 'A',
1288− typdelim = ',',
1289− typname = "_int8",
1290− typelem = int8
1291− }
1292−
1293−array_int8Oid :: Oid
1294−array_int8Oid = Oid 1016
1295−{-# INLINE array_int8Oid #-}
1296−
1297−array_point :: TypeInfo
1298−array_point = Array {
1299− typoid = array_pointOid,
1300− typcategory = 'A',
1301− typdelim = ',',
1302− typname = "_point",
1303− typelem = point
1304− }
1305−
1306−array_pointOid :: Oid
1307−array_pointOid = Oid 1017
1308−{-# INLINE array_pointOid #-}
1309−
1310−array_lseg :: TypeInfo
1311−array_lseg = Array {
1312− typoid = array_lsegOid,
1313− typcategory = 'A',
1314− typdelim = ',',
1315− typname = "_lseg",
1316− typelem = lseg
1317− }
1318−
1319−array_lsegOid :: Oid
1320−array_lsegOid = Oid 1018
1321−{-# INLINE array_lsegOid #-}
1322−
1323−array_path :: TypeInfo
1324−array_path = Array {
1325− typoid = array_pathOid,
1326− typcategory = 'A',
1327− typdelim = ',',
1328− typname = "_path",
1329− typelem = path
1330− }
1331−
1332−array_pathOid :: Oid
1333−array_pathOid = Oid 1019
1334−{-# INLINE array_pathOid #-}
1335−
1336−array_box :: TypeInfo
1337−array_box = Array {
1338− typoid = array_boxOid,
1339− typcategory = 'A',
1340− typdelim = ';',
1341− typname = "_box",
1342− typelem = box
1343− }
1344−
1345−array_boxOid :: Oid
1346−array_boxOid = Oid 1020
1347−{-# INLINE array_boxOid #-}
1348−
1349−array_float4 :: TypeInfo
1350−array_float4 = Array {
1351− typoid = array_float4Oid,
1352− typcategory = 'A',
1353− typdelim = ',',
1354− typname = "_float4",
1355− typelem = float4
1356− }
1357−
1358−array_float4Oid :: Oid
1359−array_float4Oid = Oid 1021
1360−{-# INLINE array_float4Oid #-}
1361−
1362−array_float8 :: TypeInfo
1363−array_float8 = Array {
1364− typoid = array_float8Oid,
1365− typcategory = 'A',
1366− typdelim = ',',
1367− typname = "_float8",
1368− typelem = float8
1369− }
1370−
1371−array_float8Oid :: Oid
1372−array_float8Oid = Oid 1022
1373−{-# INLINE array_float8Oid #-}
1374−
1375−array_polygon :: TypeInfo
1376−array_polygon = Array {
1377− typoid = array_polygonOid,
1378− typcategory = 'A',
1379− typdelim = ',',
1380− typname = "_polygon",
1381− typelem = polygon
1382− }
1383−
1384−array_polygonOid :: Oid
1385−array_polygonOid = Oid 1027
1386−{-# INLINE array_polygonOid #-}
1387−
1388−array_oid :: TypeInfo
1389−array_oid = Array {
1390− typoid = array_oidOid,
1391− typcategory = 'A',
1392− typdelim = ',',
1393− typname = "_oid",
1394− typelem = oid
1395− }
1396−
1397−array_oidOid :: Oid
1398−array_oidOid = Oid 1028
1399−{-# INLINE array_oidOid #-}
1400−
1401−array_macaddr :: TypeInfo
1402−array_macaddr = Array {
1403− typoid = array_macaddrOid,
1404− typcategory = 'A',
1405− typdelim = ',',
1406− typname = "_macaddr",
1407− typelem = macaddr
1408− }
1409−
1410−array_macaddrOid :: Oid
1411−array_macaddrOid = Oid 1040
1412−{-# INLINE array_macaddrOid #-}
1413−
1414−array_inet :: TypeInfo
1415−array_inet = Array {
1416− typoid = array_inetOid,
1417− typcategory = 'A',
1418− typdelim = ',',
1419− typname = "_inet",
1420− typelem = inet
1421− }
1422−
1423−array_inetOid :: Oid
1424−array_inetOid = Oid 1041
1425−{-# INLINE array_inetOid #-}
1426−
1427−array_timestamp :: TypeInfo
1428−array_timestamp = Array {
1429− typoid = array_timestampOid,
1430− typcategory = 'A',
1431− typdelim = ',',
1432− typname = "_timestamp",
1433− typelem = timestamp
1434− }
1435−
1436−array_timestampOid :: Oid
1437−array_timestampOid = Oid 1115
1438−{-# INLINE array_timestampOid #-}
1439−
1440−array_date :: TypeInfo
1441−array_date = Array {
1442− typoid = array_dateOid,
1443− typcategory = 'A',
1444− typdelim = ',',
1445− typname = "_date",
1446− typelem = date
1447− }
1448−
1449−array_dateOid :: Oid
1450−array_dateOid = Oid 1182
1451−{-# INLINE array_dateOid #-}
1452−
1453−array_time :: TypeInfo
1454−array_time = Array {
1455− typoid = array_timeOid,
1456− typcategory = 'A',
1457− typdelim = ',',
1458− typname = "_time",
1459− typelem = time
1460− }
1461−
1462−array_timeOid :: Oid
1463−array_timeOid = Oid 1183
1464−{-# INLINE array_timeOid #-}
1465−
1466−array_timestamptz :: TypeInfo
1467−array_timestamptz = Array {
1468− typoid = array_timestamptzOid,
1469− typcategory = 'A',
1470− typdelim = ',',
1471− typname = "_timestamptz",
1472− typelem = timestamptz
1473− }
1474−
1475−array_timestamptzOid :: Oid
1476−array_timestamptzOid = Oid 1185
1477−{-# INLINE array_timestamptzOid #-}
1478−
1479−array_interval :: TypeInfo
1480−array_interval = Array {
1481− typoid = array_intervalOid,
1482− typcategory = 'A',
1483− typdelim = ',',
1484− typname = "_interval",
1485− typelem = interval
1486− }
1487−
1488−array_intervalOid :: Oid
1489−array_intervalOid = Oid 1187
1490−{-# INLINE array_intervalOid #-}
1491−
1492−array_numeric :: TypeInfo
1493−array_numeric = Array {
1494− typoid = array_numericOid,
1495− typcategory = 'A',
1496− typdelim = ',',
1497− typname = "_numeric",
1498− typelem = numeric
1499− }
1500−
1501−array_numericOid :: Oid
1502−array_numericOid = Oid 1231
1503−{-# INLINE array_numericOid #-}
1504−
1505−array_timetz :: TypeInfo
1506−array_timetz = Array {
1507− typoid = array_timetzOid,
1508− typcategory = 'A',
1509− typdelim = ',',
1510− typname = "_timetz",
1511− typelem = timetz
1512− }
1513−
1514−array_timetzOid :: Oid
1515−array_timetzOid = Oid 1270
1516−{-# INLINE array_timetzOid #-}
1517−
1518−array_bit :: TypeInfo
1519−array_bit = Array {
1520− typoid = array_bitOid,
1521− typcategory = 'A',
1522− typdelim = ',',
1523− typname = "_bit",
1524− typelem = bit
1525− }
1526−
1527−array_bitOid :: Oid
1528−array_bitOid = Oid 1561
1529−{-# INLINE array_bitOid #-}
1530−
1531−array_varbit :: TypeInfo
1532−array_varbit = Array {
1533− typoid = array_varbitOid,
1534− typcategory = 'A',
1535− typdelim = ',',
1536− typname = "_varbit",
1537− typelem = varbit
1538− }
1539−
1540−array_varbitOid :: Oid
1541−array_varbitOid = Oid 1563
1542−{-# INLINE array_varbitOid #-}
1543−
1544−array_refcursor :: TypeInfo
1545−array_refcursor = Array {
1546− typoid = array_refcursorOid,
1547− typcategory = 'A',
1548− typdelim = ',',
1549− typname = "_refcursor",
1550− typelem = refcursor
1551− }
1552−
1553−array_refcursorOid :: Oid
1554−array_refcursorOid = Oid 2201
1555−{-# INLINE array_refcursorOid #-}
1556−
1557−array_regprocedure :: TypeInfo
1558−array_regprocedure = Array {
1559− typoid = array_regprocedureOid,
1560− typcategory = 'A',
1561− typdelim = ',',
1562− typname = "_regprocedure",
1563− typelem = regprocedure
1564− }
1565−
1566−array_regprocedureOid :: Oid
1567−array_regprocedureOid = Oid 2207
1568−{-# INLINE array_regprocedureOid #-}
1569−
1570−array_regoper :: TypeInfo
1571−array_regoper = Array {
1572− typoid = array_regoperOid,
1573− typcategory = 'A',
1574− typdelim = ',',
1575− typname = "_regoper",
1576− typelem = regoper
1577− }
1578−
1579−array_regoperOid :: Oid
1580−array_regoperOid = Oid 2208
1581−{-# INLINE array_regoperOid #-}
1582−
1583−array_regoperator :: TypeInfo
1584−array_regoperator = Array {
1585− typoid = array_regoperatorOid,
1586− typcategory = 'A',
1587− typdelim = ',',
1588− typname = "_regoperator",
1589− typelem = regoperator
1590− }
1591−
1592−array_regoperatorOid :: Oid
1593−array_regoperatorOid = Oid 2209
1594−{-# INLINE array_regoperatorOid #-}
1595−
1596−array_regclass :: TypeInfo
1597−array_regclass = Array {
1598− typoid = array_regclassOid,
1599− typcategory = 'A',
1600− typdelim = ',',
1601− typname = "_regclass",
1602− typelem = regclass
1603− }
1604−
1605−array_regclassOid :: Oid
1606−array_regclassOid = Oid 2210
1607−{-# INLINE array_regclassOid #-}
1608−
1609−array_regtype :: TypeInfo
1610−array_regtype = Array {
1611− typoid = array_regtypeOid,
1612− typcategory = 'A',
1613− typdelim = ',',
1614− typname = "_regtype",
1615− typelem = regtype
1616− }
1617−
1618−array_regtypeOid :: Oid
1619−array_regtypeOid = Oid 2211
1620−{-# INLINE array_regtypeOid #-}
1621−
1622−array_uuid :: TypeInfo
1623−array_uuid = Array {
1624− typoid = array_uuidOid,
1625− typcategory = 'A',
1626− typdelim = ',',
1627− typname = "_uuid",
1628− typelem = uuid
1629− }
1630−
1631−array_uuidOid :: Oid
1632−array_uuidOid = Oid 2951
1633−{-# INLINE array_uuidOid #-}
1634−
1635−array_jsonb :: TypeInfo
1636−array_jsonb = Array {
1637− typoid = array_jsonbOid,
1638− typcategory = 'A',
1639− typdelim = ',',
1640− typname = "_jsonb",
1641− typelem = jsonb
1642− }
1643−
1644−array_jsonbOid :: Oid
1645−array_jsonbOid = Oid 3807
1646−{-# INLINE array_jsonbOid #-}
1647−
1648−int4range :: TypeInfo
1649−int4range = Range {
1650− typoid = int4rangeOid,
1651− typcategory = 'R',
1652− typdelim = ',',
1653− typname = "int4range",
1654− rngsubtype = int4
1655− }
1656−
1657−int4rangeOid :: Oid
1658−int4rangeOid = Oid 3904
1659−{-# INLINE int4rangeOid #-}
1660−
1661−_int4range :: TypeInfo
1662−_int4range = Array {
1663− typoid = _int4rangeOid,
1664− typcategory = 'A',
1665− typdelim = ',',
1666− typname = "_int4range",
1667− typelem = int4range
1668− }
1669−
1670−_int4rangeOid :: Oid
1671−_int4rangeOid = Oid 3905
1672−{-# INLINE _int4rangeOid #-}
1673−
1674−numrange :: TypeInfo
1675−numrange = Range {
1676− typoid = numrangeOid,
1677− typcategory = 'R',
1678− typdelim = ',',
1679− typname = "numrange",
1680− rngsubtype = numeric
1681− }
1682−
1683−numrangeOid :: Oid
1684−numrangeOid = Oid 3906
1685−{-# INLINE numrangeOid #-}
1686−
1687−_numrange :: TypeInfo
1688−_numrange = Array {
1689− typoid = _numrangeOid,
1690− typcategory = 'A',
1691− typdelim = ',',
1692− typname = "_numrange",
1693− typelem = numrange
1694− }
1695−
1696−_numrangeOid :: Oid
1697−_numrangeOid = Oid 3907
1698−{-# INLINE _numrangeOid #-}
1699−
1700−tsrange :: TypeInfo
1701−tsrange = Range {
1702− typoid = tsrangeOid,
1703− typcategory = 'R',
1704− typdelim = ',',
1705− typname = "tsrange",
1706− rngsubtype = timestamp
1707− }
1708−
1709−tsrangeOid :: Oid
1710−tsrangeOid = Oid 3908
1711−{-# INLINE tsrangeOid #-}
1712−
1713−_tsrange :: TypeInfo
1714−_tsrange = Array {
1715− typoid = _tsrangeOid,
1716− typcategory = 'A',
1717− typdelim = ',',
1718− typname = "_tsrange",
1719− typelem = tsrange
1720− }
1721−
1722−_tsrangeOid :: Oid
1723−_tsrangeOid = Oid 3909
1724−{-# INLINE _tsrangeOid #-}
1725−
1726−tstzrange :: TypeInfo
1727−tstzrange = Range {
1728− typoid = tstzrangeOid,
1729− typcategory = 'R',
1730− typdelim = ',',
1731− typname = "tstzrange",
1732− rngsubtype = timestamptz
1733− }
1734−
1735−tstzrangeOid :: Oid
1736−tstzrangeOid = Oid 3910
1737−{-# INLINE tstzrangeOid #-}
1738−
1739−_tstzrange :: TypeInfo
1740−_tstzrange = Array {
1741− typoid = _tstzrangeOid,
1742− typcategory = 'A',
1743− typdelim = ',',
1744− typname = "_tstzrange",
1745− typelem = tstzrange
1746− }
1747−
1748−_tstzrangeOid :: Oid
1749−_tstzrangeOid = Oid 3911
1750−{-# INLINE _tstzrangeOid #-}
1751−
1752−daterange :: TypeInfo
1753−daterange = Range {
1754− typoid = daterangeOid,
1755− typcategory = 'R',
1756− typdelim = ',',
1757− typname = "daterange",
1758− rngsubtype = date
1759− }
1760−
1761−daterangeOid :: Oid
1762−daterangeOid = Oid 3912
1763−{-# INLINE daterangeOid #-}
1764−
1765−_daterange :: TypeInfo
1766−_daterange = Array {
1767− typoid = _daterangeOid,
1768− typcategory = 'A',
1769− typdelim = ',',
1770− typname = "_daterange",
1771− typelem = daterange
1772− }
1773−
1774−_daterangeOid :: Oid
1775−_daterangeOid = Oid 3913
1776−{-# INLINE _daterangeOid #-}
1777−
1778−int8range :: TypeInfo
1779−int8range = Range {
1780− typoid = int8rangeOid,
1781− typcategory = 'R',
1782− typdelim = ',',
1783− typname = "int8range",
1784− rngsubtype = int8
1785− }
1786−
1787−int8rangeOid :: Oid
1788−int8rangeOid = Oid 3926
1789−{-# INLINE int8rangeOid #-}
1790−
1791−_int8range :: TypeInfo
1792−_int8range = Array {
1793− typoid = _int8rangeOid,
1794− typcategory = 'A',
1795− typdelim = ',',
1796− typname = "_int8range",
1797− typelem = int8range
1798− }
1799−
1800−_int8rangeOid :: Oid
1801−_int8rangeOid = Oid 3927
1802−{-# INLINE _int8rangeOid #-}
src/Database/PostgreSQL/Simple/TypeInfo/Types.hsdeleted−56
@@ -1,56 +0,0 @@
1−------------------------------------------------------------------------------
2−-- |
3−-- Module: Database.PostgreSQL.Simple.TypeInfo.Types
4−-- Copyright: (c) 2013 Leon P Smith
5−-- License: BSD3
6−-- Maintainer: Leon P Smith <leon@melding-monads.com>
7−-- Stability: experimental
8−--
9−------------------------------------------------------------------------------
10−
11−module Database.PostgreSQL.Simple.TypeInfo.Types where
12−
13−import Data.ByteString(ByteString)
14−import Database.PostgreSQL.LibPQ(Oid)
15−import Data.Vector(Vector)
16−
17−-- | A structure representing some of the metadata regarding a PostgreSQL
18−-- type, mostly taken from the @pg_type@ table.
19−
20−data TypeInfo
21−
22− = Basic { typoid :: {-# UNPACK #-} !Oid
23− , typcategory :: {-# UNPACK #-} !Char
24− , typdelim :: {-# UNPACK #-} !Char
25− , typname :: !ByteString
26− }
27−
28− | Array { typoid :: {-# UNPACK #-} !Oid
29− , typcategory :: {-# UNPACK #-} !Char
30− , typdelim :: {-# UNPACK #-} !Char
31− , typname :: !ByteString
32− , typelem :: !TypeInfo
33− }
34−
35− | Range { typoid :: {-# UNPACK #-} !Oid
36− , typcategory :: {-# UNPACK #-} !Char
37− , typdelim :: {-# UNPACK #-} !Char
38− , typname :: !ByteString
39− , rngsubtype :: !TypeInfo
40− }
41−
42− | Composite { typoid :: {-# UNPACK #-} !Oid
43− , typcategory :: {-# UNPACK #-} !Char
44− , typdelim :: {-# UNPACK #-} !Char
45− , typname :: !ByteString
46− , typrelid :: {-# UNPACK #-} !Oid
47− , attributes :: !(Vector Attribute)
48− }
49−
50− deriving (Show)
51−
52−data Attribute
53− = Attribute { attname :: !ByteString
54− , atttype :: !TypeInfo
55− }
56− deriving (Show)
src/Database/PostgreSQL/Simple/Types.hs+36−186
@@ -1,58 +1,43 @@
1−{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, GeneralizedNewtypeDeriving #-}
1+{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, GeneralizedNewtypeDeriving #-}
22
3−------------------------------------------------------------------------------
43-- |
54-- Module: Database.PostgreSQL.Simple.Types
65-- Copyright: (c) 2011 MailRank, Inc.
7−-- (c) 2011-2012 Leon P Smith
6+-- (c) 2011 Leon P Smith
87-- License: BSD3
98-- Maintainer: Leon P Smith <leon@melding-monads.com>
109-- Stability: experimental
10+-- Portability: portable
1111--
1212-- Basic types.
13−--
14−------------------------------------------------------------------------------
1513
1614module Database.PostgreSQL.Simple.Types
1715 (
1816 Null(..)
19− , Default(..)
2017 , Only(..)
2118 , In(..)
2219 , Binary(..)
23− , Identifier(..)
24− , QualifiedIdentifier(..)
2520 , Query(..)
2621 , Oid(..)
27− , (:.)(..)
28− , Savepoint(..)
29− , PGArray(..)
30− , Values(..)
3122 ) where
3223
33−import Control.Arrow (first)
34−import Data.ByteString (ByteString)
35−import Data.Hashable (Hashable(hashWithSalt))
36−import Data.Foldable (toList)
37−import Data.Monoid (Monoid(..))
38−import Data.Semigroup
39−import Data.String (IsString(..))
40−import Data.Typeable (Typeable)
41−import Data.ByteString.Builder ( stringUtf8 )
24+import Blaze.ByteString.Builder (toByteString)
25+import Control.Arrow (first)
26+import Data.ByteString (ByteString)
27+import Data.Monoid (Monoid(..))
28+import Data.String (IsString(..))
29+import Data.Typeable (Typeable)
30+import qualified Blaze.ByteString.Builder.Char.Utf8 as Utf8
4231import qualified Data.ByteString as B
43−import Data.Text (Text)
44−import qualified Data.Text as T
45−import Data.Tuple.Only (Only(..))
46−import Database.PostgreSQL.LibPQ (Oid(..))
47−import Database.PostgreSQL.Simple.Compat (toByteString)
32+import Database.PostgreSQL.LibPQ (Oid(..))
4833
4934-- | A placeholder for the SQL @NULL@ value.
5035data Null = Null
5136 deriving (Read, Show, Typeable)
5237
53−-- | A placeholder for the PostgreSQL @DEFAULT@ value.
54−data Default = Default
55− deriving (Read, Show, Typeable)
38+instance Eq Null where
39+ _ == _ = False
40+ _ /= _ = False
5641
5742-- | A query string. This type is intended to make it difficult to
5843-- construct a SQL query by concatenating string fragments, as that is
@@ -84,175 +69,40 @@ instance Read Query where
8469 readsPrec i = fmap (first Query) . readsPrec i
8570
8671instance IsString Query where
87− fromString = Query . toByteString . stringUtf8
88−
89−instance Semigroup Query where
90− Query a <> Query b = Query (B.append a b)
91− {-# INLINE (<>) #-}
92− sconcat xs = Query (B.concat $ map fromQuery $ toList xs)
72+ fromString = Query . toByteString . Utf8.fromString
9373
9474instance Monoid Query where
9575 mempty = Query B.empty
76+ mappend (Query a) (Query b) = Query (B.append a b)
77+ {-# INLINE mappend #-}
9678
97−-- | Wrap a list of values for use in an @IN@ clause. Replaces a
98−-- single \"@?@\" character with a parenthesized list of rendered
99−-- values.
100−--
101−-- Example:
102−--
103−-- > query c "select * from whatever where id in ?" (Only (In [3,4,5]))
104−--
105−-- Note that @In []@ expands to @(null)@, which works as expected in
106−-- the query above, but evaluates to the logical null value on every
107−-- row instead of @TRUE@. This means that changing the query above
108−-- to @... id NOT in ?@ and supplying the empty list as the parameter
109−-- returns zero rows, instead of all of them as one would expect.
79+-- | A single-value \"collection\".
11080--
111−-- Since postgresql doesn't seem to provide a syntax for actually specifying
112−-- an empty list, which could solve this completely, there are two
113−-- workarounds particularly worth mentioning, namely:
81+-- This is useful if you need to supply a single parameter to a SQL
82+-- query, or extract a single column from a SQL result.
11483--
115−-- 1. Use postgresql-simple's 'Values' type instead, which can handle the
116−-- empty case correctly. Note however that while specifying the
117−-- postgresql type @"int4"@ is mandatory in the empty case, specifying
118−-- the haskell type @Values (Only Int)@ would not normally be needed in
119−-- realistic use cases.
84+-- Parameter example:
12085--
121−-- > query c "select * from whatever where id not in ?"
122−-- > (Only (Values ["int4"] [] :: Values (Only Int)))
86+-- @query c \"select x from scores where x > ?\" ('Only' (42::Int))@
12387--
88+-- Result example:
12489--
125−-- 2. Use sql's @COALESCE@ operator to turn a logical @null@ into the correct
126−-- boolean. Note however that the correct boolean depends on the use
127−-- case:
128−--
129−-- > query c "select * from whatever where coalesce(id NOT in ?, TRUE)"
130−-- > (Only (In [] :: In [Int]))
90+-- @xs <- query_ c \"select id from users\"
91+--forM_ xs $ \\('Only' id) -> {- ... -}@
92+newtype Only a = Only {
93+ fromOnly :: a
94+ } deriving (Eq, Ord, Read, Show, Typeable, Functor)
95+
96+-- | Wrap a list of values for use in an @IN@ clause. Replaces a
97+-- single \"@?@\" character with a parenthesized list of rendered
98+-- values.
13199--
132−-- > query c "select * from whatever where coalesce(id IN ?, FALSE)"
133−-- > (Only (In [] :: In [Int]))
100+-- Example:
134101--
135−-- Note that at as of PostgreSQL 9.4, the query planner cannot see inside
136−-- the @COALESCE@ operator, so if you have an index on @id@ then you
137−-- probably don't want to write the last example with @COALESCE@, which
138−-- would result in a table scan. There are further caveats if @id@ can
139−-- be null or you want null treated sensibly as a component of @IN@ or
140−-- @NOT IN@.
141−
102+-- > query c "select * from whatever where id in ?" (In [3,4,5])
142103newtype In a = In a
143104 deriving (Eq, Ord, Read, Show, Typeable, Functor)
144105
145−-- | Wrap binary data for use as a @bytea@ value.
146−newtype Binary a = Binary {fromBinary :: a}
106+-- | Wrap a mostly-binary string to be escaped in hexadecimal.
107+newtype Binary a = Binary a
147108 deriving (Eq, Ord, Read, Show, Typeable, Functor)
148−
149−-- | Wrap text for use as sql identifier, i.e. a table or column name.
150−newtype Identifier = Identifier {fromIdentifier :: Text}
151− deriving (Eq, Ord, Read, Show, Typeable, IsString)
152−
153−instance Hashable Identifier where
154− hashWithSalt i (Identifier t) = hashWithSalt i t
155−
156−-- | Wrap text for use as (maybe) qualified identifier, i.e. a table
157−-- with schema, or column with table.
158−data QualifiedIdentifier = QualifiedIdentifier (Maybe Text) Text
159− deriving (Eq, Ord, Read, Show, Typeable)
160−
161−instance Hashable QualifiedIdentifier where
162− hashWithSalt i (QualifiedIdentifier q t) = hashWithSalt i (q, t)
163−
164−-- | @\"foo.bar\"@ will get turned into
165−-- @QualifiedIdentifier (Just \"foo\") \"bar\"@, while @\"foo\"@ will get
166−-- turned into @QualifiedIdentifier Nothing \"foo\"@. Note this instance
167−-- is for convenience, and does not match postgres syntax. It
168−-- only examines the first period character, and thus cannot be used if the
169−-- qualifying identifier contains a period for example.
170−
171−instance IsString QualifiedIdentifier where
172− fromString str = let (x,y) = T.break (== '.') (fromString str)
173− in if T.null y
174− then QualifiedIdentifier Nothing x
175− else QualifiedIdentifier (Just x) (T.tail y)
176−
177−-- | Wrap a list for use as a PostgreSQL array.
178−newtype PGArray a = PGArray {fromPGArray :: [a]}
179− deriving (Eq, Ord, Read, Show, Typeable, Functor)
180−
181−-- | A composite type to parse your custom data structures without
182−-- having to define dummy newtype wrappers every time.
183−--
184−--
185−-- > instance FromRow MyData where ...
186−--
187−-- > instance FromRow MyData2 where ...
188−--
189−--
190−-- then I can do the following for free:
191−--
192−-- @
193−-- res <- query' c "..."
194−-- forM res $ \\(MyData{..} :. MyData2{..}) -> do
195−-- ....
196−-- @
197−data h :. t = h :. t deriving (Eq,Ord,Show,Read,Typeable)
198−
199−infixr 3 :.
200−
201−newtype Savepoint = Savepoint Query
202− deriving (Eq, Ord, Show, Read, Typeable)
203−
204−-- | Represents a @VALUES@ table literal, usable as an alternative to
205−-- 'Database.PostgreSQL.Simple.executeMany' and
206−-- 'Database.PostgreSQL.Simple.returning'. The main advantage is that
207−-- you can parametrize more than just a single @VALUES@ expression.
208−-- For example, here's a query to insert a thing into one table
209−-- and some attributes of that thing into another, returning the
210−-- new id generated by the database:
211−--
212−--
213−-- > query c [sql|
214−-- > WITH new_thing AS (
215−-- > INSERT INTO thing (name) VALUES (?) RETURNING id
216−-- > ), new_attributes AS (
217−-- > INSERT INTO thing_attributes
218−-- > SELECT new_thing.id, attrs.*
219−-- > FROM new_thing JOIN ? attrs ON TRUE
220−-- > ) SELECT * FROM new_thing
221−-- > |] ("foo", Values [ "int4", "text" ]
222−-- > [ ( 1 , "hello" )
223−-- > , ( 2 , "world" ) ])
224−--
225−-- (Note this example uses writable common table expressions,
226−-- which were added in PostgreSQL 9.1)
227−--
228−-- The second parameter gets expanded into the following SQL syntax:
229−--
230−-- > (VALUES (1::"int4",'hello'::"text"),(2,'world'))
231−--
232−-- When the list of attributes is empty, the second parameter expands to:
233−--
234−-- > (VALUES (null::"int4",null::"text") LIMIT 0)
235−--
236−-- By contrast, @executeMany@ and @returning@ don't issue the query
237−-- in the empty case, and simply return @0@ and @[]@ respectively.
238−-- This behavior is usually correct given their intended use cases,
239−-- but would certainly be wrong in the example above.
240−--
241−-- The first argument is a list of postgresql type names. Because this
242−-- is turned into a properly quoted identifier, the type name is case
243−-- sensitive and must be as it appears in the @pg_type@ table. Thus,
244−-- you must write @timestamptz@ instead of @timestamp with time zone@,
245−-- @int4@ instead of @integer@ or @serial@, @_int8@ instead of @bigint[]@,
246−-- etcetera.
247−--
248−-- You may omit the type names, however, if you do so the list
249−-- of values must be non-empty, and postgresql must be able to infer
250−-- the types of the columns from the surrounding context. If the first
251−-- condition is not met, postgresql-simple will throw an exception
252−-- without issuing the query. In the second case, the postgres server
253−-- will return an error which will be turned into a @SqlError@ exception.
254−--
255−-- See <https://www.postgresql.org/docs/9.5/static/sql-values.html> for
256−-- more information.
257−data Values a = Values [QualifiedIdentifier] [a]
258− deriving (Eq, Ord, Show, Read, Typeable)
src/Database/PostgreSQL/Simple/Vector.hsdeleted−45
@@ -1,45 +0,0 @@
1−-- | 'query' variants returning 'V.Vector'.
2−module Database.PostgreSQL.Simple.Vector where
3−
4−import Database.PostgreSQL.Simple (Connection, formatQuery, formatMany)
5−import Database.PostgreSQL.Simple.FromRow (FromRow(..))
6−import Database.PostgreSQL.Simple.ToRow (ToRow(..))
7−import Database.PostgreSQL.Simple.Internal (RowParser, exec)
8−import Database.PostgreSQL.Simple.Internal.PQResultUtils
9−import Database.PostgreSQL.Simple.Types ( Query (..) )
10−
11−import qualified Data.Vector as V
12−
13−-- | Perform a @SELECT@ or other SQL query that is expected to return
14−-- results. All results are retrieved and converted before this
15−-- function returns.
16−query :: (ToRow q, FromRow r) => Connection -> Query -> q -> IO (V.Vector r)
17−query = queryWith fromRow
18−
19−-- | A version of 'query' that does not perform query substitution.
20−query_ :: (FromRow r) => Connection -> Query -> IO (V.Vector r)
21−query_ = queryWith_ fromRow
22−
23−-- | A version of 'query' taking parser as argument
24−queryWith :: ToRow q => RowParser r -> Connection -> Query -> q -> IO (V.Vector r)
25−queryWith parser conn template qs = do
26− result <- exec conn =<< formatQuery conn template qs
27− finishQueryWithV parser conn template result
28−
29−-- | A version of 'query_' taking parser as argument
30−queryWith_ :: RowParser r -> Connection -> Query -> IO (V.Vector r)
31−queryWith_ parser conn q@(Query que) = do
32− result <- exec conn que
33− finishQueryWithV parser conn q result
34−
35−-- | Execute @INSERT ... RETURNING@, @UPDATE ... RETURNING@, or other SQL
36−-- query that accepts multi-row input and is expected to return results.
37−returning :: (ToRow q, FromRow r) => Connection -> Query -> [q] -> IO (V.Vector r)
38−returning = returningWith fromRow
39−
40−-- | A version of 'returning' taking parser as argument
41−returningWith :: (ToRow q) => RowParser r -> Connection -> Query -> [q] -> IO (V.Vector r)
42−returningWith _ _ _ [] = return V.empty
43−returningWith parser conn q qs = do
44− result <- exec conn =<< formatMany conn q qs
45− finishQueryWithV parser conn q result
src/Database/PostgreSQL/Simple/Vector/Unboxed.hsdeleted−44
@@ -1,44 +0,0 @@
1−module Database.PostgreSQL.Simple.Vector.Unboxed where
2−
3−import Database.PostgreSQL.Simple (Connection, formatQuery, formatMany)
4−import Database.PostgreSQL.Simple.FromRow (FromRow(..))
5−import Database.PostgreSQL.Simple.ToRow (ToRow(..))
6−import Database.PostgreSQL.Simple.Internal (RowParser, exec)
7−import Database.PostgreSQL.Simple.Internal.PQResultUtils
8−import Database.PostgreSQL.Simple.Types ( Query (..) )
9−
10−import qualified Data.Vector.Unboxed as VU
11−
12−-- | Perform a @SELECT@ or other SQL query that is expected to return
13−-- results. All results are retrieved and converted before this
14−-- function returns.
15−query :: (ToRow q, FromRow r, VU.Unbox r) => Connection -> Query -> q -> IO (VU.Vector r)
16−query = queryWith fromRow
17−
18−-- | A version of 'query' that does not perform query substitution.
19−query_ :: (FromRow r, VU.Unbox r) => Connection -> Query -> IO (VU.Vector r)
20−query_ = queryWith_ fromRow
21−
22−-- | A version of 'query' taking parser as argument
23−queryWith :: (ToRow q, VU.Unbox r) => RowParser r -> Connection -> Query -> q -> IO (VU.Vector r)
24−queryWith parser conn template qs = do
25− result <- exec conn =<< formatQuery conn template qs
26− finishQueryWithVU parser conn template result
27−
28−-- | A version of 'query_' taking parser as argument
29−queryWith_ :: VU.Unbox r => RowParser r -> Connection -> Query -> IO (VU.Vector r)
30−queryWith_ parser conn q@(Query que) = do
31− result <- exec conn que
32− finishQueryWithVU parser conn q result
33−
34−-- | Execute @INSERT ... RETURNING@, @UPDATE ... RETURNING@, or other SQL
35−-- query that accepts multi-row input and is expected to return results.
36−returning :: (ToRow q, FromRow r, VU.Unbox r) => Connection -> Query -> [q] -> IO (VU.Vector r)
37−returning = returningWith fromRow
38−
39−-- | A version of 'returning' taking parser as argument
40−returningWith :: (ToRow q, VU.Unbox r) => RowParser r -> Connection -> Query -> [q] -> IO (VU.Vector r)
41−returningWith _ _ _ [] = return VU.empty
42−returningWith parser conn q qs = do
43− result <- exec conn =<< formatMany conn q qs
44− finishQueryWithVU parser conn q result
test/Common.hsdeleted−32
@@ -1,32 +0,0 @@
1−module Common (
2− module Database.PostgreSQL.Simple,
3− module Test.Tasty.HUnit,
4− TestEnv(..),
5− md5,
6−) where
7−
8−import Data.ByteString (ByteString)
9−import Data.Text (Text)
10−import Database.PostgreSQL.Simple
11−import Test.Tasty.HUnit
12−
13−import qualified Crypto.Hash.MD5 as MD5
14−import qualified Data.ByteString.Base16 as Base16
15−import qualified Data.Text.Encoding as TE
16−
17−data TestEnv
18− = TestEnv
19− { conn :: Connection
20− -- ^ Connection shared by all the tests
21− , withConn :: forall a. (Connection -> IO a) -> IO a
22− -- ^ Bracket for spawning additional connections
23− }
24−
25−-- | Return the MD5 hash of a 'ByteString', in lowercase hex format.
26−--
27−-- Example:
28−--
29−-- >[Only hash] <- query_ conn "SELECT md5('hi')"
30−-- >assertEqual "md5('hi')" (md5 "hi") hash
31−md5 :: ByteString -> Text
32−md5 = TE.decodeUtf8 . Base16.encode . MD5.hash
test/Exception.hsdeleted−70
@@ -1,70 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE ScopedTypeVariables #-}
4−
5−module Exception (testExceptions) where
6−
7−import Database.PostgreSQL.Simple
8−import Test.Tasty.HUnit (Assertion, assertBool)
9−import Common (TestEnv)
10−import Control.Exception (Exception (..), SomeException)
11−import Data.Maybe (isJust)
12−import Data.Either (isLeft)
13−import Control.Exception (throwIO, try)
14−
15−testExceptions :: TestEnv -> Assertion
16−testExceptions _ = do
17− let sqlError = SqlError
18− { sqlState = ""
19− , sqlExecStatus = FatalError
20− , sqlErrorMsg = ""
21− , sqlErrorDetail = ""
22− , sqlErrorHint = ""
23− }
24− let sqlEx :: SomeException = toException sqlError
25− assertBool "SqlError is SomePostgreSqlException" $ isJust (fromException sqlEx :: Maybe SomePostgreSqlException)
26− assertBool "SqlError is SqlError" $ isJust (fromException sqlEx :: Maybe SqlError)
27− eSqlError :: Either SqlError () <- try $ throwIO sqlEx
28− assertBool "Can catch SqlError" $ isLeft eSqlError
29− eSqlPostgreSqlEx :: Either SomePostgreSqlException () <- try $ throwIO sqlEx
30− assertBool "Can catch SomePostgreSqlException from SqlError" $ isLeft eSqlPostgreSqlEx
31−
32− let formatError = FormatError
33− { fmtMessage = ""
34− , fmtQuery = ""
35− , fmtParams = []
36− }
37− let formatEx :: SomeException = toException formatError
38− assertBool "FormatError is SomePostgreSqlException" $ isJust (fromException formatEx :: Maybe SomePostgreSqlException)
39− assertBool "FormatError is FormatError" $ isJust (fromException formatEx :: Maybe FormatError)
40− eFormatError :: Either FormatError () <- try $ throwIO formatEx
41− assertBool "Can catch FormatError" $ isLeft eFormatError
42− eFormatPostreSqlEx :: Either SomePostgreSqlException () <- try $ throwIO formatEx
43− assertBool "Can catch SomePostgreSqlException from FormatError" $ isLeft eFormatPostreSqlEx
44−
45− let queryError = QueryError
46− { qeMessage = ""
47− , qeQuery = ""
48− }
49− let queryEx :: SomeException = toException queryError
50− assertBool "QueryError is SomePostgreSqlException" $ isJust (fromException queryEx :: Maybe SomePostgreSqlException)
51− assertBool "QueryError is QueryError" $ isJust (fromException queryEx :: Maybe QueryError)
52− eQueryError :: Either QueryError () <- try $ throwIO queryEx
53− assertBool "Can catch QueryError" $ isLeft eQueryError
54− eQueryPostgreSqlEx :: Either SomePostgreSqlException () <- try $ throwIO queryEx
55− assertBool "Can catch SomePostgreSqlException from QueryError" $ isLeft eQueryPostgreSqlEx
56−
57− let resultError = Incompatible
58− { errSQLType = ""
59− , errSQLTableOid = Nothing
60− , errSQLField = ""
61− , errHaskellType = ""
62− , errMessage = ""
63− }
64− let resultEx :: SomeException = toException resultError
65− assertBool "ResultError is SomePostgreSqlException" $ isJust (fromException resultEx :: Maybe SomePostgreSqlException)
66− assertBool "ResultError is ResultError" $ isJust (fromException resultEx :: Maybe ResultError)
67− eResultEx :: Either ResultError () <- try $ throwIO resultEx
68− assertBool "Can catch ResultError" $ isLeft eResultEx
69− eResultPostgreSqlEx :: Either SomePostgreSqlException () <- try $ throwIO resultEx
70− assertBool "Can catch SomePostgreSqlException from ResultError" $ isLeft eResultPostgreSqlEx
test/Inspection.hsdeleted−79
@@ -1,79 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE TemplateHaskell #-}
3−{-# OPTIONS_GHC -dsuppress-idinfo -dsuppress-coercions -dsuppress-type-applications -dsuppress-module-prefixes -dsuppress-type-signatures #-}
4−-- {-# OPTIONS_GHC -dsuppress-uniques #-}
5−{-# OPTIONS_GHC -fplugin=Test.Inspection.Plugin #-}
6−module Main where
7−
8−import Test.Inspection
9−import Test.Tasty
10−import Test.Tasty.HUnit
11−
12−import qualified Database.PostgreSQL.LibPQ as PQ
13−import Database.PostgreSQL.Simple.FromField
14−import Database.PostgreSQL.Simple.TypeInfo as TI
15−import Database.PostgreSQL.Simple.TypeInfo.Macro
16−import qualified Database.PostgreSQL.Simple.TypeInfo.Static as TI
17−
18−-------------------------------------------------------------------------------
19−-- Inspection tests
20−-------------------------------------------------------------------------------
21−
22−-- # doesn't work :(
23−#define TH_MKCOMPATS3(a,b,c) $(mkCompats [TI.a,TI.b,TI.c])
24−#define IN_MKCOMPATS3(a,b,c) (eq TI.a \/ eq TI.b \/ eq TI.c)
25−
26−#define TH_INLINETYPOID(n) eq $(inlineTypoid TI.n)
27−#define IN_INLINETYPOID(n) eq TI.n
28−
29−-- eta-expansion is required
30−lhs01, rhs01 :: PQ.Oid -> Bool
31−lhs01 = TH_MKCOMPATS3(name,text,char)
32−rhs01 = IN_MKCOMPATS3(nameOid,textOid,charOid)
33−
34−lhs02, rhs02 :: PQ.Oid -> Bool
35−lhs02 = TH_INLINETYPOID(name)
36−rhs02 = IN_INLINETYPOID(nameOid)
37−
38−eq :: PQ.Oid -> PQ.Oid -> Bool
39−eq = (==)
40−{-# INLINE eq #-}
41−
42−infixr 2 \/
43−(\/) :: (PQ.Oid -> Bool)
44− -> (PQ.Oid -> Bool)
45− -> (PQ.Oid -> Bool)
46−f \/ g = \x -> f x || g x
47−{-# INLINE (\/) #-}
48−
49−inspectionTests :: TestTree
50−inspectionTests = testGroup "inspection"
51− [ testCase "mkCompats" $
52− assertSuccess $(inspectTest $ 'lhs01 === 'rhs01)
53−
54− -- byteaOid isn't inlined?
55− , testCase "inlineTypoid" $
56−#if __GLASGOW_HASKELL__ >= 808
57− assertSuccess
58−#else
59− assertFailure'
60−#endif
61− $(inspectTest $ 'lhs02 ==- 'rhs02)
62− ]
63−
64−assertSuccess :: Result -> IO ()
65−assertSuccess (Success _) = return ()
66−assertSuccess (Failure err) = assertFailure err
67−
68−assertFailure' :: Result -> IO ()
69−assertFailure' (Success err) = assertFailure err
70−assertFailure' (Failure _) = return ()
71−
72−-------------------------------------------------------------------------------
73−-- Main
74−-------------------------------------------------------------------------------
75−
76−main :: IO ()
77−main = defaultMain $ testGroup "tests"
78− [ inspectionTests
79− ]
test/Interval.hsdeleted−176
@@ -1,176 +0,0 @@
1−{-# LANGUAGE QuasiQuotes #-}
2−
3−{-
4−
5−Testing strategies:
6−
7−fromString . toString == id ** Todo?
8−
9−toString . fromString == almost id ** Todo?
10−
11−postgresql -> haskell -> postgresql * Done
12−
13−haskell -> postgresql -> haskell ** Todo?
14−
15−But still, what we really want to establish is that the two values
16−correspond; for example, a conversion that consistently added hour
17−when printed to a string and subtracted an hour when parsed from string
18−would still pass these tests.
19−
20−
21−Right now, we are checking that 1400+ timestamps in the range of 1860 to
22−2060 round trip from postgresql to haskell and back in 5 different timezones.
23−In addition to UTC, the four timezones were selected so that 2 have a positive
24−offset, and 2 have a negative offset, and that 2 have an offset of a
25−whole number of hours, while the other two do not.
26−
27−It may be worth adding a few more timezones to ensure better test coverage.
28−
29−We are checking a handful of selected timestamps to ensure we hit
30−various corner-cases in the code, in addition to 1400 timestamps randomly
31−generated with granularity of seconds down to microseconds in powers of ten.
32−
33−-}
34−
35−module Interval (testInterval) where
36−
37−import Common
38−import Control.Monad(forM_, replicateM_)
39−import Data.Time.Compat
40−import Data.Time.LocalTime.Compat (CalendarDiffTime(..))
41−import Data.ByteString(ByteString)
42−import Database.PostgreSQL.Simple.SqlQQ
43−
44−data IntervalTestCase = IntervalTestCase
45− { label :: String
46− , inputMonths :: Integer
47− , inputSeconds :: NominalDiffTime
48− , asText :: String
49− }
50− deriving (Eq, Show)
51−
52−testInterval :: TestEnv -> Assertion
53−testInterval env@TestEnv{..} = do
54−
55− initializeTable env
56−
57− let milliseconds = 0.001
58− seconds = 1
59− minutes = 60 * seconds
60− hours = 60 * minutes
61− days = 24 * hours
62− weeks = 7 * days
63− months = 1
64− years = 12 * months
65−
66− mapM (checkRoundTrip env)
67− [ IntervalTestCase
68− { label = "zero"
69− , inputMonths = 0
70− , inputSeconds = 0
71− , asText = "PT0"
72− }
73− , IntervalTestCase
74− { label = "1 year"
75− , inputMonths = 1 * years
76− , inputSeconds = 0
77− , asText = "P1Y"
78− }
79− , IntervalTestCase
80− { label = "2 months"
81− , inputMonths = 2 * months
82− , inputSeconds = 0
83− , asText = "P2M"
84− }
85− , IntervalTestCase
86− { label = "3 weeks"
87− , inputMonths = 0
88− , inputSeconds = 3 * weeks
89− , asText = "P3W"
90− }
91− , IntervalTestCase
92− { label = "4 days"
93− , inputMonths = 0
94− , inputSeconds = 4 * days
95− , asText = "P4D"
96− }
97− , IntervalTestCase
98− { label = "5 hours"
99− , inputMonths = 0
100− , inputSeconds = 5 * hours
101− , asText = "PT5H"
102− }
103− , IntervalTestCase
104− { label = "6 minutes"
105− , inputMonths = 0
106− , inputSeconds = 6 * minutes
107− , asText = "PT6M"
108− }
109− , IntervalTestCase
110− { label = "7 seconds"
111− , inputMonths = 0
112− , inputSeconds = 7 * seconds
113− , asText = "PT7S"
114− }
115− , IntervalTestCase
116− { label = "8 milliseconds"
117− , inputMonths = 0
118− , inputSeconds = 8 * milliseconds
119− , asText = "PT0.008S"
120− }
121− , IntervalTestCase
122− { label = "combination of intervals (day-size or bigger)"
123− , inputMonths = 2 * years + 4 * months
124− , inputSeconds = 3 * weeks + 5 * days
125− , asText = "P2Y4M3W5D"
126− }
127− , IntervalTestCase
128− { label = "combination of intervals (smaller than day-size)"
129− , inputMonths = 0
130− , inputSeconds = 18 * hours + 56 * minutes + 23 * seconds + 563 * milliseconds
131− , asText = "PT18H56M23.563S"
132− }
133− , IntervalTestCase
134− { label = "full combination of intervals"
135− , inputMonths = 2 * years + 4 * months
136− , inputSeconds = 3 * weeks + 5 * days + 18 * hours + 56 * minutes + 23 * seconds + 563 * milliseconds
137− , asText = "P2Y4M3W5DT18H56M23.563S"
138− }
139− ]
140−
141− return ()
142−
143−initializeTable :: TestEnv -> IO ()
144−initializeTable TestEnv{..} = withTransaction conn $ do
145− execute_ conn
146− [sql| CREATE TEMPORARY TABLE testinterval
147− ( id serial, sample interval, PRIMARY KEY(id) ) |]
148−
149− return ()
150−
151−checkRoundTrip :: TestEnv -> IntervalTestCase -> IO ()
152−checkRoundTrip TestEnv{..} IntervalTestCase{..} = do
153−
154− let input = CalendarDiffTime
155− { ctMonths = inputMonths
156− , ctTime = inputSeconds
157− }
158−
159− [(returnedId :: Int, output :: CalendarDiffTime)] <- query conn [sql|
160− INSERT INTO testinterval (sample)
161− VALUES (?)
162− RETURNING id, sample
163− |] (Only input)
164−
165− assertBool ("CalendarDiffTime did not round-trip from Haskell to SQL and back (" ++ label ++ ")") $
166− output == input
167−
168− [(Only isExpectedIso)] <- query conn [sql|
169− SELECT sample = (?)::interval
170− FROM testinterval
171− WHERE id = ?
172− |] (asText, returnedId)
173−
174− assertBool ("CalendarDiffTime inserted did not match ISO8601 equivalent \"" ++ asText ++ "\". (" ++ label ++ ")")
175− isExpectedIso
176−
test/Main.hsdeleted−648
@@ -1,648 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DeriveGeneric #-}
3−{-# LANGUAGE DeriveDataTypeable #-}
4−{-# LANGUAGE DoAndIfThenElse #-}
5−{-# LANGUAGE ScopedTypeVariables #-}
6−#if __GLASGOW_HASKELL__ >= 806
7−{-# LANGUAGE DerivingStrategies #-}
8−{-# LANGUAGE DerivingVia #-}
9−{-# LANGUAGE DeriveAnyClass #-}
10−#endif
11−module Main (main) where
12−
13−import Common
14−import Database.PostgreSQL.Simple.Copy
15−import Database.PostgreSQL.Simple.ToField (ToField)
16−import Database.PostgreSQL.Simple.FromField (FromField)
17−import Database.PostgreSQL.Simple.HStore
18−import Database.PostgreSQL.Simple.Newtypes
19−import Database.PostgreSQL.Simple.Internal (breakOnSingleQuestionMark)
20−import Database.PostgreSQL.Simple.Types(Query(..),Values(..), PGArray(..))
21−import qualified Database.PostgreSQL.Simple.Transaction as ST
22−
23−import Control.Applicative
24−import Control.Exception as E
25−import Control.Monad
26−import Data.Char
27−import Data.Foldable (toList)
28−import Data.List (concat, sort)
29−import Data.IORef
30−import Data.Monoid ((<>))
31−import Data.String (fromString)
32−import Data.Typeable
33−import GHC.Generics (Generic)
34−
35−import Data.Aeson
36−import Data.ByteString (ByteString)
37−import qualified Data.ByteString as B
38−import qualified Data.ByteString.Char8 as BS8
39−import qualified Data.ByteString.Lazy.Char8 as BL
40−import Data.CaseInsensitive (CI)
41−import qualified Data.CaseInsensitive as CI
42−import Data.Map (Map)
43−import qualified Data.Map as Map
44−import Data.Text(Text)
45−import qualified Data.Text.Encoding as T
46−import qualified Data.Vector as V
47−import System.FilePath
48−import System.Timeout(timeout)
49−import Data.Time.Compat (getCurrentTime, diffUTCTime)
50−import System.Environment (getEnvironment)
51−
52−import Test.Tasty
53−import Test.Tasty.Golden
54−import Notify
55−import Serializable
56−import Time
57−import Interval
58−import Exception (testExceptions)
59−
60−tests :: TestEnv -> TestTree
61−tests env = testGroup "tests"
62− $ map ($ env)
63− [ testBytea
64− , testCase "ExecuteMany" . testExecuteMany
65− , testCase "Fold" . testFold
66− , testCase "Notify" . testNotify
67− , testCase "Serializable" . testSerializable
68− , testCase "Time" . testTime
69− , testCase "Interval" . testInterval
70− , testCase "Array" . testArray
71− , testCase "Array of nullables" . testNullableArray
72− , testCase "HStore" . testHStore
73− , testCase "citext" . testCIText
74− , testCase "JSON" . testJSON
75− , testCase "Aeson newtype" . testAeson
76− , testCase "DerivingVia" . testDerivingVia
77− , testCase "Question mark escape" . testQM
78− , testCase "Savepoint" . testSavepoint
79− , testCase "Unicode" . testUnicode
80− , testCase "Values" . testValues
81− , testCase "Copy" . testCopy
82− , testCopyFailures
83− , testCase "Double" . testDouble
84− , testCase "1-ary generic" . testGeneric1
85− , testCase "2-ary generic" . testGeneric2
86− , testCase "3-ary generic" . testGeneric3
87− , testCase "Timeout" . testTimeout
88− , testCase "Exceptions" . testExceptions
89− ]
90−
91−testBytea :: TestEnv -> TestTree
92−testBytea TestEnv{..} = testGroup "Bytea"
93− [ testStr "empty" []
94− , testStr "\"hello\"" $ map (fromIntegral . fromEnum) ("hello" :: String)
95− , testStr "ascending" [0..255]
96− , testStr "descending" [255,254..0]
97− , testStr "ascending, doubled up" $ doubleUp [0..255]
98− , testStr "descending, doubled up" $ doubleUp [255,254..0]
99− ]
100− where
101− testStr label bytes = testCase label $ do
102− let bs = B.pack bytes
103−
104− [Only h] <- query conn "SELECT md5(?::bytea)" [Binary bs]
105− assertBool "Haskell -> SQL conversion altered the string" $ md5 bs == h
106−
107− [Only (Binary r)] <- query conn "SELECT ?::bytea" [Binary bs]
108− assertBool "SQL -> Haskell conversion altered the string" $ bs == r
109−
110− doubleUp = concatMap (\x -> [x, x])
111−
112−testExecuteMany :: TestEnv -> Assertion
113−testExecuteMany TestEnv{..} = do
114− execute_ conn "CREATE TEMPORARY TABLE tmp_executeMany (i INT, t TEXT, b BYTEA)"
115−
116− let rows :: [(Int, String, Binary ByteString)]
117− rows = [ (1, "hello", Binary "bye")
118− , (2, "world", Binary "\0\r\t\n")
119− , (3, "?", Binary "")
120− ]
121−
122− count <- executeMany conn "INSERT INTO tmp_executeMany VALUES (?, ?, ?)" rows
123− count @?= fromIntegral (length rows)
124−
125− rows' <- query_ conn "SELECT * FROM tmp_executeMany"
126− rows' @?= rows
127−
128− return ()
129−
130−testFold :: TestEnv -> Assertion
131−testFold TestEnv{..} = do
132− xs <- fold_ conn "SELECT generate_series(1,10000)"
133− [] $ \xs (Only x) -> return (x:xs)
134− reverse xs @?= ([1..10000] :: [Int])
135−
136− ref <- newIORef []
137− forEach conn "SELECT * FROM generate_series(1,?) a, generate_series(1,?) b"
138− (100 :: Int, 50 :: Int) $ \(a :: Int, b :: Int) -> do
139− xs <- readIORef ref
140− writeIORef ref $! (a,b):xs
141− xs <- readIORef ref
142− reverse xs @?= [(a,b) | b <- [1..50], a <- [1..100]]
143−
144− -- Make sure fold propagates our exception.
145− ref <- newIORef []
146− True <- expectError (== TestException) $
147− forEach_ conn "SELECT generate_series(1,10)" $ \(Only a) ->
148− if a == 5 then do
149− -- Cause a SQL error to trip up CLOSE.
150− True <- expectError isSyntaxError $
151− execute_ conn "asdf"
152− True <- expectError ST.isFailedTransactionError $
153− (query_ conn "SELECT 1" :: IO [(Only Int)])
154− throwIO TestException
155− else do
156− xs <- readIORef ref
157− writeIORef ref $! (a :: Int) : xs
158− xs <- readIORef ref
159− reverse xs @?= [1..4]
160−
161− withTransaction conn $ replicateM_ 2 $ do
162− xs <- fold_ conn "VALUES (1), (2), (3), (4), (5)"
163− [] $ \xs (Only x) -> return (x:xs)
164− reverse xs @?= ([1..5] :: [Int])
165−
166− ref <- newIORef []
167− forEach_ conn "SELECT generate_series(1,101)" $ \(Only a) ->
168− forEach_ conn "SELECT generate_series(1,55)" $ \(Only b) -> do
169− xs <- readIORef ref
170− writeIORef ref $! (a :: Int, b :: Int) : xs
171− xs <- readIORef ref
172− reverse xs @?= [(a,b) | a <- [1..101], b <- [1..55]]
173−
174− xs <- fold_ conn "SELECT 1 WHERE FALSE"
175− [] $ \xs (Only x) -> return (x:xs)
176− xs @?= ([] :: [Int])
177−
178− -- TODO: add more complete tests, e.g.:
179− --
180− -- * Fold in a transaction
181− --
182− -- * Fold in a transaction after a previous fold has been performed
183− --
184− -- * Nested fold
185−
186− return ()
187−
188−queryFailure :: forall a. (FromField a, Typeable a, Show a)
189− => Connection -> Query -> a -> Assertion
190−queryFailure conn q resultType = do
191− x :: Either SomeException [Only a] <- E.try $ query_ conn q
192− case x of
193− Left _ -> return ()
194− Right val -> assertFailure ("Did not fail as expected: "
195− ++ show q
196− ++ " :: "
197− ++ show (typeOf resultType)
198− ++ " -> " ++ show val)
199−
200−testArray :: TestEnv -> Assertion
201−testArray TestEnv{..} = do
202− xs <- query_ conn "SELECT '{1,2,3,4}'::_int4"
203− xs @?= [Only (V.fromList [1,2,3,4 :: Int])]
204− xs <- query_ conn "SELECT '{{1,2},{3,4}}'::_int4"
205− xs @?= [Only (V.fromList [V.fromList [1,2],
206− V.fromList [3,4 :: Int]])]
207− queryFailure conn "SELECT '{1,2,3,4}'::_int4" (undefined :: V.Vector Bool)
208− queryFailure conn "SELECT '{{1,2},{3,4}}'::_int4" (undefined :: V.Vector Int)
209−
210−testNullableArray :: TestEnv -> Assertion
211−testNullableArray TestEnv{..} = do
212− xs <- query_ conn "SELECT '{sometext, \"NULL\"}'::_text"
213− xs @?= [Only (V.fromList ["sometext", "NULL" :: Text])]
214− xs <- query_ conn "SELECT '{sometext, NULL}'::_text"
215− xs @?= [Only (V.fromList [Just "sometext", Nothing :: Maybe Text])]
216− queryFailure conn "SELECT '{sometext, NULL}'::_text" (undefined :: V.Vector Text)
217−
218−testHStore :: TestEnv -> Assertion
219−testHStore TestEnv{..} = do
220− execute_ conn "CREATE EXTENSION IF NOT EXISTS hstore"
221− roundTrip []
222− roundTrip [("foo","bar"),("bar","baz"),("baz","hello")]
223− roundTrip [("fo\"o","bar"),("b\\ar","baz"),("baz","\"value\\with\"escapes")]
224− where
225− roundTrip :: [(Text,Text)] -> Assertion
226− roundTrip xs = do
227− let m = Only (HStoreMap (Map.fromList xs))
228− m' <- query conn "SELECT ?::hstore" m
229− [m] @?= m'
230−
231−testCIText :: TestEnv -> Assertion
232−testCIText TestEnv{..} = do
233− execute_ conn "CREATE EXTENSION IF NOT EXISTS citext"
234− roundTrip (CI.mk "")
235− roundTrip (CI.mk "UPPERCASE")
236− roundTrip (CI.mk "lowercase")
237− where
238− roundTrip :: (CI Text) -> Assertion
239− roundTrip cit = do
240− let toPostgres = Only cit
241− fromPostgres <- query conn "SELECT ?::citext" toPostgres
242− [toPostgres] @?= fromPostgres
243−
244−testJSON :: TestEnv -> Assertion
245−testJSON TestEnv{..} = do
246− roundTrip (Map.fromList [] :: Map Text Text)
247− roundTrip (Map.fromList [("foo","bar"),("bar","baz"),("baz","hello")] :: Map Text Text)
248− roundTrip (Map.fromList [("fo\"o","bar"),("b\\ar","baz"),("baz","\"value\\with\"escapes")] :: Map Text Text)
249− roundTrip (V.fromList [1,2,3,4,5::Int])
250− roundTrip ("foo" :: Text)
251− roundTrip (42 :: Int)
252− where
253− roundTrip :: ToJSON a => a -> Assertion
254− roundTrip a = do
255− let js = Only (toJSON a)
256− js' <- query conn "SELECT ?::json" js
257− [js] @?= js'
258−
259−testAeson :: TestEnv -> Assertion
260−testAeson TestEnv{..} = do
261− roundTrip (Map.fromList [] :: Map Text Text)
262− roundTrip (Map.fromList [("foo","bar"),("bar","baz"),("baz","hello")] :: Map Text Text)
263− roundTrip (Map.fromList [("fo\"o","bar"),("b\\ar","baz"),("baz","\"value\\with\"escapes")] :: Map Text Text)
264− roundTrip (V.fromList [1,2,3,4,5::Int])
265− roundTrip ("foo" :: Text)
266− roundTrip (42 :: Int)
267− where
268− roundTrip :: (Eq a, Show a, Typeable a, ToJSON a, FromJSON a)=> a -> Assertion
269− roundTrip x = do
270− y <- query conn "SELECT ?::json" (Only (Aeson x))
271− [Only (Aeson x)] @?= y
272−
273−testDerivingVia :: TestEnv -> Assertion
274−testDerivingVia TestEnv{..} = do
275−#if __GLASGOW_HASKELL__ <806
276− return ()
277−#else
278− roundTrip $ DerivingVia1 42 "Meaning of Life"
279− where
280− roundTrip :: (Eq a, Show a, Typeable a, ToField a, FromField a)=> a -> Assertion
281− roundTrip x = do
282− y <- query conn "SELECT ?::json" (Only x)
283− [Only x] @?= y
284−
285−data DerivingVia1 = DerivingVia1 Int String
286− deriving stock (Eq, Show, Generic)
287− deriving anyclass (FromJSON, ToJSON)
288− deriving (ToField, FromField) via Aeson DerivingVia1
289−
290−#endif
291−
292−
293−testQM :: TestEnv -> Assertion
294−testQM TestEnv{..} = do
295− -- Just test on a single string
296− let testQuery' b = "testing for ?" <> b <> " and making sure "
297− testQueryDoubleQM = testQuery' "?"
298− testQueryRest = "? is substituted"
299− testQuery = fromString $ testQueryDoubleQM <> testQueryRest
300− -- expect the entire first part with double QMs replaced with literal '?'
301− expected = (fromString $ testQuery' "", fromString testQueryRest)
302− tried = breakOnSingleQuestionMark testQuery
303− errMsg = concat
304− [ "Failed to break on single question mark exclusively:\n"
305− , "expected: ", show expected
306− , "result: ", show tried
307− ]
308− assertBool errMsg $ tried == expected
309−
310− -- Let's also test the question mark operators in action
311− -- ? -> Does the string exist as a top-level key within the JSON value?
312− positiveQuery "SELECT ?::jsonb ?? ?" (testObj, "foo" :: Text)
313− negativeQuery "SELECT ?::jsonb ?? ?" (testObj, "baz" :: Text)
314− negativeQuery "SELECT ?::jsonb ?? ?" (toJSON numArray, "1" :: Text)
315− -- ?| -> Do any of these array strings exist as top-level keys?
316− positiveQuery "SELECT ?::jsonb ??| ?" (testObj, PGArray ["nope","bar","6" :: Text])
317− negativeQuery "SELECT ?::jsonb ??| ?" (testObj, PGArray ["nope","6" :: Text])
318− negativeQuery "SELECT ?::jsonb ??| ?" (toJSON numArray, PGArray ["1","2","6" :: Text])
319− -- ?& -> Do all of these array strings exist as top-level keys?
320− positiveQuery "SELECT ?::jsonb ??& ?" (testObj, PGArray ["foo","bar","quux" :: Text])
321− positiveQuery "SELECT ?::jsonb ??& ?" (testObj, PGArray ["foo","bar" :: Text])
322− negativeQuery "SELECT ?::jsonb ??& ?" (testObj, PGArray ["foo","bar","baz" :: Text])
323− negativeQuery "SELECT ?::jsonb ??& ?" (toJSON numArray, PGArray ["1","2","3","4","5" :: Text])
324− -- Format error for 2 question marks, not 4
325− True <- expectError (isFormatError 2) $
326− (query conn "SELECT ?::jsonb ?? ?" $ Only testObj :: IO [Only Bool])
327− return ()
328− where positiveQuery :: ToRow a => Query -> a -> Assertion
329− positiveQuery = boolQuery True
330− negativeQuery :: ToRow a => Query -> a -> Assertion
331− negativeQuery = boolQuery False
332− numArray :: [Int]
333− numArray = [1,2,3,4,5]
334− boolQuery :: ToRow a => Bool -> Query -> a -> Assertion
335− boolQuery b t x = do
336− a <- query conn t x
337− [Only b] @?= a
338− testObj = toJSON (Map.fromList [("foo",toJSON (1 :: Int))
339− ,("bar",String "baz")
340− ,("quux",toJSON [1 :: Int,2,3,4,5])] :: Map Text Value
341− )
342−
343−testSavepoint :: TestEnv -> Assertion
344−testSavepoint TestEnv{..} = do
345− True <- expectError ST.isNoActiveTransactionError $
346− withSavepoint conn $ return ()
347−
348− let getRows :: IO [Int]
349− getRows = map fromOnly <$> query_ conn "SELECT a FROM tmp_savepoint ORDER BY a"
350− withTransaction conn $ do
351− execute_ conn "CREATE TEMPORARY TABLE tmp_savepoint (a INT UNIQUE)"
352− execute_ conn "INSERT INTO tmp_savepoint VALUES (1)"
353− [1] <- getRows
354−
355− withSavepoint conn $ do
356− execute_ conn "INSERT INTO tmp_savepoint VALUES (2)"
357− [1,2] <- getRows
358− return ()
359− [1,2] <- getRows
360−
361− withSavepoint conn $ do
362− execute_ conn "INSERT INTO tmp_savepoint VALUES (3)"
363− [1,2,3] <- getRows
364− True <- expectError isUniqueViolation $
365− execute_ conn "INSERT INTO tmp_savepoint VALUES (2)"
366− True <- expectError ST.isFailedTransactionError getRows
367−
368− -- Body returning successfully after handling error,
369− -- but 'withSavepoint' will roll back without complaining.
370− return ()
371− -- Rolling back clears the error condition.
372− [1,2] <- getRows
373−
374− -- 'withSavepoint' will roll back after an exception, even if the
375− -- exception wasn't SQL-related.
376− True <- expectError (== TestException) $
377− withSavepoint conn $ do
378− execute_ conn "INSERT INTO tmp_savepoint VALUES (3)"
379− [1,2,3] <- getRows
380− throwIO TestException
381− [1,2] <- getRows
382−
383− -- Nested savepoint can be rolled back while the
384− -- outer effects are retained.
385− withSavepoint conn $ do
386− execute_ conn "INSERT INTO tmp_savepoint VALUES (3)"
387− True <- expectError isUniqueViolation $
388− withSavepoint conn $ do
389− execute_ conn "INSERT INTO tmp_savepoint VALUES (4)"
390− [1,2,3,4] <- getRows
391− execute_ conn "INSERT INTO tmp_savepoint VALUES (4)"
392− [1,2,3] <- getRows
393− return ()
394− [1,2,3] <- getRows
395−
396− return ()
397−
398− -- Transaction committed successfully, even though there were errors
399− -- (but we rolled them back).
400− [1,2,3] <- getRows
401−
402− return ()
403−
404−testUnicode :: TestEnv -> Assertion
405−testUnicode TestEnv{..} = do
406− let q = Query . T.encodeUtf8 -- Handle encoding ourselves to ensure
407− -- the table gets created correctly.
408− let messages = map Only ["привет","мир"] :: [Only Text]
409− execute_ conn (q "CREATE TEMPORARY TABLE ру́сский (сообщение TEXT)")
410− executeMany conn "INSERT INTO ру́сский (сообщение) VALUES (?)" messages
411− messages' <- query_ conn "SELECT сообщение FROM ру́сский"
412− sort messages @?= sort messages'
413−
414−testValues :: TestEnv -> Assertion
415−testValues TestEnv{..} = do
416− execute_ conn "CREATE TEMPORARY TABLE values_test (x int, y text)"
417− test (Values ["int4","text"] [])
418− test (Values ["int4","text"] [(1,"hello")])
419− test (Values ["int4","text"] [(1,"hello"),(2,"world")])
420− test (Values ["int4","text"] [(1,"hello"),(2,"world"),(3,"goodbye")])
421− test (Values [] [(1,"hello")])
422− test (Values [] [(1,"hello"),(2,"world")])
423− test (Values [] [(1,"hello"),(2,"world"),(3,"goodbye")])
424− where
425− test :: Values (Int, Text) -> Assertion
426− test table@(Values _ vals) = do
427− execute conn "INSERT INTO values_test ?" (Only table)
428− vals' <- query_ conn "DELETE FROM values_test RETURNING *"
429− sort vals @?= sort vals'
430−
431−
432−testCopy :: TestEnv -> Assertion
433−testCopy TestEnv{..} = do
434− execute_ conn "CREATE TEMPORARY TABLE copy_test (x int, y text)"
435− copy_ conn "COPY copy_test FROM STDIN (FORMAT CSV)"
436− mapM_ (putCopyData conn) copyRows
437− putCopyEnd conn
438− copy_ conn "COPY copy_test FROM STDIN (FORMAT CSV)"
439− mapM_ (putCopyData conn) abortRows
440− putCopyError conn "aborted"
441− -- Hmm, does postgres always produce \n as an end-of-line here, or
442− -- are there cases where it will use a \r\n as well?
443− copy_ conn "COPY copy_test TO STDOUT (FORMAT CSV)"
444− rows <- loop []
445− sort rows @?= sort copyRows
446− -- Now, let's just verify that the connection state is back to ready,
447− -- so that we can issue more queries:
448− [Only (x::Int)] <- query_ conn "SELECT 2 + 2"
449− x @?= 4
450− -- foldCopyData
451− copy_ conn "COPY copy_test TO STDOUT (FORMAT CSV)"
452− (acc, count) <- foldCopyData conn
453− (\acc row -> return (row:acc))
454− (\acc count -> return (acc, count))
455− []
456− sort acc @?= sort copyRows
457− count @?= 2
458− where
459− copyRows = ["1,foo\n"
460− ,"2,bar\n"]
461− abortRows = ["3,baz\n"]
462− loop rows = do
463− mrow <- getCopyData conn
464− case mrow of
465− CopyOutDone _ -> return rows
466− CopyOutRow row -> loop (row:rows)
467−
468−testCopyFailures :: TestEnv -> TestTree
469−testCopyFailures env = testGroup "Copy failures"
470− $ map ($ env)
471− [ testCopyUniqueConstraintError
472− , testCopyMalformedError
473− ]
474−
475−goldenTest :: TestName -> IO BL.ByteString -> TestTree
476−goldenTest testName =
477− goldenVsStringDiff testName diff (resultsDir </> fileName<.>"expected")
478− where
479− resultsDir = "test" </> "results"
480− fileName = map normalize testName
481− normalize c | not (isAlpha c) = '-'
482− | otherwise = c
483− diff ref new = ["diff", "-u", ref, new]
484−
485−-- | Test that we provide a sensible error message on failure
486−testCopyUniqueConstraintError :: TestEnv -> TestTree
487−testCopyUniqueConstraintError TestEnv{..} =
488− goldenTest "unique constraint violation"
489− $ handle (\(SomeException exc) -> return $ BL.pack $ show exc) $ do
490− execute_ conn "CREATE TEMPORARY TABLE copy_unique_constraint_error_test (x int PRIMARY KEY, y text)"
491− copy_ conn "COPY copy_unique_constraint_error_test FROM STDIN (FORMAT CSV)"
492− mapM_ (putCopyData conn) copyRows
493− _n <- putCopyEnd conn
494− return BL.empty
495− where
496− copyRows = ["1,foo\n"
497− ,"2,bar\n"
498− ,"1,baz\n"]
499−
500−testCopyMalformedError :: TestEnv -> TestTree
501−testCopyMalformedError TestEnv{..} =
502− goldenTest "malformed input"
503− $ handle (\(SomeException exc) -> return $ BL.pack $ show exc) $ do
504− execute_ conn "CREATE TEMPORARY TABLE copy_malformed_input_error_test (x int PRIMARY KEY, y text)"
505− copy_ conn "COPY copy_unique_constraint_error_test FROM STDIN (FORMAT CSV)"
506− mapM_ (putCopyData conn) copyRows
507− _n <- putCopyEnd conn
508− return BL.empty
509− where
510− copyRows = ["1,foo\n"
511− ,"2,bar\n"
512− ,"z,baz\n"]
513−
514−testTimeout :: TestEnv -> Assertion
515−testTimeout TestEnv{..} =
516− withConn $ \c -> do
517− start_t <- getCurrentTime
518− res <- timeout 200000 $ do
519− withTransaction c $ do
520− query_ c "SELECT pg_sleep(1)" :: IO [Only ()]
521− end_t <- getCurrentTime
522− assertBool "Timeout did not occur" (res == Nothing)
523−#if !defined(mingw32_HOST_OS)
524−-- At the moment, you cannot timely abandon queries with async exceptions on
525−-- Windows.
526− let d = end_t `diffUTCTime` start_t
527− assertBool "Timeout didn't work in a timely fashion" (0.1 < d && d < 0.6)
528−#endif
529−
530−testDouble :: TestEnv -> Assertion
531−testDouble TestEnv{..} = do
532− [Only (x :: Double)] <- query_ conn "SELECT 'NaN'::float8"
533− assertBool "expected NaN" (isNaN x)
534− [Only (x :: Double)] <- query_ conn "SELECT 'Infinity'::float8"
535− x @?= (1 / 0)
536− [Only (x :: Double)] <- query_ conn "SELECT '-Infinity'::float8"
537− x @?= (-1 / 0)
538−
539−
540−testGeneric1 :: TestEnv -> Assertion
541−testGeneric1 TestEnv{..} = do
542− roundTrip conn (Gen1 123)
543− where
544− roundTrip conn x0 = do
545− r <- query conn "SELECT ?::int" (x0 :: Gen1)
546− r @?= [x0]
547−
548−testGeneric2 :: TestEnv -> Assertion
549−testGeneric2 TestEnv{..} = do
550− roundTrip conn (Gen2 123 "asdf")
551− where
552− roundTrip conn x0 = do
553− r <- query conn "SELECT ?::int, ?::text" x0
554− r @?= [x0]
555−
556−testGeneric3 :: TestEnv -> Assertion
557−testGeneric3 TestEnv{..} = do
558− roundTrip conn (Gen3 123 "asdf" True)
559− where
560− roundTrip conn x0 = do
561− r <- query conn "SELECT ?::int, ?::text, ?::bool" x0
562− r @?= [x0]
563−
564−data Gen1 = Gen1 Int
565− deriving (Show,Eq,Generic)
566−instance FromRow Gen1
567−instance ToRow Gen1
568−
569−data Gen2 = Gen2 Int Text
570− deriving (Show,Eq,Generic)
571−instance FromRow Gen2
572−instance ToRow Gen2
573−
574−data Gen3 = Gen3 Int Text Bool
575− deriving (Show,Eq,Generic)
576−instance FromRow Gen3
577−instance ToRow Gen3
578−
579−data TestException
580− = TestException
581− deriving (Eq, Show, Typeable)
582−
583−instance Exception TestException
584−
585−expectError :: Exception e => (e -> Bool) -> IO a -> IO Bool
586−expectError p io =
587− (io >> return False) `E.catch` \ex ->
588− if p ex then return True else throwIO ex
589−
590−isUniqueViolation :: SqlError -> Bool
591−isUniqueViolation SqlError{..} = sqlState == "23505"
592−
593−isSyntaxError :: SqlError -> Bool
594−isSyntaxError SqlError{..} = sqlState == "42601"
595−
596−isFormatError :: Int -> FormatError -> Bool
597−isFormatError i FormatError{..}
598− | null fmtMessage = False
599− | otherwise = fmtMessage == concat [ show i
600− , " single '?' characters, but "
601− , show (length fmtParams)
602− , " parameters"
603− ]
604−------------------------------------------------------------------------
605−
606−-- | Action for connecting to the database that will be used for testing.
607−--
608−-- Note that some tests, such as Notify, use multiple connections, and assume
609−-- that 'testConnect' connects to the same database every time it is called.
610−withTestEnv :: ByteString -> (TestEnv -> IO a) -> IO a
611−withTestEnv connstr cb =
612− withConn $ \conn -> do
613− -- currently required for interval to work.
614− -- we also test that this doesn't interfere with anything else
615− execute_ conn "SET intervalstyle TO 'iso_8601'"
616−
617− cb TestEnv
618− { conn = conn
619− , withConn = withConn
620− }
621− where
622− withConn = bracket (connectPostgreSQL connstr) close
623−
624−main :: IO ()
625−main = withConnstring $ \connstring -> do
626− withTestEnv connstring (defaultMain . tests)
627−
628−withConnstring :: (BS8.ByteString -> IO ()) -> IO ()
629−withConnstring kont = do
630− env <- getEnvironment
631− case lookup "DATABASE_CONNSTRING" env of
632− Just s -> kont (BS8.pack (special s))
633− Nothing -> case lookup "GITHUB_ACTIONS" env of
634− Just "true" -> kont (BS8.pack gha)
635− _ -> putStrLn "Set DATABASE_CONNSTRING environment variable"
636− where
637− -- https://www.appveyor.com/docs/services-databases/
638− special "appveyor" = "dbname='TestDb' user='postgres' password='Password12!'"
639− special "travis" = ""
640− special s = s
641−
642− gha = unwords
643− [ "dbname='postgres'"
644− , "user='postgres'"
645− , "password='postgres'"
646− , "host='postgres'"
647− , "port=5432"
648− ]
test/Notify.hsdeleted−41
@@ -1,41 +0,0 @@
1−module Notify (testNotify) where
2−
3−import Common
4−
5−import Control.Applicative
6−import Control.Concurrent
7−import Control.Monad
8−import Data.Function
9−import Data.List
10−import Database.PostgreSQL.Simple.Notification
11−
12−import qualified Data.ByteString as B
13−
14−-- TODO: Test with payload, but only for PostgreSQL >= 9.0
15−-- (when that feature was introduced).
16−
17−testNotify :: TestEnv -> Assertion
18−testNotify TestEnv{..} =
19− withConn $ \conn2 -> do
20− execute_ conn "LISTEN foo"
21− execute_ conn "LISTEN bar"
22−
23− results_mv <- newEmptyMVar
24− forkIO $ replicateM 2 (getNotification conn)
25− >>= putMVar results_mv
26−
27− threadDelay 100000
28−
29− execute_ conn2 "NOTIFY foo"
30− execute_ conn2 "NOTIFY bar"
31−
32− [n1, n2] <- sortBy (compare `on` notificationChannel)
33− <$> takeMVar results_mv
34−
35− assertEqual "n1" "bar" (notificationChannel n1)
36− assertEqual "n2" "foo" (notificationChannel n2)
37−
38− -- Other sanity checks
39− assertEqual "Server PIDs match" (notificationPid n1) (notificationPid n2)
40− assertBool "notificationData is empty" $
41− all (B.null . notificationData) [n1, n2]
test/Serializable.hsdeleted−68
@@ -1,68 +0,0 @@
1−module Serializable (testSerializable) where
2−
3−import Common
4−import Control.Concurrent
5−import Control.Exception as E
6−import Data.IORef
7−import Database.PostgreSQL.Simple.Transaction
8−
9−initCounter :: Connection -> IO ()
10−initCounter conn = do
11− 0 <- execute_ conn "DROP TABLE IF EXISTS testSerializableCounter;\
12− \ CREATE TABLE testSerializableCounter (n INT)"
13− 1 <- execute_ conn "INSERT INTO testSerializableCounter VALUES (0)"
14− return ()
15−
16−getCounter :: Connection -> IO Int
17−getCounter conn = do
18− [Only n] <- query_ conn "SELECT n FROM testSerializableCounter"
19− return n
20−
21−putCounter :: Connection -> Int -> IO ()
22−putCounter conn n = do
23− 1 <- execute conn "UPDATE testSerializableCounter SET n=?" (Only n)
24− return ()
25−
26−testSerializable :: TestEnv -> Assertion
27−testSerializable TestEnv{..} =
28− withConn $ \conn2 -> do
29− initCounter conn
30−
31− attemptCounter <- newIORef (0 :: Int)
32− readyToBother <- newEmptyMVar
33− bothered <- newEmptyMVar
34− finished <- newEmptyMVar
35−
36− _ <- forkIO $ do
37− withTransactionSerializable conn2 $ do
38− modifyIORef attemptCounter (+1)
39− n <- getCounter conn2
40− True <- tryPutMVar readyToBother ()
41− readMVar bothered
42− putCounter conn2 (n+1)
43− putMVar finished ()
44−
45− takeMVar readyToBother
46− withTransactionSerializable conn $ do
47− n <- getCounter conn
48− putCounter conn (n+1)
49− True <- tryPutMVar bothered ()
50−
51− takeMVar finished
52−
53− ac <- readIORef attemptCounter
54− assertEqual "attemptCounter" 2 ac
55−
56− ok <- E.catch (do withTransactionSerializable conn (fail "Whoops")
57− return False)
58− (\(_ :: IOException) -> return True)
59− assertBool "Exceptions (besides serialization failure) should be\
60− \ propagated through withTransactionSerializable"
61− ok
62−
63− -- Make sure transaction isn't dangling
64− 1 <- execute_ conn "UPDATE testSerializableCounter SET n=12345"
65− 0 <- execute_ conn "ROLLBACK"
66− -- This prints "NOTICE: there is no transaction in progress"
67− [Only (12345 :: Int)] <- query_ conn "SELECT n FROM testSerializableCounter"
68− return ()
test/Time.hsdeleted−119
@@ -1,119 +0,0 @@
1−{-# LANGUAGE QuasiQuotes #-}
2−
3−{-
4−
5−Testing strategies:
6−
7−fromString . toString == id ** Todo?
8−
9−toString . fromString == almost id ** Todo?
10−
11−postgresql -> haskell -> postgresql * Done
12−
13−haskell -> postgresql -> haskell ** Todo?
14−
15−But still, what we really want to establish is that the two values
16−correspond; for example, a conversion that consistently added hour
17−when printed to a string and subtracted an hour when parsed from string
18−would still pass these tests.
19−
20−
21−Right now, we are checking that 1400+ timestamps in the range of 1860 to
22−2060 round trip from postgresql to haskell and back in 5 different timezones.
23−In addition to UTC, the four timezones were selected so that 2 have a positive
24−offset, and 2 have a negative offset, and that 2 have an offset of a
25−whole number of hours, while the other two do not.
26−
27−It may be worth adding a few more timezones to ensure better test coverage.
28−
29−We are checking a handful of selected timestamps to ensure we hit
30−various corner-cases in the code, in addition to 1400 timestamps randomly
31−generated with granularity of seconds down to microseconds in powers of ten.
32−
33−-}
34−
35−module Time (testTime) where
36−
37−import Common
38−import Control.Monad(forM_, replicateM_)
39−import Data.Time.Compat
40−import Data.ByteString(ByteString)
41−import Database.PostgreSQL.Simple.SqlQQ
42−
43−numTests :: Int
44−numTests = 200
45−
46−testTime :: TestEnv -> Assertion
47−testTime env@TestEnv{..} = do
48− initializeTable env
49− execute_ conn "SET timezone TO 'UTC'"
50− checkRoundTrips env "1860-01-01 00:00:00+00"
51− execute_ conn "SET timezone TO 'America/Chicago'" -- -5:00
52− checkRoundTrips env "1883-11-18 12:00:00-06"
53− execute_ conn "SET timezone TO 'Asia/Tokyo'" -- +9:00
54− checkRoundTrips env "1888-01-01 00:00:00+09"
55− execute_ conn "SET timezone TO 'Asia/Kathmandu'" -- +5:45
56− checkRoundTrips env "1919-12-31 23:48:44+05:30"
57− execute_ conn "SET timezone TO 'America/St_Johns'" -- -3:30
58− checkRoundTrips env "1935-03-30 00:00:52-03:30"
59−
60−initializeTable :: TestEnv -> IO ()
61−initializeTable TestEnv{..} = withTransaction conn $ do
62− execute_ conn
63− [sql| CREATE TEMPORARY TABLE testtime
64− ( x serial, y timestamptz, PRIMARY KEY(x) ) |]
65−
66− let test :: ByteString -> IO () = \x -> do
67− execute conn [sql|
68− INSERT INTO testtime (y) VALUES (?)
69− |] (Only x)
70− return ()
71− -- America/Chicago
72− test "1883-11-18 11:59:59-05:50:36"
73− test "1883-11-18 12:09:23-05:50:36"
74− test "1883-11-18 12:00:00-06"
75− -- Asia/Tokyo
76− test "1887-12-31 23:59:59+09:18:59"
77− test "1888-01-01 00:18:58+09:18:59"
78− test "1888-01-01 00:00:00+09"
79− -- Asia/Kathmandu
80− test "1919-12-31 23:59:59+05:41:16"
81− test "1919-12-31 23:48:44+05:30"
82− test "1985-12-31 23:59:59+05:30"
83− test "1986-01-01 00:15:00+05:45"
84− -- America/St_Johns
85− test "1935-03-29 23:59:59-03:30:52"
86− test "1935-03-30 00:00:52-03:30"
87−
88− -- While the above special cases are probably a decent start, there
89− -- are probably more that are well worth adding to ensure better
90− -- coverage.
91−
92− let pop :: ByteString -> Double -> IO () = \x y ->
93− replicateM_ numTests $ execute conn
94− [sql| INSERT INTO testtime (y) VALUES
95− ('1860-01-01 00:00:00+00'::timestamptz
96− + ?::interval * ROUND(RANDOM() * ?)) |] (x,y)
97− pop "1 microsecond" 6.3113904e15
98− pop "10 microseconds" 6.3113904e14
99− pop "100 microseconds" 6.3113904e13
100− pop "1 millisecond" 6.3113904e12
101− pop "10 milliseconds" 6.3113904e11
102− pop "100 milliseconds" 6.3113904e10
103− pop "1 second" 6.3113904e9
104−
105−checkRoundTrips :: TestEnv -> ByteString -> IO ()
106−checkRoundTrips TestEnv{..} limit = do
107− yxs :: [(UTCTime, Int)] <- query_ conn [sql| SELECT y, x FROM testtime |]
108− forM_ yxs $ \yx -> do
109− res <- query conn [sql| SELECT y=? FROM testtime WHERE x=? |] yx
110− assertBool "UTCTime did not round-trip from SQL to Haskell and back" $
111− res == [Only True]
112−
113− yxs :: [(ZonedTime, Int)] <- query conn [sql|
114− SELECT y, x FROM testtime WHERE y > ?
115− |] (Only limit)
116− forM_ yxs $ \yx -> do
117− res <- query conn [sql| SELECT y=? FROM testtime WHERE x=? |] yx
118− assertBool "ZonedTime did not round-trip from SQL to Haskell and back" $
119− res == [Only True]
test/WRITING-TESTSdeleted−42
@@ -1,42 +0,0 @@
1−Do what is EASIEST. Having a test at all is more important than,
2−say, pretty failure output.
3−
4−To add a test, open Main.hs, and add an entry to tests, e.g.:
5−
6− tests :: [TestEnv -> Test]
7− tests =
8− [ ...
9− , TestLabel "Foo" . testFoo
10− ]
11−
12− testFoo :: TestEnv -> Test
13− testFoo TestEnv{..} = TestCase $ do
14− meaningOfLife @?= 42
15− 2013 <- getCurrentYear
16− return ()
17−
18−Mnemonic for HUnit @=? and @?= operators:
19−
20− * `?` is the value whose correctness is in question
21−
22− * `=` is the expected value
23−
24−If you move a test to a separate module, don't forget to add it to
25−"other-modules" in postgresql-simple.cabal . Otherwise, the module will be
26−left out of the tarball generated by `cabal sdist`, and tests will fail to
27−build when installing from Hackage.
28−
29−'TestEnv' (defined in Common.hs) contains information for accessing the
30−database. `TestEnv{..}` is a record wildcard which brings the following
31−definitions into scope:
32−
33− conn :: Connection
34− withConn :: (Connection -> IO a) -> IO a
35−
36−'conn' is a database connection shared by all the tests.
37−'withConn' can be used to open additional connections (to the same database).
38−
39−'Test' is basically a tree of 'Assertion's, where 'Assertion' is just a type
40−alias for IO (). See the [HUnit documentation][1] for more information.
41−
42− [1]: http://hackage.haskell.org/packages/archive/HUnit/latest/doc/html/Test-HUnit-Base.html
test/results/malformed-input.expecteddeleted−4
@@ -1,4 +0,0 @@
1−user error (Database.PostgreSQL.Simple.Copy.putCopyEnd: failed to parse command status
2−Connection error: ERROR: invalid input syntax for type integer: "z"
3−CONTEXT: COPY copy_unique_constraint_error_test, line 3, column x: "z"
4−)
test/results/unique-constraint-violation.expecteddeleted−5
@@ -1,5 +0,0 @@
1−user error (Database.PostgreSQL.Simple.Copy.putCopyEnd: failed to parse command status
2−Connection error: ERROR: duplicate key value violates unique constraint "copy_unique_constraint_error_test_pkey"
3−DETAIL: Key (x)=(1) already exists.
4−CONTEXT: COPY copy_unique_constraint_error_test, line 3
5−)
tools/GenBuiltinTypes.hsnew file+185
@@ -0,0 +1,185 @@
1+------------------------------------------------------------------------------
2+-- |
3+-- Module: GenBuiltinTypes
4+-- Copyright: (c) 2011 Leon P Smith
5+-- License: BSD3
6+-- Maintainer: Leon P Smith <leon@melding-monads.com>
7+-- Stability: experimental
8+--
9+-- Queries a PostgreSQL for the Object IDs associated with built-in typenames,
10+-- and generates Haskell boilerplate to handle this mapping. The subset
11+-- of types handled this way is easily modifiable, but note that
12+-- user-defined types do not have stable oids, and can differ between
13+-- databases or dumps/reloads.
14+------------------------------------------------------------------------------
15+
16+{-# LANGUAGE OverloadedStrings, QuasiQuotes, ViewPatterns #-}
17+module GenBuiltinTypes where
18+
19+import Prelude hiding ((++))
20+
21+import StringsQQ
22+import Database.PostgreSQL.Simple
23+import qualified Data.ByteString.Char8 as B
24+import qualified Data.ByteString.Lazy as L
25+import qualified Blaze.ByteString.Builder as Blaze
26+import qualified Blaze.ByteString.Builder.ByteString as Blaze
27+import qualified Blaze.ByteString.Builder.Char8 as Blaze
28+import Data.String
29+import Data.List ( sort, intersperse )
30+import qualified Data.Map as Map
31+
32+import Data.Monoid
33+
34+(++) :: Monoid a => a -> a -> a
35+(++) = mappend
36+infixr 5 ++
37+
38+type Map = Map.Map B.ByteString Int
39+builtins :: [(B.ByteString, B.ByteString)]
40+builtins = [strings|
41+bool
42+bytea
43+char
44+name
45+int8
46+int2
47+int4
48+regproc
49+text
50+oid
51+tid
52+xid
53+cid
54+xml
55+point
56+lseg
57+path
58+box
59+polygon
60+line
61+cidr
62+float4
63+float8
64+abstime
65+reltime
66+tinterval
67+unknown
68+circle
69+money
70+macaddr
71+inet
72+bpchar
73+varchar
74+date
75+time
76+timestamp
77+timestamptz TimestampWithTimeZone
78+interval
79+timetz TimeWithTimeZone
80+bit
81+varbit
82+numeric
83+refcursor
84+record
85+void
86+|]
87+
88+instance IsString Blaze.Builder where
89+ fromString = Blaze.fromByteString . fromString
90+
91+main = do
92+ conn <- connect ConnectInfo {
93+ connectHost = "127.0.0.1",
94+ connectPort = 5432,
95+ connectUser = "aliadmin",
96+ connectPassword = "aliadmin",
97+ connectDatabase = "postgres"
98+ }
99+ xs <- query conn "SELECT typname::text, oid::int\
100+ \ FROM pg_type\
101+ \ WHERE typname IN ?"
102+ (Only (In (sort (map fst builtins))))
103+ close conn
104+ let oidmap = Map.fromList xs :: Map
105+ L.writeFile "../src/Database/PostgreSQL/Simple/BuiltinTypes.hs"
106+ (Blaze.toLazyByteString (renderFile oidmap builtins))
107+
108+padCons str = fromString (replicate (len - B.length str) ' ')
109+ where
110+ len = maximum (map (B.length . snd) builtins)
111+
112+renderOid oidmap x
113+ = case Map.lookup x oidmap of
114+ Nothing -> error (B.unpack x)
115+ Just (show -> n) -> fromString (replicate (4 - length n) ' ')
116+ ++ fromString n
117+
118+renderOid' oidmap x
119+ = case Map.lookup x oidmap of
120+ Nothing -> error (B.unpack x)
121+ Just (show -> n) -> fromString n
122+ ++ fromString (replicate (4 - length n) ' ')
123+
124+bs = Blaze.fromByteString
125+
126+renderFile :: Map -> [(B.ByteString,B.ByteString)] -> Blaze.Builder
127+renderFile oidmap builtins = ([longstring|
128+{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}
129+
130+------------------------------------------------------------------------------
131+-- |
132+-- Module: Database.PostgreSQL.Simple.BuiltinTypes
133+-- Copyright: (c) 2011 Leon P Smith
134+-- License: BSD3
135+-- Maintainer: Leon P Smith <leon@melding-monads.com>
136+-- Stability: experimental
137+--
138+------------------------------------------------------------------------------
139+
140+-- Note that this file is generated by tools/GenBuiltinTypes.hs, and should
141+-- not be edited directly
142+
143+module Database.PostgreSQL.Simple.BuiltinTypes
144+ ( BuiltinType (..)
145+ , builtin2oid
146+ , oid2builtin
147+ , builtin2typname
148+ , oid2typname
149+ ) where
150+
151+import Data.Typeable
152+import Data.ByteString (ByteString)
153+import qualified Database.PostgreSQL.LibPQ as PQ
154+
155+data BuiltinType
156+ = |] ++ mconcat (intersperse "\n | " (map (Blaze.fromByteString . snd) builtins)) ++ [longstring|
157+
158+ deriving (Eq, Ord, Enum, Bounded, Read, Show, Typeable)
159+
160+builtin2oid :: BuiltinType -> PQ.Oid
161+builtin2oid typ = PQ.Oid $ case typ of
162+|] ++ mconcat [mconcat [ " ", bs y, padCons y, " -> "
163+ , renderOid oidmap x, "\n" ]
164+ | (x,y) <- builtins ] ++ [longstring|
165+
166+oid2builtin :: PQ.Oid -> Maybe BuiltinType
167+oid2builtin (PQ.Oid x) = case x of
168+|] ++ mconcat [mconcat [ " ", renderOid' oidmap x, " -> Just ", bs y, "\n" ]
169+ | (x,y) <- builtins ] ++ [longstring|
170+ _ -> Nothing
171+
172+builtin2typname :: BuiltinType -> ByteString
173+builtin2typname typ = case typ of
174+|] ++ mconcat [mconcat [ " ", bs y, padCons y, " -> ", bs x, "\n"]
175+ | (x,y) <- builtins] ++ [longstring|
176+
177+oid2typname :: PQ.Oid -> Maybe ByteString
178+oid2typname (PQ.Oid x) = case x of
179+|] ++ mconcat [mconcat [ " ", renderOid' oidmap x, " -> Just ", bs x, "\n" ]
180+ | (x,y) <- builtins ]
181+ ++ " _ -> Nothing\n"
182+ ++ mconcat [mconcat [ "\n"
183+ , bs x, " :: ByteString\n"
184+ , bs x, " = \"", bs x, "\"\n"]
185+ | (x,_y) <- builtins ])
tools/GenTypeInfo.hsdeleted−381
@@ -1,381 +0,0 @@
1−------------------------------------------------------------------------------
2−-- |
3−-- Module: GenTypeInfo
4−-- Copyright: (c) 2011-2012 Leon P Smith
5−-- License: BSD3
6−-- Maintainer: Leon P Smith <leon@melding-monads.com>
7−-- Stability: experimental
8−--
9−-- Queries a PostgreSQL database for the Object IDs and other type
10−-- information associated with typenames, and generates a module with
11−-- data constants representing part of the pg_type table.
12−--
13−-- Note that only some of the built-in types have stable type OIDs, and
14−-- thus a TypeInfo module that contains user-defined types is liable to
15−-- not work across different database instances. For these types, it is
16−-- better for `FromField` to use the `typeinfo` operator that works for
17−-- any type, whether or not it is in this module.
18−--
19−-- `typeinfo` works because postgresql-simple will dynamically query
20−-- the pg_types table the first time it receives a type OID it doesn't
21−-- know about. It then constructs a TypeInfo record and stores it in
22−-- a per-connection cache for later use.
23−--
24−-- @
25−-- runghc -itools tools/GenTypeInfo.hs
26−-- @
27−------------------------------------------------------------------------------
28−
29−{-# LANGUAGE OverloadedStrings, QuasiQuotes, ViewPatterns, RecordWildCards #-}
30−
31−module GenBuiltinTypes where
32−
33−import Prelude hiding ((++), concat)
34−
35−import StringsQQ
36−import Control.Arrow((&&&))
37−import Control.Applicative
38−import Control.Exception(bracket)
39−import Database.PostgreSQL.Simple
40−import Database.PostgreSQL.Simple.FromRow
41−import Database.PostgreSQL.Simple.Ok
42−import Database.PostgreSQL.Simple.Types(Oid(..))
43−import Database.PostgreSQL.Simple.SqlQQ
44−import qualified Data.ByteString.Char8 as B8
45−import Data.ByteString(ByteString)
46−import qualified Data.ByteString.Lazy as L
47−import qualified Data.ByteString.Builder as Blaze
48−import Data.String
49−import Data.List ( sort, intersperse )
50−import qualified Data.Map as Map
51−
52−import Data.Monoid
53−
54−(++) :: Monoid a => a -> a -> a
55−(++) = mappend
56−infixr 5 ++
57−
58−concat :: Monoid a => [a] -> a
59−concat = mconcat
60−
61−data TypeInfo = TypeInfo
62− { typoid :: Oid
63− , typcategory :: Char
64− , typdelim :: Char
65− , typname :: ByteString
66− , typelem :: Oid
67− , rngsubtype :: Maybe Oid
68− }
69−
70−instance FromRow TypeInfo where
71− fromRow = TypeInfo <$> field <*> field <*> field <*> field <*> field <*> field
72−
73−type NameMap = Map.Map B8.ByteString TypeInfo
74−
75−type OidMap = Map.Map Oid TypeInfo
76−
77−type TypeName = (B8.ByteString, B8.ByteString)
78−
79−type TypeNames = [TypeName]
80−
81−-- Note that the following syntax is "pgName <whitespace> hsName", though
82−-- they default to the same thing if there is only one identifier
83−typeNames :: TypeNames
84−typeNames = [typenames|
85−bool
86−bytea
87−char
88−name
89−int8
90−int2
91−int4
92−regproc
93−text
94−oid
95−tid
96−xid
97−cid
98−xml
99−point
100−lseg
101−path
102−box
103−polygon
104−line
105−cidr
106−float4
107−float8
108−unknown
109−circle
110−money
111−macaddr
112−inet
113−bpchar
114−varchar
115−date
116−time
117−timestamp
118−timestamptz
119−interval
120−timetz
121−bit
122−varbit
123−numeric
124−refcursor
125−record
126−void
127−_record array_record
128−regprocedure
129−regoper
130−regoperator
131−regclass
132−regtype
133−uuid
134−json
135−jsonb
136−int2vector
137−oidvector
138−_xml array_xml
139−_json array_json
140−_line array_line
141−_cidr array_cidr
142−_circle array_circle
143−_money array_money
144−_bool array_bool
145−_bytea array_bytea
146−_char array_char
147−_name array_name
148−_int2 array_int2
149−_int2vector array_int2vector
150−_int4 array_int4
151−_regproc array_regproc
152−_text array_text
153−_tid array_tid
154−_xid array_xid
155−_cid array_cid
156−_oidvector array_oidvector
157−_bpchar array_bpchar
158−_varchar array_varchar
159−_int8 array_int8
160−_point array_point
161−_lseg array_lseg
162−_path array_path
163−_box array_box
164−_float4 array_float4
165−_float8 array_float8
166−_polygon array_polygon
167−_oid array_oid
168−_macaddr array_macaddr
169−_inet array_inet
170−_timestamp array_timestamp
171−_date array_date
172−_time array_time
173−_timestamptz array_timestamptz
174−_interval array_interval
175−_numeric array_numeric
176−_timetz array_timetz
177−_bit array_bit
178−_varbit array_varbit
179−_refcursor array_refcursor
180−_regprocedure array_regprocedure
181−_regoper array_regoper
182−_regoperator array_regoperator
183−_regclass array_regclass
184−_regtype array_regtype
185−_uuid array_uuid
186−_jsonb array_jsonb
187−int4range
188−_int4range
189−numrange
190−_numrange
191−tsrange
192−_tsrange
193−tstzrange
194−_tstzrange
195−daterange
196−_daterange
197−int8range
198−_int8range
199−|]
200−
201−connectionString = "dbname=postgres"
202−
203−withPostgreSQL = bracket (connectPostgreSQL connectionString) close
204−
205−getTypeInfos :: TypeNames -> IO (OidMap, NameMap)
206−getTypeInfos typnames = withPostgreSQL $ \conn -> do
207− infos <- query conn [sql|
208− WITH types AS
209− (SELECT oid, typcategory, typdelim, typname, typelem
210− FROM pg_type WHERE typname IN ?)
211− SELECT types.*, rngsubtype FROM types LEFT JOIN pg_range ON oid = rngtypid
212− |] (Only (In (sort (map pg typnames))))
213− loop conn (oidMap infos) (nameMap infos) infos
214− where
215− oidMap = Map.fromList . map (typoid &&& id)
216− nameMap = Map.fromList . map (typname &&& id)
217− loop conn oids names infos = do
218− let unknowns = [ x | x <- map typelem infos ++
219− [ x | Just x <- map rngsubtype infos ],
220− x /= Oid 0,
221− not (Map.member x oids) ]
222− case unknowns of
223− [] -> return (oids, names)
224− (_:_) -> do
225− infos' <- query conn [sql|
226− WITH types AS
227− (SELECT oid, typcategory, typdelim, typname, typelem
228− FROM pg_type WHERE oid IN ?)
229− SELECT types.*, rngsubtype
230− FROM types LEFT JOIN pg_range ON oid = rngtypid
231− |] (Only (In (sort unknowns)))
232− let oids' = oids `Map.union` oidMap infos'
233− names' = names `Map.union` nameMap infos'
234− loop conn oids' names' infos'
235−
236−main = do
237− (oidmap, namemap) <- getTypeInfos typeNames
238− L.writeFile "src/Database/PostgreSQL/Simple/TypeInfo/Static.hs"
239− (Blaze.toLazyByteString (renderFile oidmap namemap typeNames))
240−
241−
242−showOid (Oid n) = show n
243−
244−renderOid :: NameMap -> TypeName -> Blaze.Builder
245−renderOid byName name
246− = case Map.lookup (pg name) byName of
247− Nothing -> error (B8.unpack (pg name))
248− Just (showOid . typoid -> n) -> fromString n
249− ++ fromString (replicate (4 - length n) ' ')
250−
251−renderElem :: OidMap -> Oid -> Blaze.Builder
252−renderElem byOid elemOid
253− | elemOid == Oid 0 = "Nothing"
254− | otherwise = case Map.lookup elemOid byOid of
255− Nothing -> error ("oid not found: " ++ show elemOid)
256− Just x -> "Just " ++ bs (typname x)
257−
258−renderTypeInfo :: OidMap -> TypeInfo -> TypeName -> Blaze.Builder
259−renderTypeInfo byOid info name
260− | typcategory info == 'A' || typname info == "_record" =
261− let (Just typelem_info) = Map.lookup (typelem info) byOid
262− typelem_hs_name =
263− case lookup (typname typelem_info) typeNames of
264− Nothing -> error ( "type not found: "
265− ++ B8.unpack( typname typelem_info)
266− ++ " (typelem of " ++ B8.unpack (typname info)
267− ++ ")")
268− Just x -> x
269− in concat
270− [ "\n"
271− , bs (hs name), " :: TypeInfo\n"
272− , bs (hs name), " = Array {\n"
273− , " typoid = ", bs (hs name), "Oid,\n"
274− , " typcategory = '", bs $ B8.singleton (typcategory info), "',\n"
275− , " typdelim = '", bs $ B8.singleton (typdelim info), "',\n"
276− , " typname = \"", bs (typname info), "\",\n"
277− , " typelem = ", bs typelem_hs_name, "\n"
278− , " }\n"
279− , "\n"
280− , bs (hs name), "Oid :: Oid\n"
281− , bs (hs name), "Oid = ", fromString (show (typoid info)), "\n"
282− , "{-# INLINE ", bs (hs name), "Oid #-}"
283− , "\n"
284− ]
285− | typcategory info == 'R' =
286− let (Just rngsubtype_oid) = rngsubtype info
287− (Just rngsubtype_info) = Map.lookup rngsubtype_oid byOid
288− rngsubtype_hs_name =
289− case lookup (typname rngsubtype_info) typeNames of
290− Nothing -> error ( "type not found: "
291− ++ B8.unpack (typname rngsubtype_info)
292− ++ " (rngsubtype of "
293− ++ B8.unpack (typname info) ++ ")")
294− Just x -> x
295− in concat
296− [ "\n"
297− , bs (hs name), " :: TypeInfo\n"
298− , bs (hs name), " = Range {\n"
299− , " typoid = ", bs (hs name), "Oid,\n"
300− , " typcategory = '", bs $ B8.singleton (typcategory info), "',\n"
301− , " typdelim = '", bs $ B8.singleton (typdelim info), "',\n"
302− , " typname = \"", bs (typname info), "\",\n"
303− , " rngsubtype = ", bs rngsubtype_hs_name, "\n"
304− , " }\n"
305− , "\n"
306− , bs (hs name), "Oid :: Oid\n"
307− , bs (hs name), "Oid = ", fromString (show (typoid info)), "\n"
308− , "{-# INLINE ", bs (hs name), "Oid #-}"
309− , "\n"
310− ]
311− | otherwise =
312− concat
313− [ "\n"
314− , bs (hs name), " :: TypeInfo\n"
315− , bs (hs name), " = Basic {\n"
316− , " typoid = ", bs (hs name), "Oid,\n"
317− , " typcategory = '", bs $ B8.singleton (typcategory info), "',\n"
318− , " typdelim = '", bs $ B8.singleton (typdelim info), "',\n"
319− , " typname = \"", bs (typname info), "\"\n"
320− , " }\n"
321− , "\n"
322− , bs (hs name), "Oid :: Oid\n"
323− , bs (hs name), "Oid = ", fromString (show (typoid info)), "\n"
324− , "{-# INLINE ", bs (hs name), "Oid #-}"
325− , "\n"
326− ]
327−
328−-- FIXME: add in any names that we need that we didn't specify, (i.e.
329−-- the "unknowns" in getTypeInfos
330−-- and munge them into a valid haskell identifier if needed.
331−getNames :: NameMap -> TypeNames -> TypeNames
332−getNames _ x = x
333−
334−bs = Blaze.byteString
335−
336−pg = fst
337−
338−hs = snd
339−
340−renderFile :: OidMap -> NameMap -> TypeNames -> Blaze.Builder
341−renderFile byOid byName names = ([longstring|
342−------------------------------------------------------------------------------
343−-- |
344−-- Module: Database.PostgreSQL.Simple.TypeInfo
345−-- Copyright: (c) 2011-2012 Leon P Smith
346−-- License: BSD3
347−-- Maintainer: Leon P Smith <leon@melding-monads.com>
348−-- Stability: experimental
349−--
350−-- This module contains portions of the @pg_type@ table that are relevant
351−-- to postgresql-simple and are believed to not change between PostgreSQL
352−-- versions.
353−--
354−------------------------------------------------------------------------------
355−
356−-- Note that this file is generated by tools/GenTypeInfo.hs, and should
357−-- not be edited directly
358−
359−module Database.PostgreSQL.Simple.TypeInfo.Static
360− ( TypeInfo(..)
361− , staticTypeInfo
362−|] ++ concat [ " , " ++ bs (hs name) ++ "\n"
363− ++ " , " ++ bs (hs name) ++ "Oid\n"
364− | name <- names ] ++ [longstring|
365− ) where
366−
367−import Database.PostgreSQL.LibPQ (Oid(..))
368−import Database.PostgreSQL.Simple.TypeInfo.Types
369−
370−staticTypeInfo :: Oid -> Maybe TypeInfo
371−staticTypeInfo (Oid x) = case x of
372−|] ++ concat [concat [ " ", renderOid byName name,
373− " -> Just ", bs (hs name), "\n"
374− ]
375− | name <- names ]
376− ++ [longstring|
377− _ -> Nothing
378−|]
379− ++ concat [ renderTypeInfo byOid typeInfo name
380− | name <- getNames byName names
381− , let (Just typeInfo) = Map.lookup (pg name) byName])
tools/StringsQQ.hs+1−12
@@ -1,6 +1,6 @@
11{-# LANGUAGE TemplateHaskell #-}
22
3−module StringsQQ (strings, longstring, typenames) where
3+module StringsQQ (strings, longstring) where
44
55import Language.Haskell.TH
66import Language.Haskell.TH.Quote
@@ -28,14 +28,3 @@ longstring = QuasiQuoter { quotePat = undefined,
2828
2929longstringExp ('\n':xs) = stringE xs
3030longstringExp xs = stringE xs
31−
32−typenames = QuasiQuoter { quotePat = undefined,
33− quoteType = undefined,
34− quoteExp = typenamesExp,
35− quoteDec = undefined }
36−
37−typenamesExp :: String -> Q Exp
38−typenamesExp = foldr (\x xs -> [e| $(x) : $(xs) |]) [e| [] |]
39− . map delta . filter (not . null) . map words . lines
40− where delta [xs] = delta [xs,xs]
41− delta [xs,ys] = [e| ( $(stringE xs) , $(stringE ys) ) |]