git.iko.soy/typeable/postgresql-simple
on 477b790 help sign in
3ac2949
swap
0 ahead, 311 behind
.ghcinew file+16
since splitsnapshots
unifiedsplit
@@ -0,0 +1,16 @@
1+:set -isrc -itest -optP-includedist/build/autogen/cabal_macros.h
2+:set -Wall -fno-warn-name-shadowing
3+
4+:set -XDoAndIfThenElse
5+:set -XOverloadedStrings
6+:set -XBangPatterns
7+:set -XViewPatterns
8+:set -XTypeOperators
9+
10+-- for tests
11+:set -XNamedFieldPuns
12+:set -XRank2Types
13+:set -XRecordWildCards
14+:set -XPatternGuards
15+:set -XScopedTypeVariables
16+:set -fno-warn-unused-do-bind
.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−6
@@ -7,11 +7,5 @@ dist/
7*.o
7*.o
8\#*\#
8\#*\#
9.#*
9.#*
10−/CHANGELOG.md
11.cabal-sandbox/
10.cabal-sandbox/
12−.stack-work/
13cabal.sandbox.config
11cabal.sandbox.config
14−/dist-newstyle
15−.ghc.environment.*
16−cabal.project.local
17−dump-core
.travis.ymlnew file+7
@@ -0,0 +1,7 @@
1+language: haskell
2+
3+addons:
4+ postgresql: "9.3"
5+
6+before_install:
7+ - createdb `whoami`
CHANGES.md → CHANGESrenamed+52−367
@@ -1,325 +1,10 @@
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)
1+Version 0.4.8.0 (2014-11-24)
317 * Added support for postgresql's citext type extension via the
2 * Added support for postgresql's citext type extension via the
318 case-insensitive package.
3 case-insensitive package.
319
4
320 * Added the function parseHStoreList to the HStore module.
5 * Added the function parseHStoreList to the HStore module.
321
6
322−### Version 0.4.7.0 (2014-10-27)
7+Version 0.4.7.0 (2014-10-27)
323 * Added support for very old timestamps to UTCTime. Depending on time
8 * 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
9 zone, very old timestamps can be returned with a offset from UTC that
325 contains seconds.
10 contains seconds.
@@ -339,24 +24,24 @@
339
24
340 Thanks to Michael Snoyman for his assistance with this issue.
25 Thanks to Michael Snoyman for his assistance with this issue.
341
26
342−### Version 0.4.6.0 (2014-10-07)
27+Version 0.4.6.0 (2014-10-07)
343 * Added an instance ToField NominalDiffTime.
28 * Added an instance ToField NominalDiffTime.
344
29
345−### Version 0.4.5.0 (2014-09-26)
30+Version 0.4.5.0 (2014-09-26)
346 * Added support for retrieving NaN and ±Infinity floating point values
31 * Added support for retrieving NaN and ±Infinity floating point values
347 from postgres to the FromField instances for Float, Double, and Rational.
32 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
33 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
34 way of representing these special values. Thanks goes to Tom Nielsen
350 for reporting the issue.
35 for reporting the issue.
351
36
352−### Version 0.4.4.1 (2014-09-07)
37+Version 0.4.4.1 (2014-09-07)
353 * Fixed a rather serious bug that prevented the COPY module from working
38 * 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
39 at all on unix clients since version 0.4.3.0. Thanks goes to
355 Dmitry Dzhus for reporting the issue.
40 Dmitry Dzhus for reporting the issue.
356
41
357 * Added a regression test for the COPY module to the test suite.
42 * Added a regression test for the COPY module to the test suite.
358
43
359−### Version 0.4.4.0 (2014-08-26)
44+Version 0.4.4.0 (2014-08-26)
360 * Added the jsonb type debuting in PostgreSQL 9.4 to the TypeInfo.Static
45 * 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
46 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
47 be compatible with the new type. Thanks to Tobias Florek for the
@@ -365,7 +50,7 @@
365 * Ported some expanded documentation from mysql-simple, and fixed
50 * Ported some expanded documentation from mysql-simple, and fixed
366 a documentation typo.
51 a documentation typo.
367
52
368−### Version 0.4.3.0 (2014-07-10)
53+Version 0.4.3.0 (2014-07-10)
369 * connect and exec now use libpq asynchronously on non-Windows platforms.
54 * connect and exec now use libpq asynchronously on non-Windows platforms.
370 This means we are using threadWaitRead and threadWaitWrite to
55 This means we are using threadWaitRead and threadWaitWrite to
371 have GHC's IO manager schedule non-blocking C calls to libpq,
56 have GHC's IO manager schedule non-blocking C calls to libpq,
@@ -379,7 +64,7 @@
379 that originate from client-side code. However, this goal
64 that originate from client-side code. However, this goal
380 isn't perfectly achieved as of yet.
65 isn't perfectly achieved as of yet.
381
66
382−### Version 0.4.2.3 (2014-06-04)
67+Version 0.4.2.3 (2014-06-04)
383 * This is strictly a documentation release, with no code changes.
68 * This is strictly a documentation release, with no code changes.
384
69
385 * Fixed several documentation typos, thanks to Chris Allen and remdezx.
70 * Fixed several documentation typos, thanks to Chris Allen and remdezx.
@@ -390,13 +75,13 @@
390
75
391 * De-emphasized connect and ConnectInfo in favor of connectPostgreSQL.
76 * De-emphasized connect and ConnectInfo in favor of connectPostgreSQL.
392
77
393−### Version 0.4.2.2 (2014-05-15)
78+Version 0.4.2.2 (2014-05-15)
394− * Fixed compatibility with scientific-0.3.\*, thanks to Adam Bergmark
79+ * Fixed compatibility with scientific-0.3.*, thanks to Adam Bergmark
395
80
396 * Improved documentation of the FromField module, as well as the fold,
81 * Improved documentation of the FromField module, as well as the fold,
397 foldWithOptions, executeMany, and returning operators.
82 foldWithOptions, executeMany, and returning operators.
398
83
399−### Version 0.4.2.1 (2014-03-27)
84+Version 0.4.2.1 (2014-03-27)
400 * Fixed bug in Values syntax generation
85 * Fixed bug in Values syntax generation
401
86
402 * Improved documentation, including examples of multi-row update,
87 * Improved documentation, including examples of multi-row update,
@@ -404,17 +89,17 @@
404 floating point numbers from the database, and the IsString instance
89 floating point numbers from the database, and the IsString instance
405 for QualifiedIdentifier.
90 for QualifiedIdentifier.
406
91
407−### Version 0.4.2.0 (2014-03-22)
92+Version 0.4.2.0 (2014-03-22)
408 * Added ToField and FromField instances for the scientific package
93 * Added ToField and FromField instances for the scientific package
409
94
410 * Changed the Identifier and QualifiedIdentifier to use Text in
95 * Changed the Identifier and QualifiedIdentifier to use Text in
411 order to avoid encoding errors. Technically this requires a
96 order to avoid encoding errors. Technically this requires a
412− major version bump, but let's pretend 0.4.1.0 didn't happen.
97+ major verson bump, but let's pretend 0.4.1.0 didn't happen.
413
98
414 * Removed non-exhaustive cases in the ToField instance for Values,
99 * Removed non-exhaustive cases in the ToField instance for Values,
415 and tweaked error messages.
100 and tweaked error messages.
416
101
417−### Version 0.4.1.0 (2014-03-22)
102+Version 0.4.1.0 (2014-03-22)
418 * Fixed the parsing of arrays containing null values, courtesy of
103 * Fixed the parsing of arrays containing null values, courtesy of
419 Francesco Mazzoli
104 Francesco Mazzoli
420
105
@@ -426,17 +111,17 @@
426 more general than executeMany and returning. See the
111 more general than executeMany and returning. See the
427 Database.PostgreSQL.Simple.Types.Values data type.
112 Database.PostgreSQL.Simple.Types.Values data type.
428
113
429−### Version 0.4.0.2 (2014-01-12)
114+Version 0.4.0.2 (2014-01-12)
430 * Tweaked C preprocessor directive to be more portable
115 * Tweaked C preprocessor directive to be more portable
431
116
432 * Tweaked testsuite for compatibility with aeson-0.7
117 * Tweaked testsuite for compatibility with aeson-0.7
433
118
434−### Version 0.4.0.1 (2013-12-21)
119+Version 0.4.0.1 (2013-12-21)
435 * Relaxed dependency on aeson to >= 0.6
120 * Relaxed dependency on aeson to >= 0.6
436
121
437 * Update the documentation of `fromField`
122 * Update the documentation of `fromField`
438
123
439−### Version 0.4.0.0 (2013-12-21)
124+Version 0.4.0.0 (2013-12-21)
440 * Changed the calling code of `fromField` so that it always sends
125 * 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
126 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
127 performance bump for most people most of the time; however it
@@ -452,15 +137,15 @@
452
137
453 * Added FromField instances for IORef, MVar, and IOVector.
138 * Added FromField instances for IORef, MVar, and IOVector.
454
139
455−### Version 0.3.10.0 (2013-12-17)
140+Version 0.3.10.0 (2013-12-17)
456 * Added the queryWith function, courtesy of Leonid Onokhov
141 * Added the queryWith function, courtesy of Leonid Onokhov
457
142
458 * Added the Default type, for representing postgresql's default values
143 * Added the Default type, for representing postgresql's default values
459
144
460−### Version 0.3.9.1 (2013-10-28)
145+Version 0.3.9.1 (2013-10-28)
461 * Removed dependency on hashable
146 * Removed dependency on hashable
462
147
463−### Version 0.3.9.0 (2013-10-27)
148+Version 0.3.9.0 (2013-10-27)
464 * Added FromField and ToField instances for the `uuid` package,
149 * Added FromField and ToField instances for the `uuid` package,
465 courtesy of Bas van Dijk.
150 courtesy of Bas van Dijk.
466
151
@@ -470,16 +155,16 @@
470 * Added the fromBinary, fromHStoreMap, and fromHStoreList newtype
155 * Added the fromBinary, fromHStoreMap, and fromHStoreList newtype
471 unwrapper functions, courtesy of Bas van Dijk.
156 unwrapper functions, courtesy of Bas van Dijk.
472
157
473−### Version 0.3.8.0 (2013-10-11)
158+Version 0.3.8.0 (2013-10-11)
474 * Fixed the example code in `FromField`, thanks to Adam Bergmark.
159 * Fixed the example code in `FromField`, thanks to Adam Bergmark.
475
160
476 * Added `Notification.getBackendPID`.
161 * Added `Notification.getBackendPID`.
477
162
478−### Version 0.3.7.1 (2013-09-12)
163+Version 0.3.7.1 (2013-09-12)
479 * Relaxed the dependency on bytestring-0.10 back to bytestring-0.9,
164 * Relaxed the dependency on bytestring-0.10 back to bytestring-0.9,
480 courtesy of Michael Snoyman
165 courtesy of Michael Snoyman
481
166
482−### Version 0.3.7.0 (2013-09-11)
167+Version 0.3.7.0 (2013-09-11)
483 * Added `aeson` as a dependency.
168 * Added `aeson` as a dependency.
484
169
485 * Added ToField and FromField instances for aeson's JSON.Value type,
170 * Added ToField and FromField instances for aeson's JSON.Value type,
@@ -500,7 +185,7 @@
500
185
501 * Various documentation fixes.
186 * Various documentation fixes.
502
187
503−### Version 0.3.6.0 (2013-08-19)
188+Version 0.3.6.0 (2013-08-19)
504 * Added the json type to BuiltinTypes and TypeInfo.Static, courtesy of
189 * Added the json type to BuiltinTypes and TypeInfo.Static, courtesy of
505 Manuel Gómez.
190 Manuel Gómez.
506
191
@@ -511,14 +196,14 @@
511 months from now. Fixed the example code in FromField to reflect
196 months from now. Fixed the example code in FromField to reflect
512 this change.
197 this change.
513
198
514−### Version 0.3.5.0 (2013-08-09)
199+Version 0.3.5.0 (2013-08-09)
515 * Added an FromRow instance for Vector, semantically identical to the
200 * Added an FromRow instance for Vector, semantically identical to the
516 existing FromRow instance for [], courtesy of Doug Beardsley
201 existing FromRow instance for [], courtesy of Doug Beardsley
517
202
518 * Reworked the documentation for the Copy module, and tweaked the
203 * Reworked the documentation for the Copy module, and tweaked the
519 documentation for the LargeObjects module.
204 documentation for the LargeObjects module.
520
205
521−### Version 0.3.4.0 (2013-07-23)
206+Version 0.3.4.0 (2013-07-23)
522 * Added direct support for COPY IN and COPY OUT, without having
207 * Added direct support for COPY IN and COPY OUT, without having
523 to use raw postgresql-libpq calls and postgresql-simple's Internal
208 to use raw postgresql-libpq calls and postgresql-simple's Internal
524 module.
209 module.
@@ -527,49 +212,49 @@
527 exception instead of an ErrorCall exception when it fails to fetch
212 exception instead of an ErrorCall exception when it fails to fetch
528 the connection's file descriptor from libpq.
213 the connection's file descriptor from libpq.
529
214
530−### Version 0.3.3.2 (2013-06-18)
215+Version 0.3.3.2 (2013-06-18)
531 * Optimized the definition of `mconcat` in the Monoid instance for
216 * Optimized the definition of `mconcat` in the Monoid instance for
532 the Query type, courtesy of Joey Adams.
217 the Query type, courtesy of Joey Adams.
533
218
534−### Version 0.3.3.1 (2013-06-06)
219+Version 0.3.3.1 (2013-06-06)
535 * `getNotification` now works on Windows, albeit using a one-second
220 * `getNotification` now works on Windows, albeit using a one-second
536 polling loop, courtesy of Joey Adams.
221 polling loop, courtesy of Joey Adams.
537
222
538−### Version 0.3.3.0 (2013-05-29)
223+Version 0.3.3.0 (2013-05-29)
539 * Fixed two issues with the fold operator: fold would raise the wrong
224 * Fixed two issues with the fold operator: fold would raise the wrong
540 exception, and gave the database cursor a static name preventing
225 exception, and gave the database cursor a static name preventing
541 folds from being nested. Thanks to Joey Adams for his
226 folds from being nested. Thanks to Joey Adams for his
542 work on these issues.
227 work on these issues.
543
228
544−### Version 0.3.2.0 (2013-05-20)
229+Version 0.3.2.0 (2013-05-20)
545 * Added a savepoint abstraction to the Transaction module, courtesy
230 * Added a savepoint abstraction to the Transaction module, courtesy
546 of Joey Adams
231 of Joey Adams
547
232
548−### Version 0.3.1.2 (2013-04-29)
233+Version 0.3.1.2 (2013-04-29)
549 * Fixed hstore parser to not unnecessarily reverse the key-value pairs
234 * Fixed hstore parser to not unnecessarily reverse the key-value pairs
550
235
551−### Version 0.3.1.1 (2013-04-29)
236+Version 0.3.1.1 (2013-04-29)
552 * Fixed hstore parser to recognize empty hstores, courtesy of Simon
237 * Fixed hstore parser to recognize empty hstores, courtesy of Simon
553 Meier
238 Meier
554
239
555−### Version 0.3.1.0 (2013-04-26)
240+Version 0.3.1.0 (2013-04-26)
556 * Added support for Range and Composite types to the TypeInfo system.
241 * Added support for Range and Composite types to the TypeInfo system.
557
242
558 * Added support for hstore types in the Simple.HStore module.
243 * Added support for hstore types in the Simple.HStore module.
559
244
560 * Improved documentation of the FromField module.
245 * Improved documentation of the FromField module.
561
246
562−### Version 0.3.0.1 (2013-03-26)
247+Version 0.3.0.1 (2013-03-26)
563 * A large chunk of the documentation inside the FromField module had
248 * A large chunk of the documentation inside the FromField module had
564 silently failed to render in Haddock.
249 silently failed to render in Haddock.
565
250
566−### Version 0.3.0.0 (2013-03-25)
251+Version 0.3.0.0 (2013-03-25)
567 * Added support for PostgreSQL's Array Types. Thanks to Jason Dusek
252 * Added support for PostgreSQL's Array Types. Thanks to Jason Dusek
568 for his work on this feature.
253 for his work on this feature.
569
254
570 * Added a brand new TypeInfo system that gives FromField instances
255 * Added a brand new TypeInfo system that gives FromField instances
571 convenient and efficient access to the pg_type metatable. This
256 convenient and efficient access to the pg_type metatable. This
572− replaced the older typename cache, and was necessary to properly
257+ replaced the older typename cache, and was neccesary to properly
573 support postgres array types. Thanks to Bas van Dijk for his
258 support postgres array types. Thanks to Bas van Dijk for his
574 work on this feature.
259 work on this feature.
575
260
@@ -605,33 +290,33 @@
605 now stripped out.
290 now stripped out.
606
291
607
292
608−### Version 0.2.4.1 (2012-08-29)
293+Version 0.2.4.1 (2012-08-29)
609 * Fixed the documentation of `In`. Thanks to rekado and dstcruz for
294 * Fixed the documentation of `In`. Thanks to rekado and dstcruz for
610 pointing this out.
295 pointing this out.
611
296
612−### Version 0.2.4.0 (2012-08-23)
297+Version 0.2.4.0 (2012-08-23)
613 * Added the `withTransactionSerializable` and `withTransactionModeRetry`
298 * Added the `withTransactionSerializable` and `withTransactionModeRetry`
614 operators, thanks to Joey Adams.
299 operators, thanks to Joey Adams.
615
300
616−### Version 0.2.3.0 (2012-08-09)
301+Version 0.2.3.0 (2012-08-09)
617 * Added the `returning` operator, thanks to Jason Dusek
302 * Added the `returning` operator, thanks to Jason Dusek
618
303
619−### Version 0.2.2.0 (2012-07-26)
304+Version 0.2.2.0 (2012-07-26)
620 * Added a ToRow instance for the (:.) type, courtesy of Leonid Onokhov
305 * Added a ToRow instance for the (:.) type, courtesy of Leonid Onokhov
621
306
622 * Added the type oid for PostgreSQL's `uuid` type to BuiltinTypes
307 * Added the type oid for PostgreSQL's `uuid` type to BuiltinTypes
623
308
624−### Version 0.2.1.0 (2012-07-23)
309+Version 0.2.1.0 (2012-07-23)
625 * Added the FromRow.fieldWith operator, thanks to Leonid Onokhov
310 * Added the FromRow.fieldWith operator, thanks to Leonid Onokhov
626
311
627 * Added a type synonym for FieldParser
312 * Added a type synonym for FieldParser
628
313
629−### Version 0.2.0.1 (2012-06-21)
314+Version 0.2.0.1 (2012-06-21)
630 * Fixed a compatibility problem with PostgreSQL 8.1, which does not allow
315 * Fixed a compatibility problem with PostgreSQL 8.1, which does not allow
631 clients to set their own value for `standard_conforming_strings`. This
316 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.
317 connection variable is still set to `on` for PostgreSQL 8.2 and later.
633
318
634−### Version 0.2: (2012-06-19)
319+Version 0.2: (2012-06-19)
635 * Removed the conversion from `timestamp` to `UTCTime`. Some code will be
320 * Removed the conversion from `timestamp` to `UTCTime`. Some code will be
636 broken even though it will still compile.
321 broken even though it will still compile.
637
322
@@ -640,16 +325,16 @@
640 * Exported ToRow/FromRow from Database.PostgreSQL.Simple
325 * Exported ToRow/FromRow from Database.PostgreSQL.Simple
641
326
642
327
643−### Version 0.1.4.3: (2012-06-10)
328+Version 0.1.4.3: (2012-06-10)
644 * Fix language extensions for compatibility with GHC 7.0
329 * Fix language extensions for compatibility with GHC 7.0
645
330
646−### Version 0.1.4.2: (2012-06-10)
331+Version 0.1.4.2: (2012-06-10)
647 * Fix a wayward dependency on Text.
332 * Fix a wayward dependency on Text.
648
333
649−### Version 0.1.4.1: (2012-06-10)
334+Version 0.1.4.1: (2012-06-10)
650 * Added support for timezones with minutes in their UTC offset.
335 * Added support for timezones with minutes in their UTC offset.
651
336
652−### Version 0.1.4: (2012-06-10)
337+Version 0.1.4: (2012-06-10)
653 * Removed pcre-light dependency, courtesy of Joey Adams.
338 * Removed pcre-light dependency, courtesy of Joey Adams.
654
339
655 * Reworked support for the Time types.
340 * Reworked support for the Time types.
@@ -661,7 +346,7 @@
661 now the preferred way of dealing with `timestamp` (without time zone).
346 now the preferred way of dealing with `timestamp` (without time zone).
662
347
663 * `Database.PostgreSQL.Simple.Time` is a new module that offers types
348 * `Database.PostgreSQL.Simple.Time` is a new module that offers types
664− that accommodate PostgreSQL's infinities.
349+ that accomodate PostgreSQL's infinities.
665
350
666 * All time-related `FromField`/`ToField` instances are now based on new,
351 * All time-related `FromField`/`ToField` instances are now based on new,
667 higher-speed parsers and printers instead of those provided by the
352 higher-speed parsers and printers instead of those provided by the
@@ -674,13 +359,13 @@
674 * Renaming some of the type names in `BuiltinTypes`.
359 * Renaming some of the type names in `BuiltinTypes`.
675
360
676
361
677−### Version 0.1.3: (2012-05-30)
362+Version 0.1.3: (2012-05-30)
678 * Made ZonedTime an instance of FromField and ToField
363 * Made ZonedTime an instance of FromField and ToField
679
364
680 * Added getNotificationNonBlocking
365 * Added getNotificationNonBlocking
681
366
682
367
683−### Version 0.1.2: (2012-05-09)
368+Version 0.1.2: (2012-05-09)
684 * Switched to libpq-based escaping for bytea types; Binary now works with
369 * Switched to libpq-based escaping for bytea types; Binary now works with
685 PostgreSQL 8 courtesy of Joey Adams.
370 PostgreSQL 8 courtesy of Joey Adams.
686
371
@@ -693,7 +378,7 @@
693 * Exported (:.) from Database.PostgreSQL.Simple
378 * Exported (:.) from Database.PostgreSQL.Simple
694
379
695
380
696−### Version 0.1.1: (2012-05-06)
381+Version 0.1.1: (2012-05-06)
697 * Added some preliminary documentation for the Ok, Notification, and
382 * Added some preliminary documentation for the Ok, Notification, and
698 LargeObjects modules
383 LargeObjects modules
699
384
@@ -702,7 +387,7 @@
702 * Fixed a bug relating to handling the transaction level
387 * Fixed a bug relating to handling the transaction level
703
388
704
389
705−### Version 0.1: (2012-05-04)
390+Version 0.1: (2012-05-04)
706 * Renamed several modules, typeclasses, and functions:
391 * Renamed several modules, typeclasses, and functions:
707
392
708 QueryParams (renderParams) -> ToRow (toRow)
393 QueryParams (renderParams) -> ToRow (toRow)
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.
CONTRIBUTORS−16
@@ -18,19 +18,3 @@ Adam Bergmark <adam@edea.se>
18Tobias Florek <tob@butter.sh>
18Tobias Florek <tob@butter.sh>
19Francesco Mazzoli <francesco.mazzoli@erudify.com>
19Francesco Mazzoli <francesco.mazzoli@erudify.com>
20Chris Allen <cma@bitemyapp.com>
20Chris 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+95−153
@@ -1,175 +1,117 @@
1−cabal-version: 1.12
2−name: postgresql-simple
1+Name: postgresql-simple
3−version: 0.7.0.0
2+Version: 0.4.8.0
4−x-revision: 1
5−synopsis: Mid-Level PostgreSQL client library
3+Synopsis: Mid-Level PostgreSQL client library
6−description:
4+Description:
7− Mid-Level PostgreSQL client library, forked from mysql-simple.
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-2013 Leon P Smith
12+Category: Database
13+Build-type: Simple
8
14
9−license: BSD3
15+Cabal-version: >= 1.9.2
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
16
18−category: Database
19−build-type: Simple
20extra-source-files:
17extra-source-files:
21− CHANGES.md
22− CONTRIBUTORS
18+ CONTRIBUTORS
23− test/results/malformed-input.expected
24− test/results/unique-constraint-violation.expected
25
19
26−tested-with:
20+Library
27− GHC ==8.6.5
21+ hs-source-dirs: src
28− || ==8.8.4
22+ Exposed-modules:
29− || ==8.10.7
23+ Database.PostgreSQL.Simple
30− || ==9.0.2
24+ Database.PostgreSQL.Simple.Arrays
31− || ==9.2.8
25+ Database.PostgreSQL.Simple.BuiltinTypes
32− || ==9.4.8
26+ Database.PostgreSQL.Simple.Copy
33− || ==9.6.3
27+ Database.PostgreSQL.Simple.FromField
34− || ==9.8.1
28+ Database.PostgreSQL.Simple.FromRow
29+ Database.PostgreSQL.Simple.LargeObjects
30+ Database.PostgreSQL.Simple.HStore
31+ Database.PostgreSQL.Simple.HStore.Internal
32+ Database.PostgreSQL.Simple.Notification
33+ Database.PostgreSQL.Simple.Ok
34+ Database.PostgreSQL.Simple.SqlQQ
35+ Database.PostgreSQL.Simple.Time
36+ Database.PostgreSQL.Simple.Time.Internal
37+ Database.PostgreSQL.Simple.ToField
38+ Database.PostgreSQL.Simple.ToRow
39+ Database.PostgreSQL.Simple.Transaction
40+ Database.PostgreSQL.Simple.TypeInfo
41+ Database.PostgreSQL.Simple.TypeInfo.Macro
42+ Database.PostgreSQL.Simple.TypeInfo.Static
43+ Database.PostgreSQL.Simple.Types
44+ Database.PostgreSQL.Simple.Errors
45+-- Other-modules:
46+ Database.PostgreSQL.Simple.Internal
35
47
36−library
37− default-language: Haskell2010
38− hs-source-dirs: src
39− exposed-modules:
48+ Other-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
49+ Database.PostgreSQL.Simple.Compat
46− Database.PostgreSQL.Simple.FromRow
47− Database.PostgreSQL.Simple.HStore
48− Database.PostgreSQL.Simple.HStore.Internal
50+ Database.PostgreSQL.Simple.HStore.Implementation
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
51+ Database.PostgreSQL.Simple.Time.Implementation
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
52+ Database.PostgreSQL.Simple.TypeInfo.Types
63− Database.PostgreSQL.Simple.TypeInfo.Static
64− Database.PostgreSQL.Simple.Types
65− Database.PostgreSQL.Simple.Vector
66− Database.PostgreSQL.Simple.Vector.Unboxed
67
53
68− -- Other-modules:
54+ Build-depends:
69− other-modules:
55+ aeson >= 0.6,
70− Database.PostgreSQL.Simple.Compat
56+ attoparsec >= 0.10.3,
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
57+ base < 5,
58+ blaze-builder,
59+ blaze-textual,
81− , bytestring >=0.10.8.2 && <0.13
60+ bytestring >= 0.9,
61+ case-insensitive,
82− , containers >=0.6.0.1 && <0.7
62+ containers,
63+ hashable,
64+ postgresql-libpq >= 0.9,
83− , template-haskell >=2.14.0.0 && <2.22
65+ template-haskell,
84− , text >=1.2.3.0 && <1.3 || >=2.0 && <2.2
66+ text >= 0.11.1,
85− , time-compat >=1.9.5 && <1.12
67+ time,
86− , transformers >=0.5.6.2 && <0.7
68+ transformers,
87−
69+ uuid >= 1.3.1,
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
70+ scientific,
97− , uuid-types >=1.0.5 && <1.1
98− , vector >=0.13.0.0 && <0.14
71+ vector
99
72
100− default-extensions:
101− BangPatterns
102− DoAndIfThenElse
103− OverloadedStrings
73+ extensions: DoAndIfThenElse, OverloadedStrings, BangPatterns, ViewPatterns
104− TypeOperators
74+ TypeOperators
105− ViewPatterns
106
75
107− ghc-options: -Wall -fno-warn-name-shadowing
76+ ghc-options: -Wall -fno-warn-name-shadowing
108
77
109source-repository head
78source-repository head
110 type: git
79 type: git
111− location: http://github.com/haskellari/postgresql-simple
80+ location: http://github.com/lpsmith/postgresql-simple
112
81
113−test-suite inspection
82+source-repository this
114− default-language: Haskell2010
83+ type: git
115− type: exitcode-stdio-1.0
84+ location: http://github.com/lpsmith/postgresql-simple
116− hs-source-dirs: test
85+ tag: v0.4.8.0
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
86
126test-suite test
87test-suite test
127− default-language: Haskell2010
128− type: exitcode-stdio-1.0
88+ type: exitcode-stdio-1.0
89+
129− hs-source-dirs: test
90+ hs-source-dirs: test
130− main-is: Main.hs
91+ main-is: Main.hs
131 other-modules:
92 other-modules:
132 Common
93 Common
133− Exception
134− Interval
135 Notify
94 Notify
136 Serializable
95 Serializable
137 Time
96 Time
138
97
139− ghc-options: -threaded
140− ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind
98+ 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
99
149− build-depends:
100+ extensions: NamedFieldPuns
150− aeson
101+ , OverloadedStrings
151− , base
102+ , Rank2Types
152− , base16-bytestring
103+ , RecordWildCards
153− , bytestring
104+ , PatternGuards
154− , case-insensitive
105+ , ScopedTypeVariables
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
106
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:
107+ build-depends: base
173− base
108+ , aeson
109+ , base16-bytestring
110+ , bytestring
111+ , containers
112+ , cryptohash
113+ , HUnit
174− , postgresql-simple
114+ , postgresql-simple
115+ , text
116+ , time
175− , vector
117+ , vector
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+174−135
@@ -42,7 +42,7 @@ module Database.PostgreSQL.Simple
42 -- ** Modifying multiple rows at once
42 -- ** Modifying multiple rows at once
43 -- $many
43 -- $many
44
44
45− -- ** @RETURNING@: modifications that return results
45+ -- ** @RETURNING@: modifications that returns results
46 -- $returning
46 -- $returning
47
47
48 -- * Extracting results
48 -- * Extracting results
@@ -64,17 +64,15 @@ module Database.PostgreSQL.Simple
64 , Only(..)
64 , Only(..)
65 , (:.)(..)
65 , (:.)(..)
66 -- ** Exceptions
66 -- ** Exceptions
67− , SomePostgreSqlException(..)
68 , SqlError(..)
67 , SqlError(..)
69 , PQ.ExecStatus(..)
68 , PQ.ExecStatus(..)
70− , FormatError(..)
69+ , FormatError(fmtMessage, fmtQuery, fmtParams)
71− , QueryError(..)
70+ , QueryError(qeMessage, qeQuery)
72− , ResultError(..)
71+ , ResultError(errSQLType, errHaskellType, errMessage)
73 -- * Connection management
72 -- * Connection management
74 , Base.connectPostgreSQL
73 , Base.connectPostgreSQL
75 , Base.close
74 , Base.close
76 , Base.connect
75 , Base.connect
77− , Base.withConnect
78 , Base.ConnectInfo(..)
76 , Base.ConnectInfo(..)
79 , Base.defaultConnectInfo
77 , Base.defaultConnectInfo
80 , Base.postgreSQLConnectionString
78 , Base.postgreSQLConnectionString
@@ -95,14 +93,6 @@ module Database.PostgreSQL.Simple
95 , forEach
93 , forEach
96 , forEach_
94 , forEach_
97 , returning
95 , 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
106 -- * Statements that do not return results
96 -- * Statements that do not return results
107 , execute
97 , execute
108 , execute_
98 , execute_
@@ -120,27 +110,46 @@ module Database.PostgreSQL.Simple
120 , formatQuery
110 , formatQuery
121 ) where
111 ) where
122
112
123−import Data.ByteString.Builder (Builder, byteString, char8)
113+import Blaze.ByteString.Builder
114+ ( Builder, fromByteString, toByteString )
115+import Blaze.ByteString.Builder.Char8 (fromChar)
116+import Blaze.Text ( integral )
124−import Control.Applicative ((<$>))
117+import Control.Applicative ((<$>), pure)
125import Control.Exception as E
118import Control.Exception as E
119+import Control.Monad (foldM)
126import Data.ByteString (ByteString)
120import Data.ByteString (ByteString)
127import Data.Int (Int64)
121import Data.Int (Int64)
128import Data.List (intersperse)
122import Data.List (intersperse)
129import Data.Monoid (mconcat)
123import Data.Monoid (mconcat)
124+import Data.Typeable (Typeable)
130−import Database.PostgreSQL.Simple.Compat ((<>), toByteString)
125+import Database.PostgreSQL.Simple.Compat ( (<>) )
131−import Database.PostgreSQL.Simple.Cursor
132import Database.PostgreSQL.Simple.FromField (ResultError(..))
126import Database.PostgreSQL.Simple.FromField (ResultError(..))
133import Database.PostgreSQL.Simple.FromRow (FromRow(..))
127import Database.PostgreSQL.Simple.FromRow (FromRow(..))
134−import Database.PostgreSQL.Simple.ToField (Action(..))
128+import Database.PostgreSQL.Simple.Ok
129+import Database.PostgreSQL.Simple.ToField (Action(..), inQuotes)
135import Database.PostgreSQL.Simple.ToRow (ToRow(..))
130import Database.PostgreSQL.Simple.ToRow (ToRow(..))
136import Database.PostgreSQL.Simple.Types
131import Database.PostgreSQL.Simple.Types
137 ( Binary(..), In(..), Only(..), Query(..), (:.)(..) )
132 ( Binary(..), In(..), Only(..), Query(..), (:.)(..) )
138import Database.PostgreSQL.Simple.Internal as Base
133import Database.PostgreSQL.Simple.Internal as Base
139−import Database.PostgreSQL.Simple.Internal.PQResultUtils
140import Database.PostgreSQL.Simple.Transaction
134import Database.PostgreSQL.Simple.Transaction
135+import Database.PostgreSQL.Simple.TypeInfo
141import qualified Database.PostgreSQL.LibPQ as PQ
136import qualified Database.PostgreSQL.LibPQ as PQ
142import qualified Data.ByteString.Char8 as B
137import qualified Data.ByteString.Char8 as B
143−
138+import qualified Data.Text as T
139+import qualified Data.Text.Encoding as TE
140+import Control.Monad.Trans.Reader
141+import Control.Monad.Trans.State.Strict
142+
143+-- | Exception thrown if a 'Query' could not be formatted correctly.
144+-- This may occur if the number of \'@?@\' characters in the query
145+-- string does not match the number of parameters provided.
146+data FormatError = FormatError {
147+ fmtMessage :: String
148+ , fmtQuery :: Query
149+ , fmtParams :: [ByteString]
150+ } deriving (Eq, Show, Typeable)
151+
152+instance Exception FormatError
144
153
145-- | Format a query string.
154-- | Format a query string.
146--
155--
@@ -177,9 +186,9 @@ formatMany conn q@(Query template) qs = do
177 case parseTemplate template of
186 case parseTemplate template of
178 Just (before, qbits, after) -> do
187 Just (before, qbits, after) -> do
179 bs <- mapM (buildQuery conn q qbits . toRow) qs
188 bs <- mapM (buildQuery conn q qbits . toRow) qs
180− return . toByteString . mconcat $ byteString before :
189+ return . toByteString . mconcat $ fromByteString before :
181− intersperse (char8 ',') bs ++
190+ intersperse (fromChar ',') bs ++
182− [byteString after]
191+ [fromByteString after]
183 Nothing -> fmtError "syntax error in multi-row template" q []
192 Nothing -> fmtError "syntax error in multi-row template" q []
184
193
185-- Split the input string into three pieces, @before@, @qbits@, and @after@,
194-- Split the input string into three pieces, @before@, @qbits@, and @after@,
@@ -277,32 +286,45 @@ parseTemplate template =
277
286
278 skipSpace = B.dropWhile isSpace_ascii
287 skipSpace = B.dropWhile isSpace_ascii
279
288
289+escapeStringConn :: Connection -> ByteString -> IO (Either ByteString ByteString)
290+escapeStringConn = escapeWrap PQ.escapeStringConn
291+
292+escapeIdentifier :: Connection -> ByteString -> IO (Either ByteString ByteString)
293+escapeIdentifier = escapeWrap PQ.escapeIdentifier
294+
295+escapeByteaConn :: Connection -> ByteString -> IO (Either ByteString ByteString)
296+escapeByteaConn = escapeWrap PQ.escapeByteaConn
297+
298+escapeWrap :: (PQ.Connection -> ByteString -> IO (Maybe ByteString))
299+ -> Connection
300+ -> ByteString
301+ -> IO (Either ByteString ByteString)
302+escapeWrap f conn s =
303+ withConnection conn $ \c ->
304+ f c s >>= checkError c
305+
306+checkError :: PQ.Connection -> Maybe a -> IO (Either ByteString a)
307+checkError _ (Just x) = return $ Right x
308+checkError c Nothing = Left . maybe "" id <$> PQ.errorMessage c
280
309
281buildQuery :: Connection -> Query -> ByteString -> [Action] -> IO Builder
310buildQuery :: Connection -> Query -> ByteString -> [Action] -> IO Builder
282−buildQuery conn q template xs =
311+buildQuery conn q template xs = zipParams (split template) <$> mapM sub xs
283− zipParams (split template) <$> mapM (buildAction conn q xs) xs
312+ where err' msg = fmtError (utf8ToString msg) q xs
284− where split s =
313+ quote = either err' (inQuotes . fromByteString)
285− -- This part escapes double '??'s to make literal '?'s possible
314+ utf8ToString = T.unpack . TE.decodeUtf8
286− -- in PostgreSQL queries using the JSON operators: @?@, @?|@ and @?&@
315+ sub (Plain b) = pure b
287− let (h,t) = breakOnSingleQuestionMark s
316+ sub (Escape s) = quote <$> escapeStringConn conn s
288− in byteString h
317+ sub (EscapeByteA s) = quote <$> escapeByteaConn conn s
289− : if B.null t
318+ sub (EscapeIdentifier s) = either err' fromByteString <$>
290− then []
319+ escapeIdentifier conn s
320+ sub (Many ys) = mconcat <$> mapM sub ys
291− else split (B.tail t)
321+ split s = fromByteString h : if B.null t then [] else split (B.tail t)
322+ where (h,t) = B.break (=='?') s
292 zipParams (t:ts) (p:ps) = t <> p <> zipParams ts ps
323 zipParams (t:ts) (p:ps) = t <> p <> zipParams ts ps
293 zipParams [t] [] = t
324 zipParams [t] [] = t
294− zipParams _ _ = fmtError (show countSingleQs ++
325+ zipParams _ _ = fmtError (show (B.count '?' template) ++
295− " single '?' characters, but " ++
326+ " '?' characters, but " ++
296 show (length xs) ++ " parameters") q xs
327 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
306
328
307-- | Execute an @INSERT@, @UPDATE@, or other SQL query that is not
329-- | Execute an @INSERT@, @UPDATE@, or other SQL query that is not
308-- expected to return results.
330-- expected to return results.
@@ -340,10 +362,10 @@ execute conn template qs = do
340-- @
362-- @
341-- executeMany c [sql|
363-- executeMany c [sql|
342-- UPDATE sometable
364-- UPDATE sometable
343−-- SET y = upd.y
365+-- SET sometable.y = upd.y
344-- FROM (VALUES (?,?)) as upd(x,y)
366-- FROM (VALUES (?,?)) as upd(x,y)
345-- WHERE sometable.x = upd.x
367-- WHERE sometable.x = upd.x
346−-- |] [(1, \"hello\"),(2, \"world\")]
368+-- |] [(1, \"hello\"),(2, \"world\")
347-- @
369-- @
348
370
349executeMany :: (ToRow q) => Connection -> Query -> [q] -> IO Int64
371executeMany :: (ToRow q) => Connection -> Query -> [q] -> IO Int64
@@ -365,14 +387,10 @@ executeMany conn q qs = do
365--
387--
366-- Throws 'FormatError' if the query could not be formatted correctly.
388-- Throws 'FormatError' if the query could not be formatted correctly.
367returning :: (ToRow q, FromRow r) => Connection -> Query -> [q] -> IO [r]
389returning :: (ToRow q, FromRow r) => Connection -> Query -> [q] -> IO [r]
368−returning = returningWith fromRow
369−
370−-- | A version of 'returning' taking parser as argument
371−returningWith :: (ToRow q) => RowParser r -> Connection -> Query -> [q] -> IO [r]
372−returningWith _ _ _ [] = return []
390+returning _ _ [] = return []
373−returningWith parser conn q qs = do
391+returning conn q qs = do
374 result <- exec conn =<< formatMany conn q qs
392 result <- exec conn =<< formatMany conn q qs
375− finishQueryWith parser conn q result
393+ finishQuery conn q result
376
394
377-- | Perform a @SELECT@ or other SQL query that is expected to return
395-- | Perform a @SELECT@ or other SQL query that is expected to return
378-- results. All results are retrieved and converted before this
396-- results. All results are retrieved and converted before this
@@ -447,17 +465,6 @@ fold :: ( FromRow row, ToRow params )
447 -> IO a
465 -> IO a
448fold = foldWithOptions defaultFoldOptions
466fold = foldWithOptions defaultFoldOptions
449
467
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
468-- | 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
469-- to 256 rows, although it might be nice to make this more intelligent
463-- based on e.g. the average size of the rows.
470-- based on e.g. the average size of the rows.
@@ -492,21 +499,9 @@ foldWithOptions :: ( FromRow row, ToRow params )
492 -> a
499 -> a
493 -> (a -> row -> IO a)
500 -> (a -> row -> IO a)
494 -> IO a
501 -> IO a
495−foldWithOptions opts = foldWithOptionsAndParser opts fromRow
502+foldWithOptions opts conn template qs a f = do
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
508 q <- formatQuery conn template qs
503 q <- formatQuery conn template qs
509− doFold opts parser conn template (Query q) a f
504+ doFold opts conn template (Query q) a f
510
505
511-- | A version of 'fold' that does not perform query substitution.
506-- | A version of 'fold' that does not perform query substitution.
512fold_ :: (FromRow r) =>
507fold_ :: (FromRow r) =>
@@ -517,14 +512,6 @@ fold_ :: (FromRow r) =>
517 -> IO a
512 -> IO a
518fold_ = foldWithOptions_ defaultFoldOptions
513fold_ = foldWithOptions_ defaultFoldOptions
519
514
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
528
515
529foldWithOptions_ :: (FromRow r) =>
516foldWithOptions_ :: (FromRow r) =>
530 FoldOptions
517 FoldOptions
@@ -533,27 +520,18 @@ foldWithOptions_ :: (FromRow r) =>
533 -> a -- ^ Initial state for result consumer.
520 -> a -- ^ Initial state for result consumer.
534 -> (a -> r -> IO a) -- ^ Result consumer.
521 -> (a -> r -> IO a) -- ^ Result consumer.
535 -> IO a
522 -> IO a
536−foldWithOptions_ opts conn query' a f = doFold opts fromRow conn query' query' a f
523+foldWithOptions_ opts conn query a f = doFold opts conn query query a f
537−
524+
538−-- | A version of 'foldWithOptions_' taking a parser as an argument
525+
539−foldWithOptionsAndParser_ :: FoldOptions
526+doFold :: ( FromRow row )
540− -> RowParser r
527+ => FoldOptions
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
550 -> Connection
528 -> Connection
551 -> Query
529 -> Query
552 -> Query
530 -> Query
553 -> a
531 -> a
554 -> (a -> row -> IO a)
532 -> (a -> row -> IO a)
555 -> IO a
533 -> IO a
556−doFold FoldOptions{..} parser conn _template q a0 f = do
534+doFold FoldOptions{..} conn _template q a0 f = do
557 stat <- withConnection conn PQ.transactionStatus
535 stat <- withConnection conn PQ.transactionStatus
558 case stat of
536 case stat of
559 PQ.TransIdle -> withTransactionMode transactionMode conn go
537 PQ.TransIdle -> withTransactionMode transactionMode conn go
@@ -571,17 +549,28 @@ doFold FoldOptions{..} parser conn _template q a0 f = do
571 PQ.TransUnknown -> fail "foldWithOpts FIXME: PQ.TransUnknown"
549 PQ.TransUnknown -> fail "foldWithOpts FIXME: PQ.TransUnknown"
572 -- Not sure what this means.
550 -- Not sure what this means.
573 where
551 where
574− declare =
552+ declare = do
575− declareCursor conn q
553+ name <- newTempName conn
576− fetch cursor a =
554+ _ <- execute_ conn $ mconcat
577− foldForwardWithParser cursor parser chunkSize f a
555+ [ "DECLARE ", name, " NO SCROLL CURSOR FOR ", q ]
578−
556+ return name
557+ fetch (Query name) = query_ conn $
558+ Query (toByteString (fromByteString "FETCH FORWARD "
559+ <> integral chunkSize
560+ <> fromByteString " FROM "
561+ <> fromByteString name
562+ ))
563+ close name =
564+ (execute_ conn ("CLOSE " <> name) >> return ()) `E.catch` \ex ->
565+ -- Don't throw exception if CLOSE failed because the transaction is
566+ -- aborted. Otherwise, it will throw away the original error.
567+ if isFailedTransactionError ex then return () else throwIO ex
568+
579− go = bracket declare closeCursor $ \cursor ->
569+ go = bracket declare close $ \name ->
580− let loop a = fetch cursor a >>=
570+ let loop a = do
581− \r -> case r of
571+ rs <- fetch name
582− Left x -> return x
572+ if null rs then return a else foldM f a rs >>= loop
583− Right x -> loop x
584− in loop a0
573+ in loop a0
585
574
586-- FIXME: choose the Automatic chunkSize more intelligently
575-- FIXME: choose the Automatic chunkSize more intelligently
587-- One possibility is to use the type of the results, although this
576-- One possibility is to use the type of the results, although this
@@ -600,37 +589,87 @@ forEach :: (ToRow q, FromRow r) =>
600 -> q -- ^ Query parameters.
589 -> q -- ^ Query parameters.
601 -> (r -> IO ()) -- ^ Result consumer.
590 -> (r -> IO ()) -- ^ Result consumer.
602 -> IO ()
591 -> IO ()
603−forEach = forEachWith fromRow
592+forEach conn template qs = fold conn template qs () . const
604{-# INLINE forEach #-}
593{-# INLINE forEach #-}
605
594
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−
617-- | A version of 'forEach' that does not perform query substitution.
595-- | A version of 'forEach' that does not perform query substitution.
618forEach_ :: (FromRow r) =>
596forEach_ :: (FromRow r) =>
619 Connection
597 Connection
620 -> Query -- ^ Query template.
598 -> Query -- ^ Query template.
621 -> (r -> IO ()) -- ^ Result consumer.
599 -> (r -> IO ()) -- ^ Result consumer.
622 -> IO ()
600 -> IO ()
623−forEach_ = forEachWith_ fromRow
601+forEach_ conn template = fold_ conn template () . const
624{-# INLINE forEach_ #-}
602{-# INLINE forEach_ #-}
625
603
626−forEachWith_ :: RowParser r
604+forM' :: (Ord n, Num n) => n -> n -> (n -> IO a) -> IO [a]
627− -> Connection
605+forM' lo hi m = loop hi []
628− -> Query
606+ where
629− -> (r -> IO ())
607+ loop !n !as
630− -> IO ()
608+ | n < lo = return as
631−forEachWith_ parser conn template = foldWith_ parser conn template () . const
609+ | otherwise = do
632−{-# INLINE forEachWith_ #-}
610+ a <- m n
633−
611+ loop (n-1) (a:as)
612+
613+finishQuery :: FromRow r => Connection -> Query -> PQ.Result -> IO [r]
614+finishQuery = finishQueryWith fromRow
615+
616+finishQueryWith :: RowParser r -> Connection -> Query -> PQ.Result -> IO [r]
617+finishQueryWith parser conn q result = do
618+ status <- PQ.resultStatus result
619+ case status of
620+ PQ.EmptyQuery ->
621+ throwIO $ QueryError "query: Empty query" q
622+ PQ.CommandOk -> do
623+ throwIO $ QueryError "query resulted in a command response" q
624+ PQ.TuplesOk -> do
625+ let unCol (PQ.Col x) = fromIntegral x :: Int
626+ nrows <- PQ.ntuples result
627+ ncols <- PQ.nfields result
628+ forM' 0 (nrows-1) $ \row -> do
629+ let rw = Row row result
630+ okvc <- runConversion (runStateT (runReaderT (unRP parser) rw) 0) conn
631+ case okvc of
632+ Ok (val,col) | col == ncols -> return val
633+ | otherwise -> do
634+ vals <- forM' 0 (ncols-1) $ \c -> do
635+ tinfo <- getTypeInfo conn =<< PQ.ftype result c
636+ v <- PQ.getvalue result row c
637+ return ( tinfo
638+ , fmap ellipsis v )
639+ throw (ConversionFailed
640+ (show (unCol ncols) ++ " values: " ++ show vals)
641+ Nothing
642+ ""
643+ (show (unCol col) ++ " slots in target type")
644+ "mismatch between number of columns to \
645+ \convert and number in target type")
646+ Errors [] -> throwIO $ ConversionFailed "" Nothing "" "" "unknown error"
647+ Errors [x] -> throwIO x
648+ Errors xs -> throwIO $ ManyErrors xs
649+ PQ.CopyOut ->
650+ throwIO $ QueryError "query: COPY TO is not supported" q
651+ PQ.CopyIn ->
652+ throwIO $ QueryError "query: COPY FROM is not supported" q
653+ PQ.BadResponse -> throwResultError "query" result status
654+ PQ.NonfatalError -> throwResultError "query" result status
655+ PQ.FatalError -> throwResultError "query" result status
656+
657+ellipsis :: ByteString -> ByteString
658+ellipsis bs
659+ | B.length bs > 15 = B.take 10 bs `B.append` "[...]"
660+ | otherwise = bs
661+
662+fmtError :: String -> Query -> [Action] -> a
663+fmtError msg q xs = throw FormatError {
664+ fmtMessage = msg
665+ , fmtQuery = q
666+ , fmtParams = map twiddle xs
667+ }
668+ where twiddle (Plain b) = toByteString b
669+ twiddle (Escape s) = s
670+ twiddle (EscapeByteA s) = s
671+ twiddle (EscapeIdentifier s) = s
672+ twiddle (Many ys) = B.concat (map twiddle ys)
634
673
635-- $use
674-- $use
636--
675--
@@ -902,7 +941,7 @@ forEachWith_ parser conn template = foldWith_ parser conn template () . const
902-- all values of the given PostgreSQL type is considered \"compatible\".
941-- all values of the given PostgreSQL type is considered \"compatible\".
903-- For instance, you can always extract a PostgreSQL 16-bit @SMALLINT@
942-- For instance, you can always extract a PostgreSQL 16-bit @SMALLINT@
904-- column to a Haskell 'Int'. The Haskell 'Float' type can accurately
943-- column to a Haskell 'Int'. The Haskell 'Float' type can accurately
905−-- represent a @SMALLINT@, so it is considered compatible with those types.
944+-- represent a @SMALLINT@, so it is considered compatble with those types.
906--
945--
907-- * A numeric compatibility check is based only on the type of a
946-- * A numeric compatibility check is based only on the type of a
908-- column, /not/ on its values. For instance, a PostgreSQL 64-bit
947-- column, /not/ on its values. For instance, a PostgreSQL 64-bit
src/Database/PostgreSQL/Simple/Arrays.hs+2−2
@@ -42,9 +42,9 @@ array delim = char '{' *> option [] (arrays <|> strings) <* char '}'
42quoted :: Parser ByteString
42quoted :: Parser ByteString
43quoted = char '"' *> option "" contents <* char '"'
43quoted = char '"' *> option "" contents <* char '"'
44 where
44 where
45− esc' = char '\\' *> (char '\\' <|> char '"')
45+ esc = char '\\' *> (char '\\' <|> char '"')
46 unQ = takeWhile1 (notInClass "\"\\")
46 unQ = takeWhile1 (notInClass "\"\\")
47− contents = mconcat <$> many (unQ <|> B.singleton <$> esc')
47+ contents = mconcat <$> many (unQ <|> B.singleton <$> esc)
48
48
49-- | Recognizes a plain string literal, not containing quotes or brackets and
49-- | Recognizes a plain string literal, not containing quotes or brackets and
50-- not containing the delimiter character.
50-- not containing the delimiter character.
src/Database/PostgreSQL/Simple/BuiltinTypes.hsnew file+428
@@ -0,0 +1,428 @@
1+{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}
2+
3+------------------------------------------------------------------------------
4+-- |
5+-- Module: Database.PostgreSQL.Simple.BuiltinTypes
6+-- Copyright: (c) 2011-2012 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+ {-# DEPRECATED "Use TypeInfo instead" #-}
18+ ( BuiltinType (..)
19+ , builtin2oid
20+ , oid2builtin
21+ , builtin2typname
22+ , oid2typname
23+ ) where
24+
25+import Data.Typeable
26+import Data.ByteString (ByteString)
27+import qualified Database.PostgreSQL.LibPQ as PQ
28+
29+data BuiltinType
30+ = Bool
31+ | ByteA
32+ | Char
33+ | Name
34+ | Int8
35+ | Int2
36+ | Int4
37+ | RegProc
38+ | Text
39+ | Oid
40+ | Tid
41+ | Xid
42+ | Cid
43+ | Xml
44+ | Point
45+ | LSeg
46+ | Path
47+ | Box
48+ | Polygon
49+ | Line
50+ | Cidr
51+ | Float4
52+ | Float8
53+ | AbsTime
54+ | RelTime
55+ | TInterval
56+ | Unknown
57+ | Circle
58+ | Money
59+ | MacAddr
60+ | Inet
61+ | BpChar
62+ | VarChar
63+ | Date
64+ | Time
65+ | Timestamp
66+ | TimestampTZ
67+ | Interval
68+ | TimeTZ
69+ | Bit
70+ | VarBit
71+ | Numeric
72+ | RefCursor
73+ | Record
74+ | Void
75+ | UUID
76+ | JSON
77+ | JSONB
78+ deriving (Eq, Ord, Enum, Bounded, Read, Show, Typeable)
79+
80+builtin2oid :: BuiltinType -> PQ.Oid
81+builtin2oid typ = PQ.Oid $ case typ of
82+ Bool -> 16
83+ ByteA -> 17
84+ Char -> 18
85+ Name -> 19
86+ Int8 -> 20
87+ Int2 -> 21
88+ Int4 -> 23
89+ RegProc -> 24
90+ Text -> 25
91+ Oid -> 26
92+ Tid -> 27
93+ Xid -> 28
94+ Cid -> 29
95+ Xml -> 142
96+ Point -> 600
97+ LSeg -> 601
98+ Path -> 602
99+ Box -> 603
100+ Polygon -> 604
101+ Line -> 628
102+ Cidr -> 650
103+ Float4 -> 700
104+ Float8 -> 701
105+ AbsTime -> 702
106+ RelTime -> 703
107+ TInterval -> 704
108+ Unknown -> 705
109+ Circle -> 718
110+ Money -> 790
111+ MacAddr -> 829
112+ Inet -> 869
113+ BpChar -> 1042
114+ VarChar -> 1043
115+ Date -> 1082
116+ Time -> 1083
117+ Timestamp -> 1114
118+ TimestampTZ -> 1184
119+ Interval -> 1186
120+ TimeTZ -> 1266
121+ Bit -> 1560
122+ VarBit -> 1562
123+ Numeric -> 1700
124+ RefCursor -> 1790
125+ Record -> 2249
126+ Void -> 2278
127+ UUID -> 2950
128+ JSON -> 114
129+ JSONB -> 3802
130+
131+oid2builtin :: PQ.Oid -> Maybe BuiltinType
132+oid2builtin (PQ.Oid x) = case x of
133+ 16 -> Just Bool
134+ 17 -> Just ByteA
135+ 18 -> Just Char
136+ 19 -> Just Name
137+ 20 -> Just Int8
138+ 21 -> Just Int2
139+ 23 -> Just Int4
140+ 24 -> Just RegProc
141+ 25 -> Just Text
142+ 26 -> Just Oid
143+ 27 -> Just Tid
144+ 28 -> Just Xid
145+ 29 -> Just Cid
146+ 142 -> Just Xml
147+ 600 -> Just Point
148+ 601 -> Just LSeg
149+ 602 -> Just Path
150+ 603 -> Just Box
151+ 604 -> Just Polygon
152+ 628 -> Just Line
153+ 650 -> Just Cidr
154+ 700 -> Just Float4
155+ 701 -> Just Float8
156+ 702 -> Just AbsTime
157+ 703 -> Just RelTime
158+ 704 -> Just TInterval
159+ 705 -> Just Unknown
160+ 718 -> Just Circle
161+ 790 -> Just Money
162+ 829 -> Just MacAddr
163+ 869 -> Just Inet
164+ 1042 -> Just BpChar
165+ 1043 -> Just VarChar
166+ 1082 -> Just Date
167+ 1083 -> Just Time
168+ 1114 -> Just Timestamp
169+ 1184 -> Just TimestampTZ
170+ 1186 -> Just Interval
171+ 1266 -> Just TimeTZ
172+ 1560 -> Just Bit
173+ 1562 -> Just VarBit
174+ 1700 -> Just Numeric
175+ 1790 -> Just RefCursor
176+ 2249 -> Just Record
177+ 2278 -> Just Void
178+ 2950 -> Just UUID
179+ 114 -> Just JSON
180+ 3802 -> Just JSONB
181+ _ -> Nothing
182+
183+builtin2typname :: BuiltinType -> ByteString
184+builtin2typname typ = case typ of
185+ Bool -> bool
186+ ByteA -> bytea
187+ Char -> char
188+ Name -> name
189+ Int8 -> int8
190+ Int2 -> int2
191+ Int4 -> int4
192+ RegProc -> regproc
193+ Text -> text
194+ Oid -> oid
195+ Tid -> tid
196+ Xid -> xid
197+ Cid -> cid
198+ Xml -> xml
199+ Point -> point
200+ LSeg -> lseg
201+ Path -> path
202+ Box -> box
203+ Polygon -> polygon
204+ Line -> line
205+ Cidr -> cidr
206+ Float4 -> float4
207+ Float8 -> float8
208+ AbsTime -> abstime
209+ RelTime -> reltime
210+ TInterval -> tinterval
211+ Unknown -> unknown
212+ Circle -> circle
213+ Money -> money
214+ MacAddr -> macaddr
215+ Inet -> inet
216+ BpChar -> bpchar
217+ VarChar -> varchar
218+ Date -> date
219+ Time -> time
220+ Timestamp -> timestamp
221+ TimestampTZ -> timestamptz
222+ Interval -> interval
223+ TimeTZ -> timetz
224+ Bit -> bit
225+ VarBit -> varbit
226+ Numeric -> numeric
227+ RefCursor -> refcursor
228+ Record -> record
229+ Void -> void
230+ UUID -> uuid
231+ JSON -> json
232+ JSONB -> jsonb
233+
234+oid2typname :: PQ.Oid -> Maybe ByteString
235+oid2typname (PQ.Oid x) = case x of
236+ 16 -> Just bool
237+ 17 -> Just bytea
238+ 18 -> Just char
239+ 19 -> Just name
240+ 20 -> Just int8
241+ 21 -> Just int2
242+ 23 -> Just int4
243+ 24 -> Just regproc
244+ 25 -> Just text
245+ 26 -> Just oid
246+ 27 -> Just tid
247+ 28 -> Just xid
248+ 29 -> Just cid
249+ 142 -> Just xml
250+ 600 -> Just point
251+ 601 -> Just lseg
252+ 602 -> Just path
253+ 603 -> Just box
254+ 604 -> Just polygon
255+ 628 -> Just line
256+ 650 -> Just cidr
257+ 700 -> Just float4
258+ 701 -> Just float8
259+ 702 -> Just abstime
260+ 703 -> Just reltime
261+ 704 -> Just tinterval
262+ 705 -> Just unknown
263+ 718 -> Just circle
264+ 790 -> Just money
265+ 829 -> Just macaddr
266+ 869 -> Just inet
267+ 1042 -> Just bpchar
268+ 1043 -> Just varchar
269+ 1082 -> Just date
270+ 1083 -> Just time
271+ 1114 -> Just timestamp
272+ 1184 -> Just timestamptz
273+ 1186 -> Just interval
274+ 1266 -> Just timetz
275+ 1560 -> Just bit
276+ 1562 -> Just varbit
277+ 1700 -> Just numeric
278+ 1790 -> Just refcursor
279+ 2249 -> Just record
280+ 2278 -> Just void
281+ 2950 -> Just uuid
282+ 114 -> Just json
283+ 3802 -> Just jsonb
284+ _ -> Nothing
285+
286+bool :: ByteString
287+bool = "bool"
288+
289+bytea :: ByteString
290+bytea = "bytea"
291+
292+char :: ByteString
293+char = "char"
294+
295+name :: ByteString
296+name = "name"
297+
298+int8 :: ByteString
299+int8 = "int8"
300+
301+int2 :: ByteString
302+int2 = "int2"
303+
304+int4 :: ByteString
305+int4 = "int4"
306+
307+regproc :: ByteString
308+regproc = "regproc"
309+
310+text :: ByteString
311+text = "text"
312+
313+oid :: ByteString
314+oid = "oid"
315+
316+tid :: ByteString
317+tid = "tid"
318+
319+xid :: ByteString
320+xid = "xid"
321+
322+cid :: ByteString
323+cid = "cid"
324+
325+xml :: ByteString
326+xml = "xml"
327+
328+point :: ByteString
329+point = "point"
330+
331+lseg :: ByteString
332+lseg = "lseg"
333+
334+path :: ByteString
335+path = "path"
336+
337+box :: ByteString
338+box = "box"
339+
340+polygon :: ByteString
341+polygon = "polygon"
342+
343+line :: ByteString
344+line = "line"
345+
346+cidr :: ByteString
347+cidr = "cidr"
348+
349+float4 :: ByteString
350+float4 = "float4"
351+
352+float8 :: ByteString
353+float8 = "float8"
354+
355+abstime :: ByteString
356+abstime = "abstime"
357+
358+reltime :: ByteString
359+reltime = "reltime"
360+
361+tinterval :: ByteString
362+tinterval = "tinterval"
363+
364+unknown :: ByteString
365+unknown = "unknown"
366+
367+circle :: ByteString
368+circle = "circle"
369+
370+money :: ByteString
371+money = "money"
372+
373+macaddr :: ByteString
374+macaddr = "macaddr"
375+
376+inet :: ByteString
377+inet = "inet"
378+
379+bpchar :: ByteString
380+bpchar = "bpchar"
381+
382+varchar :: ByteString
383+varchar = "varchar"
384+
385+date :: ByteString
386+date = "date"
387+
388+time :: ByteString
389+time = "time"
390+
391+timestamp :: ByteString
392+timestamp = "timestamp"
393+
394+timestamptz :: ByteString
395+timestamptz = "timestamptz"
396+
397+interval :: ByteString
398+interval = "interval"
399+
400+timetz :: ByteString
401+timetz = "timetz"
402+
403+bit :: ByteString
404+bit = "bit"
405+
406+varbit :: ByteString
407+varbit = "varbit"
408+
409+numeric :: ByteString
410+numeric = "numeric"
411+
412+refcursor :: ByteString
413+refcursor = "refcursor"
414+
415+record :: ByteString
416+record = "record"
417+
418+void :: ByteString
419+void = "void"
420+
421+uuid :: ByteString
422+uuid = "uuid"
423+
424+json :: ByteString
425+json = "json"
426+
427+jsonb :: ByteString
428+jsonb = "jsonb"
src/Database/PostgreSQL/Simple/Compat.hs+21−17
@@ -5,20 +5,19 @@ module Database.PostgreSQL.Simple.Compat
5 ( mask
5 ( mask
6 , (<>)
6 , (<>)
7 , unsafeDupablePerformIO
7 , unsafeDupablePerformIO
8− , toByteString
9− , scientificBuilder
10− , toPico
11− , fromPico
12 ) where
8 ) where
13
9
14import qualified Control.Exception as E
10import qualified Control.Exception as E
15−import Data.ByteString (ByteString)
11+import Data.Monoid
16−import Data.ByteString.Lazy (toStrict)
12+
17−import Data.ByteString.Builder (Builder, toLazyByteString)
13+#if __GLASGOW_HASKELL__ >= 702
18−import Data.Text.Lazy.Builder.Scientific (scientificBuilder)
19import System.IO.Unsafe (unsafeDupablePerformIO)
14import System.IO.Unsafe (unsafeDupablePerformIO)
20−import Data.Fixed (Pico)
15+#elif __GLASGOW_HASKELL__ >= 611
21−import Data.Fixed (Fixed(MkFixed))
16+import GHC.IO (unsafeDupablePerformIO)
17+#else
18+import GHC.IOBase (unsafeDupablePerformIO)
19+#endif
20+
22
21
23-- | Like 'E.mask', but backported to base before version 4.3.0.
22-- | Like 'E.mask', but backported to base before version 4.3.0.
24--
23--
@@ -28,14 +27,19 @@ import Data.Fixed (Fixed(MkFixed))
28-- 'withTransactionMode' function calls the restore callback only once, so we
27-- 'withTransactionMode' function calls the restore callback only once, so we
29-- don't need that polymorphism.
28-- don't need that polymorphism.
30mask :: ((IO a -> IO a) -> IO b) -> IO b
29mask :: ((IO a -> IO a) -> IO b) -> IO b
30+#if MIN_VERSION_base(4,3,0)
31mask io = E.mask $ \restore -> io restore
31mask io = E.mask $ \restore -> io restore
32+#else
33+mask io = do
34+ b <- E.blocked
35+ E.block $ io $ \m -> if b then m else E.unblock m
36+#endif
32{-# INLINE mask #-}
37{-# INLINE mask #-}
33
38
34−toByteString :: Builder -> ByteString
39+#if !MIN_VERSION_base(4,5,0)
35−toByteString x = toStrict (toLazyByteString x)
40+infixr 6 <>
36−
37−toPico :: Integer -> Pico
38−toPico = MkFixed
39
41
40−fromPico :: Pico -> Integer
42+(<>) :: Monoid m => m -> m -> m
41−fromPico (MkFixed i) = i
43+(<>) = mappend
44+{-# INLINE (<>) #-}
45+#endif
src/Database/PostgreSQL/Simple/Copy.hs+6−36
@@ -9,7 +9,7 @@
9-- Stability: experimental
9-- Stability: experimental
10--
10--
11-- mid-level support for COPY IN and COPY OUT. See
11-- mid-level support for COPY IN and COPY OUT. See
12−-- <https://www.postgresql.org/docs/9.5/static/sql-copy.html> for
12+-- <http://www.postgresql.org/docs/9.2/static/sql-copy.html> for
13-- more information.
13-- more information.
14--
14--
15-- To use this binding, first call 'copy' with an appropriate
15-- To use this binding, first call 'copy' with an appropriate
@@ -32,7 +32,6 @@ module Database.PostgreSQL.Simple.Copy
32 ( copy
32 ( copy
33 , copy_
33 , copy_
34 , CopyOutResult(..)
34 , CopyOutResult(..)
35− , foldCopyData
36 , getCopyData
35 , getCopyData
37 , putCopyData
36 , putCopyData
38 , putCopyEnd
37 , putCopyEnd
@@ -49,13 +48,13 @@ import qualified Data.ByteString.Char8 as B
49import qualified Database.PostgreSQL.LibPQ as PQ
48import qualified Database.PostgreSQL.LibPQ as PQ
50import Database.PostgreSQL.Simple
49import Database.PostgreSQL.Simple
51import Database.PostgreSQL.Simple.Types
50import Database.PostgreSQL.Simple.Types
52−import Database.PostgreSQL.Simple.Internal hiding (result, row)
51+import Database.PostgreSQL.Simple.Internal
53
52
54
53
55-- | Issue a @COPY FROM STDIN@ or @COPY TO STDOUT@ query. In the former
54-- | 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,
55-- case, the connection's state will change to @CopyIn@; in the latter,
57-- @CopyOut@. The connection must be in the ready state in order
56-- @CopyOut@. The connection must be in the ready state in order
58−-- to call this function. Performs parameter substitution.
57+-- to call this function. Performs parameter subsitution.
59
58
60copy :: ( ToRow params ) => Connection -> Query -> params -> IO ()
59copy :: ( ToRow params ) => Connection -> Query -> params -> IO ()
61copy conn template qs = do
60copy conn template qs = do
@@ -76,18 +75,15 @@ doCopy :: B.ByteString -> Connection -> Query -> B.ByteString -> IO ()
76doCopy funcName conn template q = do
75doCopy funcName conn template q = do
77 result <- exec conn q
76 result <- exec conn q
78 status <- PQ.resultStatus result
77 status <- PQ.resultStatus result
79− let errMsg msg = throwIO $ QueryError
78+ let err = throwIO $ QueryError
80− (B.unpack funcName ++ " " ++ msg)
79+ (B.unpack funcName ++ " " ++ show status)
81 template
80 template
82− let err = errMsg $ show status
83 case status of
81 case status of
84 PQ.EmptyQuery -> err
82 PQ.EmptyQuery -> err
85 PQ.CommandOk -> err
83 PQ.CommandOk -> err
86 PQ.TuplesOk -> err
84 PQ.TuplesOk -> err
87 PQ.CopyOut -> return ()
85 PQ.CopyOut -> return ()
88 PQ.CopyIn -> return ()
86 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
87 PQ.BadResponse -> throwResultError funcName result status
92 PQ.NonfatalError -> throwResultError funcName result status
88 PQ.NonfatalError -> throwResultError funcName result status
93 PQ.FatalError -> throwResultError funcName result status
89 PQ.FatalError -> throwResultError funcName result status
@@ -101,30 +97,6 @@ data CopyOutResult
101 deriving (Eq, Typeable, Show)
97 deriving (Eq, Typeable, Show)
102
98
103
99
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
100-- | 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
101-- 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,
102-- returns a 'CopyOutRow', the connection remains in the @CopyOut@ state,
@@ -252,9 +224,7 @@ getCopyCommandTag funcName pqconn = do
252 consumeResults pqconn
224 consumeResults pqconn
253 let rowCount = P.string "COPY " *> (P.decimal <* P.endOfInput)
225 let rowCount = P.string "COPY " *> (P.decimal <* P.endOfInput)
254 case P.parseOnly rowCount cmdStat of
226 case P.parseOnly rowCount cmdStat of
255− Left _ -> do mmsg <- PQ.errorMessage pqconn
256− fail $ errCmdStatusFmt
227+ Left _ -> fail errCmdStatusFmt
257− ++ maybe "" (\msg -> "\nConnection error: "++B.unpack msg) mmsg
258 Right n -> return $! n
228 Right n -> return $! n
259 where
229 where
260 errCmdStatus = B.unpack funcName ++ ": failed to fetch command status"
230 errCmdStatus = B.unpack funcName ++ ": failed to fetch command status"
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.hs+11−15
@@ -25,6 +25,7 @@ module Database.PostgreSQL.Simple.Errors
25 )
25 )
26 where
26 where
27
27
28+import Control.Applicative
28import Control.Exception as E
29import Control.Exception as E
29
30
30import Data.Attoparsec.ByteString.Char8
31import Data.Attoparsec.ByteString.Char8
@@ -54,23 +55,19 @@ data ConstraintViolation
54 -- ^ Name of violated constraint
55 -- ^ Name of violated constraint
55 | CheckViolation ByteString ByteString
56 | CheckViolation ByteString ByteString
56 -- ^ Relation name (usually table), constraint name
57 -- ^ Relation name (usually table), constraint name
57− | ExclusionViolation ByteString
58− -- ^ Name of the exclusion violation constraint
59 deriving (Show, Eq, Ord, Typeable)
58 deriving (Show, Eq, Ord, Typeable)
60
59
61-- Default instance should be enough
60-- Default instance should be enough
62−instance Exception ConstraintViolation where
61+instance Exception ConstraintViolation
63− toException = postgresqlExceptionToException
64− fromException = postgresqlExceptionFromException
65
62
66
63
67-- | Tries to convert 'SqlError' to 'ConstrainViolation', checks sqlState and
64-- | Tries to convert 'SqlError' to 'ConstrainViolation', checks sqlState and
68−-- succeeds only if able to parse sqlErrorMsg.
65+-- succeedes only if able to parse sqlErrorMsg.
69--
66--
70−-- > createUser = handleJust constraintViolation handler $ execute conn ...
67+-- > createUser = catchJust constraintViolation catcher $ execute conn ...
71-- > where
68-- > where
72−-- > handler (UniqueViolation "user_login_key") = ...
69+-- > catcher UniqueViolation "user_login_key" = ...
73−-- > handler _ = ...
70+-- > catcher _ = ...
74constraintViolation :: SqlError -> Maybe ConstraintViolation
71constraintViolation :: SqlError -> Maybe ConstraintViolation
75constraintViolation e =
72constraintViolation e =
76 case sqlState e of
73 case sqlState e of
@@ -78,23 +75,22 @@ constraintViolation e =
78 "23503" -> uncurry ForeignKeyViolation <$> parseMaybe parseQ2 msg
75 "23503" -> uncurry ForeignKeyViolation <$> parseMaybe parseQ2 msg
79 "23505" -> UniqueViolation <$> parseMaybe parseQ1 msg
76 "23505" -> UniqueViolation <$> parseMaybe parseQ1 msg
80 "23514" -> uncurry CheckViolation <$> parseMaybe parseQ2 msg
77 "23514" -> uncurry CheckViolation <$> parseMaybe parseQ2 msg
81− "23P01" -> ExclusionViolation <$> parseMaybe parseQ1 msg
82 _ -> Nothing
78 _ -> Nothing
83 where msg = sqlErrorMsg e
79 where msg = sqlErrorMsg e
84
80
85
81
86-- | Like constraintViolation, but also packs original SqlError.
82-- | Like constraintViolation, but also packs original SqlError.
87--
83--
88−-- > createUser = handleJust constraintViolationE handler $ execute conn ...
84+-- > createUser = catchJust constraintViolationE catcher $ execute conn ...
89-- > where
85-- > where
90−-- > handler (_, UniqueViolation "user_login_key") = ...
86+-- > catcher (_, UniqueViolation "user_login_key") = ...
91−-- > handler (e, _) = throwIO e
87+-- > catcher (e, _) = throwIO e
92--
88--
93constraintViolationE :: SqlError -> Maybe (SqlError, ConstraintViolation)
89constraintViolationE :: SqlError -> Maybe (SqlError, ConstraintViolation)
94constraintViolationE e = fmap ((,) e) $ constraintViolation e
90constraintViolationE e = fmap ((,) e) $ constraintViolation e
95
91
96-- | Catches SqlError, tries to convert to ConstraintViolation, re-throws
92-- | Catches SqlError, tries to convert to ConstraintViolation, re-throws
97−-- on fail. Provides alternative interface to 'E.handleJust'
93+-- on fail. Provides alternative interface to catchJust
98--
94--
99-- > createUser = catchViolation catcher $ execute conn ...
95-- > createUser = catchViolation catcher $ execute conn ...
100-- > where
96-- > where
@@ -125,7 +121,7 @@ parseMaybe p b = either (const Nothing) Just $ parseOnly p b
125------------------------------------------------------------------------
121------------------------------------------------------------------------
126-- Error predicates
122-- Error predicates
127--
123--
128−-- https://www.postgresql.org/docs/9.5/static/errcodes-appendix.html
124+-- http://www.postgresql.org/docs/current/static/errcodes-appendix.html
129
125
130isSerializationError :: SqlError -> Bool
126isSerializationError :: SqlError -> Bool
131isSerializationError = isSqlState "40001"
127isSerializationError = isSqlState "40001"
src/Database/PostgreSQL/Simple/FromField.hs+94−167
@@ -1,8 +1,7 @@
1{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-}
1{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-}
2{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
2{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
3{-# LANGUAGE PatternGuards, ScopedTypeVariables #-}
3{-# LANGUAGE PatternGuards, ScopedTypeVariables #-}
4−{-# LANGUAGE RecordWildCards #-}
4+{-# LANGUAGE RecordWildCards, TemplateHaskell #-}
5−{-# LANGUAGE PolyKinds #-}
6
5
7{- |
6{- |
8Module: Database.PostgreSQL.Simple.FromField
7Module: Database.PostgreSQL.Simple.FromField
@@ -29,10 +28,10 @@ conversion routine, which sacrifices some accuracy for speed. If you
29need accuracy, consider first converting data to a 'Scientific' or 'Rational'
28need accuracy, consider first converting data to a 'Scientific' or 'Rational'
30type, and then converting to a floating-point type. If you are defining
29type, and then converting to a floating-point type. If you are defining
31your own 'Database.PostgreSQL.Simple.FromRow.FromRow' instances, this can be
30your own 'Database.PostgreSQL.Simple.FromRow.FromRow' instances, this can be
32−achieved simply by
31+acheived simply by
33@'fromRational' '<$>' 'Database.PostgreSQL.Simple.FromRow.field'@, although
32@'fromRational' '<$>' 'Database.PostgreSQL.Simple.FromRow.field'@, although
34−this idiom is additionally compatible with PostgreSQL's @int8@ and @numeric@
33+this idiom is additionally compatible with PostgreSQL's @numeric@ type.
35−types. If this is unacceptable, you may find
34+If this is unacceptable, you may find
36'Database.PostgreSQL.Simple.FromRow.fieldWith' useful.
35'Database.PostgreSQL.Simple.FromRow.fieldWith' useful.
37
36
38Also note that while converting to a 'Double' through the 'Scientific' type
37Also note that while converting to a 'Double' through the 'Scientific' type
@@ -106,28 +105,23 @@ module Database.PostgreSQL.Simple.FromField
106 , typeOid
105 , typeOid
107 , PQ.Oid(..)
106 , PQ.Oid(..)
108 , PQ.Format(..)
107 , PQ.Format(..)
109− , pgArrayFieldParser
110− , attoFieldParser
111
108
112− , optionalField
113 , fromJSONField
109 , fromJSONField
114− , fromFieldJSONByteString
115 ) where
110 ) where
116
111
117#include "MachDeps.h"
112#include "MachDeps.h"
118
113
119−import Control.Applicative ( Const(Const), (<|>), (<$>), pure, (*>), (<*) )
114+import Control.Applicative ( (<|>), (<$>), pure, (*>) )
120import Control.Concurrent.MVar (MVar, newMVar)
115import Control.Concurrent.MVar (MVar, newMVar)
121−import Control.Exception (Exception (toException, fromException))
116+import Control.Exception (Exception)
122import qualified Data.Aeson as JSON
117import qualified Data.Aeson as JSON
123import Data.Attoparsec.ByteString.Char8 hiding (Result)
118import Data.Attoparsec.ByteString.Char8 hiding (Result)
124import Data.ByteString (ByteString)
119import Data.ByteString (ByteString)
125import qualified Data.ByteString.Char8 as B
120import qualified Data.ByteString.Char8 as B
126−import Data.Functor.Identity (Identity(Identity))
127import Data.Int (Int16, Int32, Int64)
121import Data.Int (Int16, Int32, Int64)
128import Data.IORef (IORef, newIORef)
122import Data.IORef (IORef, newIORef)
129import Data.Ratio (Ratio)
123import Data.Ratio (Ratio)
130−import Data.Time.Compat ( UTCTime, ZonedTime, LocalTime, Day, TimeOfDay, CalendarDiffTime )
124+import Data.Time ( UTCTime, ZonedTime, LocalTime, Day, TimeOfDay )
131import Data.Typeable (Typeable, typeOf)
125import Data.Typeable (Typeable, typeOf)
132import Data.Vector (Vector)
126import Data.Vector (Vector)
133import Data.Vector.Mutable (IOVector)
127import Data.Vector.Mutable (IOVector)
@@ -138,6 +132,7 @@ import Database.PostgreSQL.Simple.Ok
138import Database.PostgreSQL.Simple.Types
132import Database.PostgreSQL.Simple.Types
139import Database.PostgreSQL.Simple.TypeInfo as TI
133import Database.PostgreSQL.Simple.TypeInfo as TI
140import qualified Database.PostgreSQL.Simple.TypeInfo.Static as TI
134import qualified Database.PostgreSQL.Simple.TypeInfo.Static as TI
135+import Database.PostgreSQL.Simple.TypeInfo.Macro as TI
141import Database.PostgreSQL.Simple.Time
136import Database.PostgreSQL.Simple.Time
142import Database.PostgreSQL.Simple.Arrays as Arrays
137import Database.PostgreSQL.Simple.Arrays as Arrays
143import qualified Database.PostgreSQL.LibPQ as PQ
138import qualified Database.PostgreSQL.LibPQ as PQ
@@ -149,13 +144,11 @@ import qualified Data.Text.Encoding as ST
149import qualified Data.Text.Lazy as LT
144import qualified Data.Text.Lazy as LT
150import Data.CaseInsensitive (CI)
145import Data.CaseInsensitive (CI)
151import qualified Data.CaseInsensitive as CI
146import qualified Data.CaseInsensitive as CI
152−import Data.UUID.Types (UUID)
147+import Data.UUID (UUID)
153−import qualified Data.UUID.Types as UUID
148+import qualified Data.UUID as UUID
154import Data.Scientific (Scientific)
149import Data.Scientific (Scientific)
155import GHC.Real (infinity, notANumber)
150import GHC.Real (infinity, notANumber)
156
151
157−import qualified Data.Aeson.Types as JSON
158−
159-- | Exception thrown if conversion from a SQL value to a Haskell
152-- | Exception thrown if conversion from a SQL value to a Haskell
160-- value fails.
153-- value fails.
161data ResultError = Incompatible { errSQLType :: String
154data ResultError = Incompatible { errSQLType :: String
@@ -182,9 +175,7 @@ data ResultError = Incompatible { errSQLType :: String
182 -- between metadata and actual data in a row).
175 -- between metadata and actual data in a row).
183 deriving (Eq, Show, Typeable)
176 deriving (Eq, Show, Typeable)
184
177
185−instance Exception ResultError where
178+instance Exception ResultError
186− toException = postgresqlExceptionToException
187− fromException = postgresqlExceptionFromException
188
179
189left :: Exception a => a -> Conversion b
180left :: Exception a => a -> Conversion b
190left = conversionError
181left = conversionError
@@ -225,7 +216,7 @@ typename field = typname <$> typeInfo field
225
216
226typeInfo :: Field -> Conversion TypeInfo
217typeInfo :: Field -> Conversion TypeInfo
227typeInfo Field{..} = Conversion $ \conn -> do
218typeInfo Field{..} = Conversion $ \conn -> do
228− Ok <$> (getTypeInfo conn typeOid)
219+ Ok <$> (getTypeInfo conn =<< PQ.ftype result column)
229
220
230typeInfoByOid :: PQ.Oid -> Conversion TypeInfo
221typeInfoByOid :: PQ.Oid -> Conversion TypeInfo
231typeInfoByOid oid = Conversion $ \conn -> do
222typeInfoByOid oid = Conversion $ \conn -> do
@@ -250,11 +241,9 @@ tableOid Field{..} = toMaybeOid (unsafeDupablePerformIO (PQ.ftable result column
250 then Nothing
241 then Nothing
251 else Just x
242 else Just x
252
243
253−-- | If the column has a table associated with it, this returns the
244+-- | If the column has a table associated with it, this returns the number
254−-- number of the associated table column. Table columns have
245+-- off the associated table column. Numbering starts from 0. Analogous
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@.
246+-- to libpq's @PQftablecol@.
258
247
259tableColumn :: Field -> Int
248tableColumn :: Field -> Int
260tableColumn Field{..} = fromCol (unsafeDupablePerformIO (PQ.ftablecol result column))
249tableColumn Field{..} = fromCol (unsafeDupablePerformIO (PQ.ftablecol result column))
@@ -270,33 +259,16 @@ format Field{..} = unsafeDupablePerformIO (PQ.fformat result column)
270-- | void
259-- | void
271instance FromField () where
260instance FromField () where
272 fromField f _bs
261 fromField f _bs
273− | typeOid f /= TI.voidOid = returnError Incompatible f ""
262+ | typeOid f /= $(inlineTypoid TI.void) = returnError Incompatible f ""
274 | otherwise = pure ()
263 | otherwise = pure ()
275
264
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
265-- | For dealing with null values. Compatible with any postgresql type
283-- compatible with type @a@. Note that the type is not checked if
266-- 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
267-- the value is null, although it is inadvisable to rely on this
285-- behavior.
268-- behavior.
286−instance FromField a => FromField (Maybe a) where
269+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
270+ fromField _ Nothing = pure Nothing
298− Just _ -> Just <$> p f mv
271+ fromField f bs = Just <$> fromField f bs
299−{-# INLINE optionalField #-}
300
272
301-- | compatible with any data type, but the value must be null
273-- | compatible with any data type, but the value must be null
302instance FromField Null where
274instance FromField Null where
@@ -306,30 +278,30 @@ instance FromField Null where
306-- | bool
278-- | bool
307instance FromField Bool where
279instance FromField Bool where
308 fromField f bs
280 fromField f bs
309− | typeOid f /= TI.boolOid = returnError Incompatible f ""
281+ | typeOid f /= $(inlineTypoid TI.bool) = returnError Incompatible f ""
310 | bs == Nothing = returnError UnexpectedNull f ""
282 | bs == Nothing = returnError UnexpectedNull f ""
311 | bs == Just "t" = pure True
283 | bs == Just "t" = pure True
312 | bs == Just "f" = pure False
284 | bs == Just "f" = pure False
313 | otherwise = returnError ConversionFailed f ""
285 | otherwise = returnError ConversionFailed f ""
314
286
315−-- | \"char\", bpchar
287+-- | \"char\"
316instance FromField Char where
288instance FromField Char where
317− fromField f bs0 =
289+ fromField f bs =
318− if (eq TI.charOid \/ eq TI.bpcharOid) (typeOid f)
290+ if typeOid f /= $(inlineTypoid TI.char)
291+ then returnError Incompatible f ""
319− then case bs0 of
292+ else case bs of
320 Nothing -> returnError UnexpectedNull f ""
293 Nothing -> returnError UnexpectedNull f ""
321 Just bs -> if B.length bs /= 1
294 Just bs -> if B.length bs /= 1
322 then returnError ConversionFailed f "length not 1"
295 then returnError ConversionFailed f "length not 1"
323 else return $! (B.head bs)
296 else return $! (B.head bs)
324− else returnError Incompatible f ""
325
297
326-- | int2
298-- | int2
327instance FromField Int16 where
299instance FromField Int16 where
328− fromField = attoFieldParser ok16 $ signed decimal
300+ fromField = atto ok16 $ signed decimal
329
301
330-- | int2, int4
302-- | int2, int4
331instance FromField Int32 where
303instance FromField Int32 where
332− fromField = attoFieldParser ok32 $ signed decimal
304+ fromField = atto ok32 $ signed decimal
333
305
334#if WORD_SIZE_IN_BITS < 64
306#if WORD_SIZE_IN_BITS < 64
335-- | int2, int4, and if compiled as 64-bit code, int8 as well.
307-- | int2, int4, and if compiled as 64-bit code, int8 as well.
@@ -339,37 +311,37 @@ instance FromField Int32 where
339-- This library was compiled as 64-bit code.
311-- This library was compiled as 64-bit code.
340#endif
312#endif
341instance FromField Int where
313instance FromField Int where
342− fromField = attoFieldParser okInt $ signed decimal
314+ fromField = atto okInt $ signed decimal
343
315
344-- | int2, int4, int8
316-- | int2, int4, int8
345instance FromField Int64 where
317instance FromField Int64 where
346− fromField = attoFieldParser ok64 $ signed decimal
318+ fromField = atto ok64 $ signed decimal
347
319
348-- | int2, int4, int8
320-- | int2, int4, int8
349instance FromField Integer where
321instance FromField Integer where
350− fromField = attoFieldParser ok64 $ signed decimal
322+ fromField = atto ok64 $ signed decimal
351
323
352-- | int2, float4 (Uses attoparsec's 'double' routine, for
324-- | int2, float4 (Uses attoparsec's 'double' routine, for
353-- better accuracy convert to 'Scientific' or 'Rational' first)
325-- better accuracy convert to 'Scientific' or 'Rational' first)
354instance FromField Float where
326instance FromField Float where
355− fromField = attoFieldParser ok (realToFrac <$> pg_double)
327+ fromField = atto ok (realToFrac <$> pg_double)
356− where ok = eq TI.float4Oid \/ eq TI.int2Oid
328+ where ok = $(mkCompats [TI.float4,TI.int2])
357
329
358-- | int2, int4, float4, float8 (Uses attoparsec's 'double' routine, for
330-- | int2, int4, float4, float8 (Uses attoparsec's 'double' routine, for
359-- better accuracy convert to 'Scientific' or 'Rational' first)
331-- better accuracy convert to 'Scientific' or 'Rational' first)
360instance FromField Double where
332instance FromField Double where
361− fromField = attoFieldParser ok pg_double
333+ fromField = atto ok pg_double
362− where ok = eq TI.float4Oid \/ eq TI.float8Oid \/ eq TI.int2Oid \/ eq TI.int4Oid
334+ where ok = $(mkCompats [TI.float4,TI.float8,TI.int2,TI.int4])
363
335
364−-- | int2, int4, int8, float4, float8, numeric
336+-- | int2, int4, float4, float8, numeric
365instance FromField (Ratio Integer) where
337instance FromField (Ratio Integer) where
366− fromField = attoFieldParser ok pg_rational
338+ fromField = atto ok pg_rational
367− where ok = eq TI.float4Oid \/ eq TI.float8Oid \/ eq TI.int2Oid \/ eq TI.int4Oid \/ eq TI.int8Oid \/ eq TI.numericOid
339+ where ok = $(mkCompats [TI.float4,TI.float8,TI.int2,TI.int4,TI.numeric])
368
340
369−-- | int2, int4, int8, float4, float8, numeric
341+-- | int2, int4, float4, float8, numeric
370instance FromField Scientific where
342instance FromField Scientific where
371− fromField = attoFieldParser ok rational
343+ fromField = atto ok rational
372− where ok = eq TI.float4Oid \/ eq TI.float8Oid \/ eq TI.int2Oid \/ eq TI.int4Oid \/ eq TI.int8Oid \/ eq TI.numericOid
344+ where ok = $(mkCompats [TI.float4,TI.float8,TI.int2,TI.int4,TI.numeric])
373
345
374unBinary :: Binary t -> t
346unBinary :: Binary t -> t
375unBinary (Binary x) = x
347unBinary (Binary x) = x
@@ -390,13 +362,13 @@ pg_rational
390
362
391-- | bytea, name, text, \"char\", bpchar, varchar, unknown
363-- | bytea, name, text, \"char\", bpchar, varchar, unknown
392instance FromField SB.ByteString where
364instance FromField SB.ByteString where
393− fromField f dat = if typeOid f == TI.byteaOid
365+ fromField f dat = if typeOid f == $(inlineTypoid TI.bytea)
394 then unBinary <$> fromField f dat
366 then unBinary <$> fromField f dat
395 else doFromField f okText' pure dat
367 else doFromField f okText' pure dat
396
368
397-- | oid
369-- | oid
398instance FromField PQ.Oid where
370instance FromField PQ.Oid where
399− fromField f dat = PQ.Oid <$> attoFieldParser (== TI.oidOid) decimal f dat
371+ fromField f dat = PQ.Oid <$> atto (== $(inlineTypoid TI.oid)) decimal f dat
400
372
401-- | bytea, name, text, \"char\", bpchar, varchar, unknown
373-- | bytea, name, text, \"char\", bpchar, varchar, unknown
402instance FromField LB.ByteString where
374instance FromField LB.ByteString where
@@ -404,7 +376,7 @@ instance FromField LB.ByteString where
404
376
405unescapeBytea :: Field -> SB.ByteString
377unescapeBytea :: Field -> SB.ByteString
406 -> Conversion (Binary SB.ByteString)
378 -> Conversion (Binary SB.ByteString)
407−unescapeBytea f str' = case unsafeDupablePerformIO (PQ.unescapeBytea str') of
379+unescapeBytea f str = case unsafeDupablePerformIO (PQ.unescapeBytea str) of
408 Nothing -> returnError ConversionFailed f "unescapeBytea failed"
380 Nothing -> returnError ConversionFailed f "unescapeBytea failed"
409 Just str -> pure (Binary str)
381 Just str -> pure (Binary str)
410
382
@@ -455,57 +427,48 @@ instance FromField [Char] where
455
427
456-- | timestamptz
428-- | timestamptz
457instance FromField UTCTime where
429instance FromField UTCTime where
458− fromField = ff TI.timestamptzOid "UTCTime" parseUTCTime
430+ fromField = ff $(inlineTypoid TI.timestamptz) "UTCTime" parseUTCTime
459
431
460-- | timestamptz
432-- | timestamptz
461instance FromField ZonedTime where
433instance FromField ZonedTime where
462− fromField = ff TI.timestamptzOid "ZonedTime" parseZonedTime
434+ fromField = ff $(inlineTypoid TI.timestamptz) "ZonedTime" parseZonedTime
463
435
464-- | timestamp
436-- | timestamp
465instance FromField LocalTime where
437instance FromField LocalTime where
466− fromField = ff TI.timestampOid "LocalTime" parseLocalTime
438+ fromField = ff $(inlineTypoid TI.timestamp) "LocalTime" parseLocalTime
467
439
468-- | date
440-- | date
469instance FromField Day where
441instance FromField Day where
470− fromField = ff TI.dateOid "Day" parseDay
442+ fromField = ff $(inlineTypoid TI.date) "Day" parseDay
471
443
472-- | time
444-- | time
473instance FromField TimeOfDay where
445instance FromField TimeOfDay where
474− fromField = ff TI.timeOid "TimeOfDay" parseTimeOfDay
446+ fromField = ff $(inlineTypoid TI.time) "TimeOfDay" parseTimeOfDay
475
447
476-- | timestamptz
448-- | timestamptz
477instance FromField UTCTimestamp where
449instance FromField UTCTimestamp where
478− fromField = ff TI.timestamptzOid "UTCTimestamp" parseUTCTimestamp
450+ fromField = ff $(inlineTypoid TI.timestamptz) "UTCTimestamp" parseUTCTimestamp
479
451
480-- | timestamptz
452-- | timestamptz
481instance FromField ZonedTimestamp where
453instance FromField ZonedTimestamp where
482− fromField = ff TI.timestamptzOid "ZonedTimestamp" parseZonedTimestamp
454+ fromField = ff $(inlineTypoid TI.timestamptz) "ZonedTimestamp" parseZonedTimestamp
483
455
484-- | timestamp
456-- | timestamp
485instance FromField LocalTimestamp where
457instance FromField LocalTimestamp where
486− fromField = ff TI.timestampOid "LocalTimestamp" parseLocalTimestamp
458+ fromField = ff $(inlineTypoid TI.timestamp) "LocalTimestamp" parseLocalTimestamp
487
459
488-- | date
460-- | date
489instance FromField Date where
461instance FromField Date where
490− fromField = ff TI.dateOid "Date" parseDate
462+ fromField = ff $(inlineTypoid TI.date) "Date" parseDate
491−
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
463
501ff :: PQ.Oid -> String -> (B8.ByteString -> Either String a)
464ff :: PQ.Oid -> String -> (B8.ByteString -> Either String a)
502 -> Field -> Maybe B8.ByteString -> Conversion a
465 -> Field -> Maybe B8.ByteString -> Conversion a
503−ff compatOid hsType parseBS f mstr =
466+ff compatOid hsType parse f mstr =
504 if typeOid f /= compatOid
467 if typeOid f /= compatOid
505 then err Incompatible ""
468 then err Incompatible ""
506 else case mstr of
469 else case mstr of
507 Nothing -> err UnexpectedNull ""
470 Nothing -> err UnexpectedNull ""
508− Just str -> case parseBS str of
471+ Just str -> case parse str of
509 Left msg -> err ConversionFailed msg
472 Left msg -> err ConversionFailed msg
510 Right val -> return val
473 Right val -> return val
511 where
474 where
@@ -527,29 +490,27 @@ instance (FromField a, FromField b) => FromField (Either a b) where
527
490
528-- | any postgresql array whose elements are compatible with type @a@
491-- | any postgresql array whose elements are compatible with type @a@
529instance (FromField a, Typeable a) => FromField (PGArray a) where
492instance (FromField a, Typeable a) => FromField (PGArray a) where
530− fromField = pgArrayFieldParser fromField
493+ fromField f mdat = do
531−
532−pgArrayFieldParser :: Typeable a => FieldParser a -> FieldParser (PGArray a)
533−pgArrayFieldParser fieldParser f mdat = do
534 info <- typeInfo f
494 info <- typeInfo f
535 case info of
495 case info of
536 TI.Array{} ->
496 TI.Array{} ->
537 case mdat of
497 case mdat of
538 Nothing -> returnError UnexpectedNull f ""
498 Nothing -> returnError UnexpectedNull f ""
539 Just dat -> do
499 Just dat -> do
540− case parseOnly (fromArray fieldParser info f) dat of
500+ case parseOnly (fromArray info f) dat of
541 Left err -> returnError ConversionFailed f err
501 Left err -> returnError ConversionFailed f err
542 Right conv -> PGArray <$> conv
502 Right conv -> PGArray <$> conv
543 _ -> returnError Incompatible f ""
503 _ -> returnError Incompatible f ""
544
504
505+fromArray :: (FromField a)
545−fromArray :: FieldParser a -> TypeInfo -> Field -> Parser (Conversion [a])
506+ => TypeInfo -> Field -> Parser (Conversion [a])
546−fromArray fieldParser typInfo f = sequence . (parseIt <$>) <$> array delim
507+fromArray typeInfo f = sequence . (parseIt <$>) <$> array delim
547 where
508 where
548− delim = typdelim (typelem typInfo)
509+ delim = typdelim (typelem typeInfo)
549− fElem = f{ typeOid = typoid (typelem typInfo) }
510+ fElem = f{ typeOid = typoid (typelem typeInfo) }
550
511
551 parseIt item =
512 parseIt item =
552− fieldParser f' $ if item == Arrays.Plain "NULL" then Nothing else Just item'
513+ fromField f' $ if item' == "NULL" then Nothing else Just item'
553 where
514 where
554 item' = fmt delim item
515 item' = fmt delim item
555 f' | Arrays.Array _ <- item = f
516 f' | Arrays.Array _ <- item = f
@@ -564,7 +525,7 @@ instance (FromField a, Typeable a) => FromField (IOVector a) where
564-- | uuid
525-- | uuid
565instance FromField UUID where
526instance FromField UUID where
566 fromField f mbs =
527 fromField f mbs =
567− if typeOid f /= TI.uuidOid
528+ if typeOid f /= $(inlineTypoid TI.uuid)
568 then returnError Incompatible f ""
529 then returnError Incompatible f ""
569 else case mbs of
530 else case mbs of
570 Nothing -> returnError UnexpectedNull f ""
531 Nothing -> returnError UnexpectedNull f ""
@@ -573,26 +534,26 @@ instance FromField UUID where
573 Nothing -> returnError ConversionFailed f "Invalid UUID"
534 Nothing -> returnError ConversionFailed f "Invalid UUID"
574 Just uuid -> pure uuid
535 Just uuid -> pure uuid
575
536
576−-- | json, jsonb
537+-- | json
577instance FromField JSON.Value where
538instance FromField JSON.Value where
578− fromField f mbs = parseBS =<< fromFieldJSONByteString f mbs
539+ fromField 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
540+ if typeOid f /= $(inlineTypoid TI.json) && typeOid f /= $(inlineTypoid TI.jsonb)
589 then returnError Incompatible f ""
541 then returnError Incompatible f ""
590 else case mbs of
542 else case mbs of
591 Nothing -> returnError UnexpectedNull f ""
543 Nothing -> returnError UnexpectedNull f ""
592− Just bs -> pure bs
544+ Just bs ->
545+#if MIN_VERSION_aeson(0,6,3)
546+ case JSON.eitherDecodeStrict' bs of
547+#elif MIN_VERSION_bytestring(0,10,0)
548+ case JSON.eitherDecode' $ LB.fromStrict bs of
549+#else
550+ case JSON.eitherDecode' $ LB.fromChunks [bs] of
551+#endif
552+ Left err -> returnError ConversionFailed f err
553+ Right val -> pure val
593
554
594-- | Parse a field to a JSON 'JSON.Value' and convert that into a
555-- | Parse a field to a JSON 'JSON.Value' and convert that into a
595−-- Haskell value using the 'JSON.FromJSON' instance.
556+-- Haskell value using 'JSON.fromJSON'.
596--
557--
597-- This can be used as the default implementation for the 'fromField'
558-- This can be used as the default implementation for the 'fromField'
598-- method for Haskell types that have a JSON representation in
559-- method for Haskell types that have a JSON representation in
@@ -600,23 +561,14 @@ fromFieldJSONByteString f mbs =
600--
561--
601-- The 'Typeable' constraint is required to show more informative
562-- The 'Typeable' constraint is required to show more informative
602-- error messages when parsing fails.
563-- 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@
613fromJSONField :: (JSON.FromJSON a, Typeable a) => FieldParser a
564fromJSONField :: (JSON.FromJSON a, Typeable a) => FieldParser a
614fromJSONField f mbBs = do
565fromJSONField f mbBs = do
615 value <- fromField f mbBs
566 value <- fromField f mbBs
616− case JSON.ifromJSON value of
567+ case JSON.fromJSON value of
617− JSON.IError path err -> returnError ConversionFailed f $
568+ JSON.Error err -> returnError ConversionFailed f $
618− "JSON decoding error: " ++ (JSON.formatError path err)
569+ "JSON decoding error: " ++ err
619− JSON.ISuccess x -> pure x
570+ JSON.Success x -> pure x
571+
620
572
621-- | Compatible with the same set of types as @a@. Note that
573-- | Compatible with the same set of types as @a@. Note that
622-- modifying the 'IORef' does not have any effects outside
574-- modifying the 'IORef' does not have any effects outside
@@ -633,33 +585,20 @@ instance FromField a => FromField (MVar a) where
633type Compat = PQ.Oid -> Bool
585type Compat = PQ.Oid -> Bool
634
586
635okText, okText', okBinary, ok16, ok32, ok64, okInt :: Compat
587okText, okText', okBinary, ok16, ok32, ok64, okInt :: Compat
636−okText = eq TI.nameOid \/ eq TI.textOid \/ eq TI.charOid
588+okText = $( mkCompats [ TI.name, TI.text, TI.char,
637− \/ eq TI.bpcharOid \/ eq TI.varcharOid
589+ TI.bpchar, TI.varchar ] )
638−okText' = eq TI.nameOid \/ eq TI.textOid \/ eq TI.charOid
590+okText' = $( mkCompats [ TI.name, TI.text, TI.char,
639− \/ eq TI.bpcharOid \/ eq TI.varcharOid \/ eq TI.unknownOid
591+ TI.bpchar, TI.varchar, TI.unknown ] )
640−okBinary = eq TI.byteaOid
592+okBinary = (== $( inlineTypoid TI.bytea ))
641−ok16 = eq TI.int2Oid
593+ok16 = (== $( inlineTypoid TI.int2 ))
642−ok32 = eq TI.int2Oid \/ eq TI.int4Oid
594+ok32 = $( mkCompats [TI.int2,TI.int4] )
643−ok64 = eq TI.int2Oid \/ eq TI.int4Oid \/ eq TI.int8Oid
595+ok64 = $( mkCompats [TI.int2,TI.int4,TI.int8] )
644#if WORD_SIZE_IN_BITS < 64
596#if WORD_SIZE_IN_BITS < 64
645okInt = ok32
597okInt = ok32
646#else
598#else
647okInt = ok64
599okInt = ok64
648#endif
600#endif
649
601
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−
663doFromField :: forall a . (Typeable a)
602doFromField :: forall a . (Typeable a)
664 => Field -> Compat -> (ByteString -> Conversion a)
603 => Field -> Compat -> (ByteString -> Conversion a)
665 -> Maybe ByteString -> Conversion a
604 -> Maybe ByteString -> Conversion a
@@ -684,22 +623,10 @@ returnError mkErr f msg = do
684 (show (typeOf (undefined :: a)))
623 (show (typeOf (undefined :: a)))
685 msg
624 msg
686
625
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)
626+atto :: forall a. (Typeable a)
697− => (PQ.Oid -> Bool)
627+ => Compat -> Parser a -> Field -> Maybe ByteString
698− -- ^ Predicate for whether the postgresql type oid is compatible with this parser
628+ -> Conversion a
699− -> Parser a
700− -- ^ An attoparsec parser.
701− -> FieldParser a
702−attoFieldParser types p0 f dat = doFromField f types (go p0) dat
629+atto types p0 f dat = doFromField f types (go p0) dat
703 where
630 where
704 go :: Parser a -> ByteString -> Conversion a
631 go :: Parser a -> ByteString -> Conversion a
705 go p s =
632 go p s =
src/Database/PostgreSQL/Simple/FromRow.hs+6−239
@@ -1,6 +1,4 @@
1−{-# LANGUAGE FlexibleContexts #-}
2−{-# LANGUAGE RecordWildCards, FlexibleInstances, DefaultSignatures #-}
1+{-# LANGUAGE RecordWildCards, FlexibleInstances #-}
3−
4
2
5------------------------------------------------------------------------------
3------------------------------------------------------------------------------
6-- |
4-- |
@@ -29,7 +27,7 @@ module Database.PostgreSQL.Simple.FromRow
29 ) where
27 ) where
30
28
31import Prelude hiding (null)
29import Prelude hiding (null)
32−import Control.Applicative (Applicative(..), (<$>), (<|>), (*>), liftA2)
30+import Control.Applicative (Applicative(..), (<$>), (<|>), (*>))
33import Control.Monad (replicateM, replicateM_)
31import Control.Monad (replicateM, replicateM_)
34import Control.Monad.Trans.State.Strict
32import Control.Monad.Trans.State.Strict
35import Control.Monad.Trans.Reader
33import Control.Monad.Trans.Reader
@@ -47,17 +45,13 @@ import Database.PostgreSQL.Simple.Ok
47import Database.PostgreSQL.Simple.Types ((:.)(..), Null)
45import Database.PostgreSQL.Simple.Types ((:.)(..), Null)
48import Database.PostgreSQL.Simple.TypeInfo
46import Database.PostgreSQL.Simple.TypeInfo
49
47
50−import GHC.Generics
51−
52−
53-- | A collection type that can be converted from a sequence of fields.
48-- | 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.
49-- Instances are provided for tuples up to 10 elements and lists of any length.
55--
50--
56-- Note that instances can be defined outside of postgresql-simple, which is
51-- 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:
52-- often useful. For example, here's an instance for a user-defined pair:
58--
53--
59−-- @
60−-- data User = User { name :: String, fileQuota :: Int }
54+-- @data User = User { name :: String, fileQuota :: Int }
61--
55--
62-- instance 'FromRow' User where
56-- instance 'FromRow' User where
63-- fromRow = User \<$\> 'field' \<*\> 'field'
57-- fromRow = User \<$\> 'field' \<*\> 'field'
@@ -67,32 +61,13 @@ import GHC.Generics
67-- in a single row of the query result. Otherwise, a 'ConversionFailed'
61-- in a single row of the query result. Otherwise, a 'ConversionFailed'
68-- exception will be thrown.
62-- exception will be thrown.
69--
63--
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
64+-- Note that 'field' evaluates it's result to WHNF, so the caveats listed in
88-- mysql-simple and very early versions of postgresql-simple no longer apply.
65-- mysql-simple and very early versions of postgresql-simple no longer apply.
89-- Instead, look at the caveats associated with user-defined implementations
66-- Instead, look at the caveats associated with user-defined implementations
90-- of 'fromField'.
67-- of 'fromField'.
91
68
92class FromRow a where
69class FromRow a where
93 fromRow :: RowParser a
70 fromRow :: RowParser a
94− default fromRow :: (Generic a, GFromRow (Rep a)) => RowParser a
95− fromRow = to <$> gfromRow
96
71
97getvalue :: PQ.Result -> PQ.Row -> PQ.Column -> Maybe ByteString
72getvalue :: PQ.Result -> PQ.Row -> PQ.Column -> Maybe ByteString
98getvalue result row col = unsafeDupablePerformIO (PQ.getvalue' result row col)
73getvalue result row col = unsafeDupablePerformIO (PQ.getvalue' result row col)
@@ -131,8 +106,8 @@ fieldWith fieldP = RP $ do
131 else do
106 else do
132 let !result = rowresult
107 let !result = rowresult
133 !typeOid = unsafeDupablePerformIO (PQ.ftype result column)
108 !typeOid = unsafeDupablePerformIO (PQ.ftype result column)
134− !field' = Field{..}
109+ !field = Field{..}
135− lift (lift (fieldP field' (getvalue result row column)))
110+ lift (lift (fieldP field (getvalue result row column)))
136
111
137field :: FromField a => RowParser a
112field :: FromField a => RowParser a
138field = fieldWith fromField
113field = fieldWith fromField
@@ -255,196 +230,6 @@ instance (FromField a, FromField b, FromField c, FromField d, FromField e,
255 null *> null *> null *> null *> null *> pure Nothing)
230 null *> null *> null *> null *> null *> pure Nothing)
256 <|> (Just <$> fromRow)
231 <|> (Just <$> fromRow)
257
232
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)
447−
448instance FromField a => FromRow [a] where
233instance FromField a => FromRow [a] where
449 fromRow = do
234 fromRow = do
450 n <- numFieldsRemaining
235 n <- numFieldsRemaining
@@ -467,21 +252,3 @@ instance FromField a => FromRow (Maybe (Vector a)) where
467
252
468instance (FromRow a, FromRow b) => FromRow (a :. b) where
253instance (FromRow a, FromRow b) => FromRow (a :. b) where
469 fromRow = (:.) <$> fromRow <*> fromRow
254 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/HStore.hs+2−2
@@ -8,14 +8,14 @@
8--
8--
9-- Parsers and printers for hstore, a extended type bundled with
9-- Parsers and printers for hstore, a extended type bundled with
10-- PostgreSQL providing finite maps from text strings to text strings.
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
11+-- See <http://www.postgresql.org/docs/9.2/static/hstore.html> for more
12-- information.
12-- information.
13--
13--
14-- Note that in order to use this type, a database superuser must
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
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
16-- can be done on PostgreSQL 9.1 and later with the command
17-- @CREATE EXTENSION hstore@. See
17-- @CREATE EXTENSION hstore@. See
18−-- <https://www.postgresql.org/docs/9.5/static/contrib.html> for more
18+-- <http://www.postgresql.org/docs/9.2/static/contrib.html> for more
19-- information.
19-- information.
20--
20--
21------------------------------------------------------------------------------
21------------------------------------------------------------------------------
src/Database/PostgreSQL/Simple/HStore/Implementation.hs+21−20
@@ -15,13 +15,17 @@
15module Database.PostgreSQL.Simple.HStore.Implementation where
15module Database.PostgreSQL.Simple.HStore.Implementation where
16
16
17import Control.Applicative
17import Control.Applicative
18+import Blaze.ByteString.Builder as Blaze
19+ ( Builder, toLazyByteString, copyByteString )
20+import Blaze.ByteString.Builder.Char8 (fromChar)
18import qualified Data.Attoparsec.ByteString as P
21import qualified Data.Attoparsec.ByteString as P
19import qualified Data.Attoparsec.ByteString.Char8 as P (isSpace_w8)
22import qualified Data.Attoparsec.ByteString.Char8 as P (isSpace_w8)
20import qualified Data.ByteString as BS
23import qualified Data.ByteString as BS
21−import Data.ByteString.Builder (Builder, byteString, char8)
22−import qualified Data.ByteString.Builder as BU
23import Data.ByteString.Internal (c2w, w2c)
24import Data.ByteString.Internal (c2w, w2c)
24import qualified Data.ByteString.Lazy as BL
25import qualified Data.ByteString.Lazy as BL
26+#if !MIN_VERSION_bytestring(0,10,0)
27+import qualified Data.ByteString.Lazy.Internal as BL (foldrChunks)
28+#endif
25import Data.Map(Map)
29import Data.Map(Map)
26import qualified Data.Map as Map
30import qualified Data.Map as Map
27import Data.Text(Text)
31import Data.Text(Text)
@@ -31,7 +35,6 @@ import Data.Text.Encoding.Error(UnicodeException)
31import qualified Data.Text.Lazy as TL
35import qualified Data.Text.Lazy as TL
32import Data.Typeable
36import Data.Typeable
33import Data.Monoid(Monoid(..))
37import Data.Monoid(Monoid(..))
34−import Data.Semigroup
35import Database.PostgreSQL.Simple.FromField
38import Database.PostgreSQL.Simple.FromField
36import Database.PostgreSQL.Simple.ToField
39import Database.PostgreSQL.Simple.ToField
37
40
@@ -50,28 +53,26 @@ instance ToHStore HStoreBuilder where
50toBuilder :: HStoreBuilder -> Builder
53toBuilder :: HStoreBuilder -> Builder
51toBuilder x = case x of
54toBuilder x = case x of
52 Empty -> mempty
55 Empty -> mempty
53− Comma c -> c
56+ Comma x -> x
54
57
55toLazyByteString :: HStoreBuilder -> BL.ByteString
58toLazyByteString :: HStoreBuilder -> BL.ByteString
56toLazyByteString x = case x of
59toLazyByteString x = case x of
57 Empty -> BL.empty
60 Empty -> BL.empty
58− Comma c -> BU.toLazyByteString c
61+ Comma x -> Blaze.toLazyByteString x
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
62
67instance Monoid HStoreBuilder where
63instance Monoid HStoreBuilder where
68 mempty = Empty
64 mempty = Empty
65+ mappend Empty x = x
66+ mappend (Comma a) x
67+ = Comma (a `mappend` case x of
68+ Empty -> mempty
69+ Comma b -> fromChar ',' `mappend` b)
69
70
70class ToHStoreText a where
71class ToHStoreText a where
71 toHStoreText :: a -> HStoreText
72 toHStoreText :: a -> HStoreText
72
73
73-- | Represents escape text, ready to be the key or value to a hstore value
74-- | Represents escape text, ready to be the key or value to a hstore value
74−newtype HStoreText = HStoreText Builder deriving (Typeable, Semigroup, Monoid)
75+newtype HStoreText = HStoreText Builder deriving (Typeable, Monoid)
75
76
76instance ToHStoreText HStoreText where
77instance ToHStoreText HStoreText where
77 toHStoreText = id
78 toHStoreText = id
@@ -94,24 +95,24 @@ escapeAppend :: BS.ByteString -> Builder -> Builder
94escapeAppend = loop
95escapeAppend = loop
95 where
96 where
96 loop (BS.break quoteNeeded -> (a,b)) rest
97 loop (BS.break quoteNeeded -> (a,b)) rest
97− = byteString a `mappend`
98+ = copyByteString a `mappend`
98 case BS.uncons b of
99 case BS.uncons b of
99 Nothing -> rest
100 Nothing -> rest
100 Just (c,d) -> quoteChar c `mappend` loop d rest
101 Just (c,d) -> quoteChar c `mappend` loop d rest
101
102
102 quoteNeeded c = c == c2w '\"' || c == c2w '\\'
103 quoteNeeded c = c == c2w '\"' || c == c2w '\\'
103 quoteChar c
104 quoteChar c
104− | c == c2w '\"' = byteString "\\\""
105+ | c == c2w '\"' = copyByteString "\\\""
105− | otherwise = byteString "\\\\"
106+ | otherwise = copyByteString "\\\\"
106
107
107hstore :: (ToHStoreText a, ToHStoreText b) => a -> b -> HStoreBuilder
108hstore :: (ToHStoreText a, ToHStoreText b) => a -> b -> HStoreBuilder
108hstore (toHStoreText -> (HStoreText key)) (toHStoreText -> (HStoreText val)) =
109hstore (toHStoreText -> (HStoreText key)) (toHStoreText -> (HStoreText val)) =
109− Comma (char8 '"' `mappend` key `mappend` byteString "\"=>\""
110+ Comma (fromChar '"' `mappend` key `mappend` copyByteString "\"=>\""
110− `mappend` val `mappend` char8 '"')
111+ `mappend` val `mappend` fromChar '"')
111
112
112instance ToField HStoreBuilder where
113instance ToField HStoreBuilder where
113 toField Empty = toField (BS.empty)
114 toField Empty = toField (BS.empty)
114− toField (Comma x) = toField (BU.toLazyByteString x)
115+ toField (Comma x) = toField (Blaze.toLazyByteString x)
115
116
116newtype HStoreList = HStoreList {fromHStoreList :: [(Text,Text)]} deriving (Typeable, Show)
117newtype HStoreList = HStoreList {fromHStoreList :: [(Text,Text)]} deriving (Typeable, Show)
117
118
@@ -144,7 +145,7 @@ newtype HStoreMap = HStoreMap {fromHStoreMap :: Map Text Text} deriving (Eq, Or
144
145
145instance ToHStore HStoreMap where
146instance ToHStore HStoreMap where
146 toHStore (HStoreMap xs) = Map.foldrWithKey f mempty xs
147 toHStore (HStoreMap xs) = Map.foldrWithKey f mempty xs
147− where f k v xs' = hstore k v `mappend` xs'
148+ where f k v xs = hstore k v `mappend` xs
148
149
149instance ToField HStoreMap where
150instance ToField HStoreMap where
150 toField xs = toField (toHStore xs)
151 toField xs = toField (toHStore xs)
src/Database/PostgreSQL/Simple/HStore/Internal.hs+2
@@ -1,3 +1,5 @@
1+{-# OPTIONS_HADDOCK hide #-}
2+
1------------------------------------------------------------------------------
3------------------------------------------------------------------------------
2-- |
4-- |
3-- Module: Database.PostgreSQL.Simple.HStore.Internal
5-- Module: Database.PostgreSQL.Simple.HStore.Internal
src/Database/PostgreSQL/Simple/Internal.hs+23−167
@@ -1,13 +1,10 @@
1{-# LANGUAGE CPP, BangPatterns, DoAndIfThenElse, RecordWildCards #-}
1{-# LANGUAGE CPP, BangPatterns, DoAndIfThenElse, RecordWildCards #-}
2−{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}
3−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2+{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
4−{-# LANGUAGE ExistentialQuantification #-}
5−{-# LANGUAGE InstanceSigs #-}
6
3
7------------------------------------------------------------------------------
4------------------------------------------------------------------------------
8-- |
5-- |
9-- Module: Database.PostgreSQL.Simple.Internal
6-- Module: Database.PostgreSQL.Simple.Internal
10−-- Copyright: (c) 2011-2015 Leon P Smith
7+-- Copyright: (c) 2011-2012 Leon P Smith
11-- License: BSD3
8-- License: BSD3
12-- Maintainer: Leon P Smith <leon@melding-monads.com>
9-- Maintainer: Leon P Smith <leon@melding-monads.com>
13-- Stability: experimental
10-- Stability: experimental
@@ -28,31 +25,24 @@ import Control.Exception
28import Control.Concurrent.MVar
25import Control.Concurrent.MVar
29import Control.Monad(MonadPlus(..))
26import Control.Monad(MonadPlus(..))
30import Data.ByteString(ByteString)
27import Data.ByteString(ByteString)
31−import qualified Data.ByteString as B
32import qualified Data.ByteString.Char8 as B8
28import qualified Data.ByteString.Char8 as B8
33−import Data.ByteString.Builder ( Builder, byteString )
34import Data.Char (ord)
29import Data.Char (ord)
35import Data.Int (Int64)
30import Data.Int (Int64)
36import qualified Data.IntMap as IntMap
31import qualified Data.IntMap as IntMap
37import Data.IORef
32import Data.IORef
38import Data.Maybe(fromMaybe)
33import Data.Maybe(fromMaybe)
39import Data.String
34import Data.String
40−import qualified Data.Text as T
41−import qualified Data.Text.Encoding as TE
42import Data.Typeable
35import Data.Typeable
43import Data.Word
36import Data.Word
44import Database.PostgreSQL.LibPQ(Oid(..))
37import Database.PostgreSQL.LibPQ(Oid(..))
45import qualified Database.PostgreSQL.LibPQ as PQ
38import qualified Database.PostgreSQL.LibPQ as PQ
46import Database.PostgreSQL.LibPQ(ExecStatus(..))
39import Database.PostgreSQL.LibPQ(ExecStatus(..))
47−import Database.PostgreSQL.Simple.Compat ( toByteString )
48import Database.PostgreSQL.Simple.Ok
40import Database.PostgreSQL.Simple.Ok
49−import Database.PostgreSQL.Simple.ToField (Action(..), inQuotes)
50import Database.PostgreSQL.Simple.Types (Query(..))
41import Database.PostgreSQL.Simple.Types (Query(..))
51import Database.PostgreSQL.Simple.TypeInfo.Types(TypeInfo)
42import Database.PostgreSQL.Simple.TypeInfo.Types(TypeInfo)
52import Control.Monad.Trans.State.Strict
43import Control.Monad.Trans.State.Strict
53import Control.Monad.Trans.Reader
44import Control.Monad.Trans.Reader
54import Control.Monad.Trans.Class
45import Control.Monad.Trans.Class
55−import GHC.Generics
56import GHC.IO.Exception
46import GHC.IO.Exception
57#if !defined(mingw32_HOST_OS)
47#if !defined(mingw32_HOST_OS)
58import Control.Concurrent(threadWaitRead, threadWaitWrite)
48import Control.Concurrent(threadWaitRead, threadWaitWrite)
@@ -78,29 +68,7 @@ data Connection = Connection {
78 connectionHandle :: {-# UNPACK #-} !(MVar PQ.Connection)
68 connectionHandle :: {-# UNPACK #-} !(MVar PQ.Connection)
79 , connectionObjects :: {-# UNPACK #-} !(MVar TypeInfoCache)
69 , connectionObjects :: {-# UNPACK #-} !(MVar TypeInfoCache)
80 , connectionTempNameCounter :: {-# UNPACK #-} !(IORef Int64)
70 , connectionTempNameCounter :: {-# UNPACK #-} !(IORef Int64)
81− } deriving (Typeable)
71+ }
82−
83−instance Eq Connection where
84− x == y = connectionHandle x == connectionHandle y
85−
86−-- | Superclass for postgresql exceptions
87−data SomePostgreSqlException = forall e. Exception e => SomePostgreSqlException e
88− deriving Typeable
89−
90−postgresqlExceptionToException :: Exception e => e -> SomeException
91−postgresqlExceptionToException = toException . SomePostgreSqlException
92−
93−postgresqlExceptionFromException :: Exception e => SomeException -> Maybe e
94−postgresqlExceptionFromException x = do
95− SomePostgreSqlException a <- fromException x
96− cast a
97−
98−instance Show SomePostgreSqlException where
99− showsPrec :: Int -> SomePostgreSqlException -> ShowS
100− showsPrec p (SomePostgreSqlException e) = showsPrec p e
101−
102−instance Exception SomePostgreSqlException where
103− displayException (SomePostgreSqlException e) = displayException e
104
72
105data SqlError = SqlError {
73data SqlError = SqlError {
106 sqlState :: ByteString
74 sqlState :: ByteString
@@ -108,15 +76,12 @@ data SqlError = SqlError {
108 , sqlErrorMsg :: ByteString
76 , sqlErrorMsg :: ByteString
109 , sqlErrorDetail :: ByteString
77 , sqlErrorDetail :: ByteString
110 , sqlErrorHint :: ByteString
78 , sqlErrorHint :: ByteString
111− } deriving (Eq, Show, Typeable)
79+ } deriving (Show, Typeable)
112
80
113fatalError :: ByteString -> SqlError
81fatalError :: ByteString -> SqlError
114fatalError msg = SqlError "" FatalError msg "" ""
82fatalError msg = SqlError "" FatalError msg "" ""
115
83
116−instance Exception SqlError where
84+instance Exception SqlError
117− toException = postgresqlExceptionToException
118− fromException = postgresqlExceptionFromException
119−
120
85
121-- | Exception thrown if 'query' is used to perform an @INSERT@-like
86-- | Exception thrown if 'query' is used to perform an @INSERT@-like
122-- operation, or 'execute' is used to perform a @SELECT@-like operation.
87-- operation, or 'execute' is used to perform a @SELECT@-like operation.
@@ -125,22 +90,7 @@ data QueryError = QueryError {
125 , qeQuery :: Query
90 , qeQuery :: Query
126 } deriving (Eq, Show, Typeable)
91 } deriving (Eq, Show, Typeable)
127
92
128−instance Exception QueryError where
93+instance Exception QueryError
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
144
94
145data ConnectInfo = ConnectInfo {
95data ConnectInfo = ConnectInfo {
146 connectHost :: String
96 connectHost :: String
@@ -148,7 +98,7 @@ data ConnectInfo = ConnectInfo {
148 , connectUser :: String
98 , connectUser :: String
149 , connectPassword :: String
99 , connectPassword :: String
150 , connectDatabase :: String
100 , connectDatabase :: String
151− } deriving (Generic,Eq,Read,Show,Typeable)
101+ } deriving (Eq,Read,Show,Typeable)
152
102
153-- | Default information for setting up a connection.
103-- | Default information for setting up a connection.
154--
104--
@@ -182,20 +132,10 @@ defaultConnectInfo = ConnectInfo {
182connect :: ConnectInfo -> IO Connection
132connect :: ConnectInfo -> IO Connection
183connect = connectPostgreSQL . postgreSQLConnectionString
133connect = connectPostgreSQL . postgreSQLConnectionString
184
134
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−
191-- | Attempt to make a connection based on a libpq connection string.
135-- | 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>
136+-- See <http://www.postgresql.org/docs/9.3/static/libpq-connect.html>
193−-- for more information. Also note that environment variables also affect
137+-- for more information. Here is an example with some
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
138+-- of the most commonly used parameters:
198−-- parameters:
199--
139--
200-- > host='db.somedomain.com' port=5432 ...
140-- > host='db.somedomain.com' port=5432 ...
201--
141--
@@ -223,9 +163,8 @@ withConnect connInfo = bracket (connect connInfo) close
223--
163--
224-- Omitting @password@ will default to an appropriate password found
164-- Omitting @password@ will default to an appropriate password found
225-- in the @pgpass@ file, or no password at all if a matching line is
165-- 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
166+-- not found. See
227−-- the @PGPASSFILE@ environment variable. See
228−-- <https://www.postgresql.org/docs/9.5/static/libpq-pgpass.html> for
167+-- <http://www.postgresql.org/docs/9.3/static/libpq-pgpass.html> for
229-- more information regarding this file.
168-- more information regarding this file.
230--
169--
231-- As all parameters are optional and the defaults are sensible, the
170-- As all parameters are optional and the defaults are sensible, the
@@ -243,20 +182,8 @@ withConnect connInfo = bracket (connect connInfo) close
243-- or production machines, or you will need to use a @pgpass@ file
182-- or production machines, or you will need to use a @pgpass@ file
244-- with the @password@ or @md5@ authentication methods.
183-- with the @password@ or @md5@ authentication methods.
245--
184--
246−-- See <https://www.postgresql.org/docs/9.5/static/client-authentication.html>
185+-- See <http://www.postgresql.org/docs/9.3/static/client-authentication.html>
247-- for more information regarding the authentication process.
186-- 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.
260
187
261connectPostgreSQL :: ByteString -> IO Connection
188connectPostgreSQL :: ByteString -> IO Connection
262connectPostgreSQL connstr = do
189connectPostgreSQL connstr = do
@@ -270,8 +197,8 @@ connectPostgreSQL connstr = do
270 let wconn = Connection{..}
197 let wconn = Connection{..}
271 version <- PQ.serverVersion conn
198 version <- PQ.serverVersion conn
272 let settings
199 let settings
273− | version < 80200 = "SET datestyle TO ISO;SET client_encoding TO UTF8"
200+ | version < 80200 = "SET datestyle TO ISO"
274− | otherwise = "SET datestyle TO ISO;SET client_encoding TO UTF8;SET standard_conforming_strings TO on"
201+ | otherwise = "SET standard_conforming_strings TO on;SET datestyle TO ISO"
275 _ <- execute_ wconn settings
202 _ <- execute_ wconn settings
276 return wconn
203 return wconn
277 _ -> do
204 _ -> do
@@ -323,7 +250,7 @@ postgreSQLConnectionString connectInfo = fromString connstr
323
250
324 str name field
251 str name field
325 | null value = id
252 | null value = id
326− | otherwise = showString name . addQuotes value . space
253+ | otherwise = showString name . quote value . space
327 where value = field connectInfo
254 where value = field connectInfo
328
255
329 num name field
256 num name field
@@ -331,7 +258,7 @@ postgreSQLConnectionString connectInfo = fromString connstr
331 | otherwise = showString name . shows value . space
258 | otherwise = showString name . shows value . space
332 where value = field connectInfo
259 where value = field connectInfo
333
260
334− addQuotes s rest = '\'' : foldr delta ('\'' : rest) s
261+ quote str rest = '\'' : foldr delta ('\'' : rest) str
335 where
262 where
336 delta c cs = case c of
263 delta c cs = case c of
337 '\\' -> '\\' : '\\' : cs
264 '\\' -> '\\' : '\\' : cs
@@ -387,7 +314,6 @@ exec conn sql =
387 Just res -> do
314 Just res -> do
388 status <- PQ.resultStatus res
315 status <- PQ.resultStatus res
389 case status of
316 case status of
390− -- FIXME: handle PQ.CopyBoth and PQ.SingleTuple
391 PQ.EmptyQuery -> getResult h mres'
317 PQ.EmptyQuery -> getResult h mres'
392 PQ.CommandOk -> getResult h mres'
318 PQ.CommandOk -> getResult h mres'
393 PQ.TuplesOk -> getResult h mres'
319 PQ.TuplesOk -> getResult h mres'
@@ -408,7 +334,6 @@ finishExecute :: Connection -> Query -> PQ.Result -> IO Int64
408finishExecute _conn q result = do
334finishExecute _conn q result = do
409 status <- PQ.resultStatus result
335 status <- PQ.resultStatus result
410 case status of
336 case status of
411− -- FIXME: handle PQ.CopyBoth and PQ.SingleTuple
412 PQ.EmptyQuery -> throwIO $ QueryError "execute: Empty query" q
337 PQ.EmptyQuery -> throwIO $ QueryError "execute: Empty query" q
413 PQ.CommandOk -> do
338 PQ.CommandOk -> do
414 ncols <- PQ.nfields result
339 ncols <- PQ.nfields result
@@ -419,7 +344,7 @@ finishExecute _conn q result = do
419 nstr <- PQ.cmdTuples result
344 nstr <- PQ.cmdTuples result
420 return $ case nstr of
345 return $ case nstr of
421 Nothing -> 0 -- is this appropriate?
346 Nothing -> 0 -- is this appropriate?
422− Just str -> mkInteger str
347+ Just str -> toInteger str
423 PQ.TuplesOk -> do
348 PQ.TuplesOk -> do
424 ncols <- PQ.nfields result
349 ncols <- PQ.nfields result
425 throwIO $ QueryError ("execute resulted in " ++ show ncols ++
350 throwIO $ QueryError ("execute resulted in " ++ show ncols ++
@@ -432,7 +357,7 @@ finishExecute _conn q result = do
432 PQ.NonfatalError -> throwResultError "execute" result status
357 PQ.NonfatalError -> throwResultError "execute" result status
433 PQ.FatalError -> throwResultError "execute" result status
358 PQ.FatalError -> throwResultError "execute" result status
434 where
359 where
435− mkInteger str = B8.foldl' delta 0 str
360+ toInteger str = B8.foldl' delta 0 str
436 where
361 where
437 delta acc c =
362 delta acc c =
438 if '0' <= c && c <= '9'
363 if '0' <= c && c <= '9'
@@ -447,8 +372,8 @@ throwResultError _ result status = do
447 PQ.resultErrorField result PQ.DiagMessageDetail
372 PQ.resultErrorField result PQ.DiagMessageDetail
448 hint <- fromMaybe "" <$>
373 hint <- fromMaybe "" <$>
449 PQ.resultErrorField result PQ.DiagMessageHint
374 PQ.resultErrorField result PQ.DiagMessageHint
450− state' <- maybe "" id <$> PQ.resultErrorField result PQ.DiagSqlstate
375+ state <- maybe "" id <$> PQ.resultErrorField result PQ.DiagSqlstate
451− throwIO $ SqlError { sqlState = state'
376+ throwIO $ SqlError { sqlState = state
452 , sqlExecStatus = status
377 , sqlExecStatus = status
453 , sqlErrorMsg = errormsg
378 , sqlErrorMsg = errormsg
454 , sqlErrorDetail = detail
379 , sqlErrorDetail = detail
@@ -517,6 +442,7 @@ instance Alternative Conversion where
517 Errors _ -> (oka <|>) <$> runConversion mb conn
442 Errors _ -> (oka <|>) <$> runConversion mb conn
518
443
519instance Monad Conversion where
444instance Monad Conversion where
445+ return a = Conversion $ \_conn -> return (return a)
520 m >>= f = Conversion $ \conn -> do
446 m >>= f = Conversion $ \conn -> do
521 oka <- runConversion m conn
447 oka <- runConversion m conn
522 case oka of
448 case oka of
@@ -531,7 +457,7 @@ conversionMap :: (Ok a -> Ok b) -> Conversion a -> Conversion b
531conversionMap f m = Conversion $ \conn -> f <$> runConversion m conn
457conversionMap f m = Conversion $ \conn -> f <$> runConversion m conn
532
458
533conversionError :: Exception err => err -> Conversion a
459conversionError :: Exception err => err -> Conversion a
534−conversionError err = Conversion $ \_ -> return (Errors [toException err])
460+conversionError err = Conversion $ \_ -> return (Errors [SomeException err])
535
461
536newTempName :: Connection -> IO Query
462newTempName :: Connection -> IO Query
537newTempName Connection{..} = do
463newTempName Connection{..} = do
@@ -565,73 +491,3 @@ throwLibPQError :: PQ.Connection -> ByteString -> IO a
565throwLibPQError conn default_desc = do
491throwLibPQError conn default_desc = do
566 msg <- maybe default_desc id <$> PQ.errorMessage conn
492 msg <- maybe default_desc id <$> PQ.errorMessage conn
567 throwIO $! libPQError msg
493 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
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+2−2
@@ -7,14 +7,14 @@
7-- Maintainer : leon@melding-monads.com
7-- Maintainer : leon@melding-monads.com
8--
8--
9-- Support for PostgreSQL's Large Objects; see
9-- Support for PostgreSQL's Large Objects; see
10−-- <https://www.postgresql.org/docs/9.5/static/largeobjects.html> for more
10+-- <http://www.postgresql.org/docs/9.1/static/largeobjects.html> for more
11-- information.
11-- information.
12--
12--
13-- Note that Large Object File Descriptors are only valid within a single
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
14-- database transaction, so if you are interested in using anything beyond
15-- 'loCreat', 'loCreate', and 'loUnlink', you will need to run the entire
15-- 'loCreat', 'loCreate', and 'loUnlink', you will need to run the entire
16-- sequence of functions in a transaction. As 'loImport' and 'loExport'
16-- sequence of functions in a transaction. As 'loImport' and 'loExport'
17−-- are simply C functions that call 'loCreat', 'loOpen', 'loRead', and
17+-- are simply C functions that call 'loCreat', 'loOpen', 'loRead', and
18-- 'loWrite', and do not perform any transaction handling themselves,
18-- 'loWrite', and do not perform any transaction handling themselves,
19-- they also need to be wrapped in an explicit transaction.
19-- they also need to be wrapped in an explicit transaction.
20--
20--
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+32−62
@@ -5,8 +5,7 @@
5-----------------------------------------------------------------------------
5-----------------------------------------------------------------------------
6-- |
6-- |
7-- Module : Database.PostgreSQL.Simple.Notification
7-- Module : Database.PostgreSQL.Simple.Notification
8−-- Copyright : (c) 2011-2015 Leon P Smith
8+-- Copyright : (c) 2011-2012 Leon P Smith
9−-- (c) 2012 Joey Adams
10-- License : BSD3
9-- License : BSD3
11--
10--
12-- Maintainer : leon@melding-monads.com
11-- Maintainer : leon@melding-monads.com
@@ -14,7 +13,7 @@
14--
13--
15-- Support for receiving asynchronous notifications via PostgreSQL's
14-- Support for receiving asynchronous notifications via PostgreSQL's
16-- Listen/Notify mechanism. See
15-- Listen/Notify mechanism. See
17−-- <https://www.postgresql.org/docs/9.5/static/sql-notify.html> for more
16+-- <http://www.postgresql.org/docs/9.1/static/sql-notify.html> for more
18-- information.
17-- information.
19--
18--
20-- Note that on Windows, @getNotification@ currently uses a polling loop
19-- Note that on Windows, @getNotification@ currently uses a polling loop
@@ -25,7 +24,7 @@
25-- Notifications do not create any extra work for the backend, and are
24-- Notifications do not create any extra work for the backend, and are
26-- likely cheaper on the client side as well.
25-- likely cheaper on the client side as well.
27--
26--
28−-- <https://hackage.haskell.org/trac/ghc/ticket/7353>
27+-- <http://hackage.haskell.org/trac/ghc/ticket/7353>
29--
28--
30-----------------------------------------------------------------------------
29-----------------------------------------------------------------------------
31
30
@@ -36,27 +35,19 @@ module Database.PostgreSQL.Simple.Notification
36 , getBackendPID
35 , getBackendPID
37 ) where
36 ) where
38
37
39−import Control.Monad ( join, void )
38+import Control.Concurrent
39+import Control.Monad ( when )
40−import Control.Exception ( throwIO, catch )
40+import Control.Exception ( throwIO )
41import qualified Data.ByteString as B
41import qualified Data.ByteString as B
42−import qualified Data.ByteString.Char8 as B8
43import Database.PostgreSQL.Simple.Internal
42import Database.PostgreSQL.Simple.Internal
44import qualified Database.PostgreSQL.LibPQ as PQ
43import qualified Database.PostgreSQL.LibPQ as PQ
45import System.Posix.Types ( CPid )
44import 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
54
45
55data Notification = Notification
46data Notification = Notification
56− { notificationPid :: {-# UNPACK #-} !CPid
47+ { notificationPid :: !CPid
57− , notificationChannel :: {-# UNPACK #-} !B.ByteString
48+ , notificationChannel :: !B.ByteString
58− , notificationData :: {-# UNPACK #-} !B.ByteString
49+ , notificationData :: !B.ByteString
59− } deriving (Show, Eq)
50+ }
60
51
61convertNotice :: PQ.Notify -> Notification
52convertNotice :: PQ.Notify -> Notification
62convertNotice PQ.Notify{..}
53convertNotice PQ.Notify{..}
@@ -66,56 +57,35 @@ convertNotice PQ.Notify{..}
66
57
67-- | Returns a single notification. If no notifications are available,
58-- | Returns a single notification. If no notifications are available,
68-- 'getNotification' blocks until one arrives.
59-- '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.
73
60
74getNotification :: Connection -> IO Notification
61getNotification :: Connection -> IO Notification
75−getNotification conn = join $ withConnection conn fetch
62+getNotification conn = loop False
76 where
63 where
77 funcName = "Database.PostgreSQL.Simple.Notification.getNotification"
64 funcName = "Database.PostgreSQL.Simple.Notification.getNotification"
78−
65+ loop doConsume = do
79− fetch c = do
66+ res <- withConnection conn $ \c -> do
67+ when doConsume (PQ.consumeInput c >> return ())
80− mmsg <- PQ.notifies c
68+ mmsg <- PQ.notifies c
81− case mmsg of
69+ case mmsg of
82− Just msg -> return (return $! convertNotice msg)
83− Nothing -> do
70+ Nothing -> do
84− mfd <- PQ.socket c
71+ mfd <- PQ.socket c
85− case mfd of
72+ case mfd of
86− Nothing -> return (throwIO $! fdError funcName)
73+ Nothing -> throwIO $ fdError funcName
74+ Just fd -> return (Left fd)
75+ Just msg -> return (Right msg)
76+ -- FIXME? what happens if the connection is closed/reset right here?
77+ case res of
87#if defined(mingw32_HOST_OS)
78#if defined(mingw32_HOST_OS)
88− -- threadWaitRead doesn't work for sockets on Windows, so just
79+ -- threadWaitRead doesn't work for sockets on Windows, so just poll
89− -- poll for input every second (PQconsumeInput is non-blocking).
80+ -- for input every second (PQconsumeInput is non-blocking).
90− --
81+ --
91− -- We could call select(), but FFI calls can't be interrupted
82+ -- We could call select(), but FFI calls can't be interrupted with
92− -- with async exceptions, whereas threadDelay can.
83+ -- async exceptions, whereas threadDelay can.
93− Just _fd -> do
94− return (threadDelay 1000000 >> loop)
84+ Left _fd -> threadDelay 1000000 >> loop True
95#else
85#else
96− -- This case fixes the race condition above. By registering
86+ Left fd -> threadWaitRead fd >> loop True
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
87#endif
111−
88+ Right msg -> return $! convertNotice msg
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
89
120-- | Non-blocking variant of 'getNotification'. Returns a single notification,
90-- | Non-blocking variant of 'getNotification'. Returns a single notification,
121-- if available. If no notifications are available, returns 'Nothing'.
91-- if available. If no notifications are available, returns 'Nothing'.
src/Database/PostgreSQL/Simple/Ok.hs+4−10
@@ -1,11 +1,10 @@
1{-# LANGUAGE DeriveDataTypeable #-}
1{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE DeriveFunctor #-}
2{-# LANGUAGE DeriveFunctor #-}
3−{-# LANGUAGE CPP #-}
4
3
5------------------------------------------------------------------------------
4------------------------------------------------------------------------------
6-- |
5-- |
7-- Module : Database.PostgreSQL.Simple.Ok
6-- Module : Database.PostgreSQL.Simple.Ok
8−-- Copyright : (c) 2012-2015 Leon P Smith
7+-- Copyright : (c) 2012 Leon P Smith
9-- License : BSD3
8-- License : BSD3
10--
9--
11-- Maintainer : leon@melding-monads.com
10-- Maintainer : leon@melding-monads.com
@@ -21,7 +20,7 @@
21-- commonly-used type and typeclass included in @base@.
20-- commonly-used type and typeclass included in @base@.
22--
21--
23-- Extending the failure case to a list of 'SomeException's enables a
22-- Extending the failure case to a list of 'SomeException's enables a
24−-- more sensible 'Alternative' instance definitions: '<|>' concatenates
23+-- more sensible 'Alternative' instance definitions: '<|>' concatinates
25-- the list of exceptions when both cases fail, and 'empty' is defined as
24-- the list of exceptions when both cases fail, and 'empty' is defined as
26-- 'Errors []'. Though '<|>' one could pick one of two exceptions, and
25-- 'Errors []'. Though '<|>' one could pick one of two exceptions, and
27-- throw away the other, and have 'empty' provide a generic exception,
26-- throw away the other, and have 'empty' provide a generic exception,
@@ -37,8 +36,6 @@ import Control.Exception
37import Control.Monad(MonadPlus(..))
36import Control.Monad(MonadPlus(..))
38import Data.Typeable
37import Data.Typeable
39
38
40−import qualified Control.Monad.Fail as Fail
41−
42-- FIXME: [SomeException] should probably be something else, maybe
39-- FIXME: [SomeException] should probably be something else, maybe
43-- a difference list (or a tree?)
40-- a difference list (or a tree?)
44
41
@@ -72,14 +69,11 @@ instance MonadPlus Ok where
72 mplus = (<|>)
69 mplus = (<|>)
73
70
74instance Monad Ok where
71instance Monad Ok where
72+ return = Ok
73+
75 Errors es >>= _ = Errors es
74 Errors es >>= _ = Errors es
76 Ok a >>= f = f a
75 Ok a >>= f = f a
77
76
78−#if !(MIN_VERSION_base(4,13,0))
79− fail = Fail.fail
80−#endif
81−
82−instance Fail.MonadFail Ok where
83 fail str = Errors [SomeException (ErrorCall str)]
77 fail str = Errors [SomeException (ErrorCall str)]
84
78
85-- | a way to reify a list of exceptions into a single exception
79-- | a way to reify a list of exceptions into a single exception
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+14−17
@@ -1,9 +1,3 @@
1−{-# LANGUAGE CPP #-}
2−#if __GLASGOW_HASKELL__ >= 800
3−{-# LANGUAGE TemplateHaskellQuotes #-}
4−#else
5−{-# LANGUAGE TemplateHaskell #-}
6−#endif
7------------------------------------------------------------------------------
1------------------------------------------------------------------------------
8-- |
2-- |
9-- Module: Database.PostgreSQL.Simple.SqlQQ
3-- Module: Database.PostgreSQL.Simple.SqlQQ
@@ -15,11 +9,10 @@
15------------------------------------------------------------------------------
9------------------------------------------------------------------------------
16
10
17module Database.PostgreSQL.Simple.SqlQQ (sql) where
11module Database.PostgreSQL.Simple.SqlQQ (sql) where
18−import Database.PostgreSQL.Simple.Types (Query)
12+
19import Language.Haskell.TH
13import Language.Haskell.TH
20import Language.Haskell.TH.Quote
14import Language.Haskell.TH.Quote
21import Data.Char
15import Data.Char
22−import Data.String
23
16
24-- | 'sql' is a quasiquoter that eases the syntactic burden
17-- | 'sql' is a quasiquoter that eases the syntactic burden
25-- of writing big sql statements in Haskell source code. For example:
18-- of writing big sql statements in Haskell source code. For example:
@@ -34,10 +27,10 @@ import Data.String
34-- > LIMIT 100 |]
27-- > LIMIT 100 |]
35-- > (beginTime,endTime,string)
28-- > (beginTime,endTime,string)
36--
29--
37−-- This quasiquoter returns a literal string expression of type 'Query',
38−-- and attempts to minimize whitespace; otherwise the above query would
30+-- This quasiquoter attempts to mimimize whitespace; otherwise the
39−-- consist of approximately half whitespace when sent to the database
31+-- above query would consist of approximately half whitespace when sent
40−-- backend. It also recognizes and strips out standard sql comments "--".
32+-- to the database backend. It also recognizes and strips out standard
33+-- sql comments "--".
41--
34--
42-- The implementation of the whitespace reducer is currently incomplete.
35-- The implementation of the whitespace reducer is currently incomplete.
43-- Thus it can mess up your syntax in cases where whitespace should be
36-- Thus it can mess up your syntax in cases where whitespace should be
@@ -57,14 +50,17 @@ import Data.String
57
50
58sql :: QuasiQuoter
51sql :: QuasiQuoter
59sql = QuasiQuoter
52sql = QuasiQuoter
60− { quotePat = error "Database.PostgreSQL.Simple.SqlQQ.sql: quasiquoter used in pattern context"
53+ { quotePat = error "Database.PostgreSQL.Simple.SqlQQ.sql:\
54+ \ quasiquoter used in pattern context"
61− , quoteType = error "Database.PostgreSQL.Simple.SqlQQ.sql: quasiquoter used in type context"
55+ , quoteType = error "Database.PostgreSQL.Simple.SqlQQ.sql:\
56+ \ quasiquoter used in type context"
62 , quoteExp = sqlExp
57 , quoteExp = sqlExp
63− , quoteDec = error "Database.PostgreSQL.Simple.SqlQQ.sql: quasiquoter used in declaration context"
58+ , quoteDec = error "Database.PostgreSQL.Simple.SqlQQ.sql:\
59+ \ quasiquoter used in declaration context"
64 }
60 }
65
61
66sqlExp :: String -> Q Exp
62sqlExp :: String -> Q Exp
67−sqlExp = appE [| fromString :: String -> Query |] . stringE . minimizeSpace
63+sqlExp = stringE . minimizeSpace
68
64
69minimizeSpace :: String -> String
65minimizeSpace :: String -> String
70minimizeSpace = drop 1 . reduceSpace
66minimizeSpace = drop 1 . reduceSpace
@@ -87,4 +83,5 @@ minimizeSpace = drop 1 . reduceSpace
87 instring ('\'':'\'':xs) = '\'':'\'': instring xs
83 instring ('\'':'\'':xs) = '\'':'\'': instring xs
88 instring ('\'':xs) = '\'': insql xs
84 instring ('\'':xs) = '\'': insql xs
89 instring (x:xs) = x : instring xs
85 instring (x:xs) = x : instring xs
90− instring [] = error "Database.PostgreSQL.Simple.SqlQQ.sql: string literal not terminated"
86+ instring [] = error "Database.PostgreSQL.Simple.SqlQQ.sql:\
87+ \ string literal not terminated"
src/Database/PostgreSQL/Simple/Time.hs+50−215
@@ -1,216 +1,53 @@
1−{- |
1+------------------------------------------------------------------------------
2+-- |
2−Module: Database.PostgreSQL.Simple.Time
3+-- Module: Database.PostgreSQL.Simple.Time
3−Copyright: (c) 2012-2015 Leon P Smith
4+-- Copyright: (c) 2012 Leon P Smith
4−License: BSD3
5+-- License: BSD3
5−Maintainer: Leon P Smith <leon@melding-monads.com>
6+-- Maintainer: Leon P Smith <leon@melding-monads.com>
6−Stability: experimental
7+-- Stability: experimental
7−
8+--
8−This module provides time types that supports positive and negative
9+-- Time types that supports positive and negative infinity. Also includes
9−infinity, as well as some functions for converting to and from strings.
10+-- new time parsers and printers with better performance than GHC's time
10−
11+-- package.
11−Also, this module also contains commentary regarding postgresql's timestamp
12+--
12−types, civil timekeeping in general, and how it relates to
13+-- The parsers only understand the specific variant of ISO 8601 that
13−postgresql-simple. You can read more about PostgreSQL's date and time types
14+-- PostgreSQL emits, and the printers attempt to duplicate this syntax.
14−at <https://www.postgresql.org/docs/9.5/static/datatype-datetime.html>,
15+-- Thus the @datestyle@ parameter for the connection must be set to @ISO@.
15−and the IANA time zone database at <https://en.wikipedia.org/wiki/Tz_database>.
16+--
16−
17+-- These parsers and printers likely have problems and shortcomings. Some
17−Stack Overflow also has some excellent commentary on time, if it is a
18+-- that I know of:
18−wiki page or a highly upvoted question and answer. If the answer regarding
19+--
19−time has not received about a hundred upvotes at least, then the answer is
20+-- 1 @TimestampTZ@s before a timezone-dependent point in time cannot be
20−almost invariably completely and painfully wrong, even if it's the chosen
21+-- parsed, because the parsers can only handle timezone offsets of a
21−answer or the most highly upvoted answer to a question.
22+-- integer number of minutes. However, PostgreSQL will include seconds
22−
23+-- in the offset, depending on the historical time standards for the city
23−PostgreSQL's @timestamp with time zone@ (hereafter, @timestamptz@) can be
24+-- identifying the time zone.
24−converted to Haskell's 'Data.Time.UTCTime' and 'Data.Time.ZonedTime' types,
25+--
25−because values of these types represent a self-contained, unambiguous point
26+-- This boundary point often marks an event of some interest. In the US
26−in time. PostgreSQL's @timestamp without time zone@ (hereafter, @timestamp@)
27+-- for example, @timestamptz@s before @1883-Nov-18 12:00:00@ local time
27−can be converted to Haskell's 'Data.Time.LocalTime', because values of these
28+-- cannot be parsed. This is the moment Standard Railway Time went live.
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
29+-- Concretely, PostgreSQL will emit @1883-11-18 12:03:57-04:56:02@
178− 1883-11-18 12:00:00-05
30+-- instead of @1883-11-18 11:59:59-05@ when the @timezone@ parameter
179−(2 rows)
31+-- for the connection is set to @America/New_York@.
180−@
32+--
181−
33+-- 2. Dates and times surrounding @1582-Feb-24@, the date the Gregorian
182−Both of these timestamps can be parsed as a 'Data.Time.UTCTime' type,
34+-- Calendar was introduced, should be investigated for conversion errors.
183−however 'Data.Time.ZonedTime' will fail on the former timestamp.
35+--
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
36+-- 3. Points in time Before Christ are not also not supported. For example,
195−will emit \"@0045-01-01 BC@\" for the first proleptic Gregorian day of
37+-- PostgreSQL will emit @0045-01-01 BC@ for a value of a @date@ type.
196−the year the Roman Empire adopted the Julian Calendar, but
38+-- This is the year that the Julian Calendar was adopted.
197−postgresql-simple does not (yet?) have the ability to either parse or
39+--
198−generate this syntax. Unfortunately this syntax isn't convenient to
40+-- However, it should be noted that the old parsers also had issues 1 and 3.
199−print or especially parse.
41+-- Also, the new parsers now correctly handle time zones that include minutes
200−
42+-- in their offset. Most notably, this includes all of India and parts of
201−Also, postgresql itself cannot parse or print dates before @4714-11-24 BC@,
43+-- Canada and Australia.
202−which is the Julian date on the proleptic Gregorian Calendar. Although
44+--
203−postgresql's timestamp types are perfectly capable of representing timestamps
45+-- PostgreSQL uses the zoneinfo database for its time zone information.
204−nearly 300,000 years in the past, using this would require postgresql-simple
46+-- You can read more about PostgreSQL's date and time types at
205−and other client programs to support binary parameters and results.
47+-- <http://www.postgresql.org/docs/9.1/static/datatype-datetime.html>,
206−
48+-- and zoneinfo at <http://en.wikipedia.org/wiki/Tz_database>.
207−Dealing with years BCE is also complicated slightly by the fact that
49+--
208−Haskell's time library has a year \"0000\", which is a convention often
50+------------------------------------------------------------------------------
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
51
215module Database.PostgreSQL.Simple.Time
52module Database.PostgreSQL.Simple.Time
216 ( Unbounded(..)
53 ( Unbounded(..)
@@ -227,7 +64,6 @@ module Database.PostgreSQL.Simple.Time
227 , parseUTCTimestamp
64 , parseUTCTimestamp
228 , parseZonedTimestamp
65 , parseZonedTimestamp
229 , parseLocalTimestamp
66 , parseLocalTimestamp
230− , parseCalendarDiffTime
231 , dayToBuilder
67 , dayToBuilder
232 , utcTimeToBuilder
68 , utcTimeToBuilder
233 , zonedTimeToBuilder
69 , zonedTimeToBuilder
@@ -240,7 +76,6 @@ module Database.PostgreSQL.Simple.Time
240 , localTimestampToBuilder
76 , localTimestampToBuilder
241 , unboundedToBuilder
77 , unboundedToBuilder
242 , nominalDiffTimeToBuilder
78 , nominalDiffTimeToBuilder
243− , calendarDiffTimeToBuilder
244 ) where
79 ) where
245
80
246import Database.PostgreSQL.Simple.Time.Implementation
81import Database.PostgreSQL.Simple.Time.Implementation
src/Database/PostgreSQL/Simple/Time/Implementation.hs+190−43
@@ -1,44 +1,51 @@
1------------------------------------------------------------------------------
1------------------------------------------------------------------------------
2-- |
2-- |
3-- Module: Database.PostgreSQL.Simple.Time.Implementation
3-- Module: Database.PostgreSQL.Simple.Time.Implementation
4−-- Copyright: (c) 2012-2015 Leon P Smith
4+-- Copyright: (c) 2012 Leon P Smith
5-- License: BSD3
5-- License: BSD3
6-- Maintainer: Leon P Smith <leon@melding-monads.com>
6-- Maintainer: Leon P Smith <leon@melding-monads.com>
7-- Stability: experimental
7-- Stability: experimental
8--
8--
9------------------------------------------------------------------------------
9------------------------------------------------------------------------------
10
10
11−{-# LANGUAGE DeriveDataTypeable, DeriveFunctor #-}
11+{-# LANGUAGE DeriveDataTypeable #-}
12
12
13module Database.PostgreSQL.Simple.Time.Implementation where
13module Database.PostgreSQL.Simple.Time.Implementation where
14
14
15−import Prelude hiding (take)
15+import Prelude hiding (take, (++))
16−import Data.ByteString.Builder(Builder, byteString)
16+import Blaze.ByteString.Builder(Builder, fromByteString)
17−import Data.ByteString.Builder.Prim(primBounded)
17+import Blaze.ByteString.Builder.Char8(fromChar)
18+import Blaze.Text.Int(integral)
18import Control.Arrow((***))
19import Control.Arrow((***))
19import Control.Applicative
20import Control.Applicative
21+import Control.Monad(when)
22+import Data.Bits((.&.))
20import qualified Data.ByteString as B
23import qualified Data.ByteString as B
21−import Data.Time.Compat (LocalTime, UTCTime, ZonedTime, Day, TimeOfDay, TimeZone, NominalDiffTime, utc)
24+import Data.ByteString.Internal (c2w, w2c)
22−import Data.Time.LocalTime.Compat (CalendarDiffTime)
25+import Data.Time hiding (getTimeZone, getZonedTime)
23import Data.Typeable
26import Data.Typeable
24−import Data.Maybe (fromMaybe)
27+import Data.Word(Word8)
25import qualified Data.Attoparsec.ByteString.Char8 as A
28import qualified Data.Attoparsec.ByteString.Char8 as A
26−import Database.PostgreSQL.Simple.Compat ((<>))
29+import Data.Monoid(Monoid(..))
27−import qualified Database.PostgreSQL.Simple.Time.Internal.Parser as TP
30+import Data.Fixed (Pico)
28−import qualified Database.PostgreSQL.Simple.Time.Internal.Printer as TPP
31+import Unsafe.Coerce
32+
33+(++) :: Monoid a => a -> a -> a
34+(++) = mappend
35+infixr 5 ++
29
36
30data Unbounded a
37data Unbounded a
31 = NegInfinity
38 = NegInfinity
32 | Finite !a
39 | Finite !a
33 | PosInfinity
40 | PosInfinity
34− deriving (Eq, Ord, Typeable, Functor)
41+ deriving (Eq, Ord, Typeable)
35
42
36instance Show a => Show (Unbounded a) where
43instance Show a => Show (Unbounded a) where
37 showsPrec prec x rest
44 showsPrec prec x rest
38 = case x of
45 = case x of
39− NegInfinity -> "-infinity" <> rest
46+ NegInfinity -> "-infinity" ++ rest
40 Finite time -> showsPrec prec time rest
47 Finite time -> showsPrec prec time rest
41− PosInfinity -> "infinity" <> rest
48+ PosInfinity -> "infinity" ++ rest
42
49
43instance Read a => Read (Unbounded a) where
50instance Read a => Read (Unbounded a) where
44 readsPrec prec = readParen False $ \str -> case str of
51 readsPrec prec = readParen False $ \str -> case str of
@@ -78,9 +85,6 @@ parseLocalTimestamp = A.parseOnly (getLocalTimestamp <* A.endOfInput)
78parseDate :: B.ByteString -> Either String Date
85parseDate :: B.ByteString -> Either String Date
79parseDate = A.parseOnly (getDate <* A.endOfInput)
86parseDate = A.parseOnly (getDate <* A.endOfInput)
80
87
81−parseCalendarDiffTime :: B.ByteString -> Either String CalendarDiffTime
82−parseCalendarDiffTime = A.parseOnly (getCalendarDiffTime <* A.endOfInput)
83−
84getUnbounded :: A.Parser a -> A.Parser (Unbounded a)
88getUnbounded :: A.Parser a -> A.Parser (Unbounded a)
85getUnbounded getFinite
89getUnbounded getFinite
86 = (pure NegInfinity <* A.string "-infinity")
90 = (pure NegInfinity <* A.string "-infinity")
@@ -88,74 +92,160 @@ getUnbounded getFinite
88 <|> (Finite <$> getFinite)
92 <|> (Finite <$> getFinite)
89
93
90getDay :: A.Parser Day
94getDay :: A.Parser Day
91−getDay = TP.day
95+getDay = do
96+ yearStr <- A.takeWhile A.isDigit
97+ when (B.length yearStr < 4) (fail "year must consist of at least 4 digits")
98+
99+ let !year = toNum yearStr
100+ _ <- A.char '-'
101+ !month <- digits "month"
102+ _ <- A.char '-'
103+ day <- digits "day"
104+
105+ case fromGregorianValid year month day of
106+ Nothing -> fail "invalid date"
107+ Just x -> return $! x
92
108
93getDate :: A.Parser Date
109getDate :: A.Parser Date
94getDate = getUnbounded getDay
110getDate = getUnbounded getDay
95
111
112+decimal :: Fractional a => B.ByteString -> a
113+decimal str = toNum str / 10^(B.length str)
114+{-# INLINE decimal #-}
115+
96getTimeOfDay :: A.Parser TimeOfDay
116getTimeOfDay :: A.Parser TimeOfDay
97−getTimeOfDay = TP.timeOfDay
117+getTimeOfDay = do
118+ !hour <- digits "hours"
119+ _ <- A.char ':'
120+ minute <- digits "minutes"
121+ _ <- A.char ':'
122+ second <- digits "seconds"
123+ subsec <- (A.char '.' *> (decimal <$> A.takeWhile1 A.isDigit)) <|> return 0
124+
125+ let !picos' = second + subsec
126+
127+ case makeTimeOfDayValid hour minute picos' of
128+ Nothing -> fail "invalid time of day"
129+ Just x -> return $! x
98
130
99getLocalTime :: A.Parser LocalTime
131getLocalTime :: A.Parser LocalTime
100−getLocalTime = TP.localTime
132+getLocalTime = LocalTime <$> getDay <*> (A.char ' ' *> getTimeOfDay)
101
133
102getLocalTimestamp :: A.Parser LocalTimestamp
134getLocalTimestamp :: A.Parser LocalTimestamp
103getLocalTimestamp = getUnbounded getLocalTime
135getLocalTimestamp = getUnbounded getLocalTime
104
136
105getTimeZone :: A.Parser TimeZone
137getTimeZone :: A.Parser TimeZone
106−getTimeZone = fromMaybe utc <$> TP.timeZone
138+getTimeZone = do
139+ !sign <- A.satisfy (\c -> c == '+' || c == '-')
140+ !hours <- digits "timezone"
141+ !mins <- (A.char ':' *> digits "timezone minutes") <|> pure 0
142+ let !absset = 60 * hours + mins
143+ !offset = if sign == '+' then absset else -absset
144+ return $! minutesToTimeZone offset
107
145
108type TimeZoneHMS = (Int,Int,Int)
146type TimeZoneHMS = (Int,Int,Int)
109
147
110getTimeZoneHMS :: A.Parser TimeZoneHMS
148getTimeZoneHMS :: A.Parser TimeZoneHMS
111−getTimeZoneHMS = munge <$> TP.timeZoneHMS
149+getTimeZoneHMS = do
112− where
150+ !sign <- A.satisfy (\c -> c == '+' || c == '-')
113− munge Nothing = (0,0,0)
151+ !hours <- digits "timezone"
114− munge (Just (TP.UTCOffsetHMS h m s)) = (h,m,s)
152+ !mins <- (A.char ':' *> digits "timezone minutes") <|> pure 0
153+ !secs <- (A.char ':' *> digits "timezone seconds") <|> pure 0
154+ if sign == '+'
155+ then return $! (hours, mins, secs)
156+ else return $! (\ !h !m !s -> (h,m,s)) (-hours) (-mins) (-secs)
115
157
116localToUTCTimeOfDayHMS :: TimeZoneHMS -> TimeOfDay -> (Integer, TimeOfDay)
158localToUTCTimeOfDayHMS :: TimeZoneHMS -> TimeOfDay -> (Integer, TimeOfDay)
117−localToUTCTimeOfDayHMS (dh, dm, ds) tod =
159+localToUTCTimeOfDayHMS (dh, dm, ds) (TimeOfDay h m s) =
118− TP.localToUTCTimeOfDayHMS (TP.UTCOffsetHMS dh dm ds) tod
160+ (\ !a !b -> (a,b)) dday (TimeOfDay h'' m'' s'')
161+ where
162+ s' = s - fromIntegral ds
163+ (!s'', m')
164+ | s' < 0 = (s' + 60, m - dm - 1)
165+ | s' >= 60 = (s' - 60, m - dm + 1)
166+ | otherwise = (s' , m - dm )
167+ (!m'', h')
168+ | m' < 0 = (m' + 60, h - dh - 1)
169+ | m' >= 60 = (m' - 60, h - dh + 1)
170+ | otherwise = (m' , h - dh )
171+ (!h'', dday)
172+ | h' < 0 = (h' + 24, -1)
173+ | h' >= 24 = (h' - 24, 1)
174+ | otherwise = (h' , 0)
119
175
120getZonedTime :: A.Parser ZonedTime
176getZonedTime :: A.Parser ZonedTime
121−getZonedTime = TP.zonedTime
177+getZonedTime = ZonedTime <$> getLocalTime <*> getTimeZone
122
178
123getZonedTimestamp :: A.Parser ZonedTimestamp
179getZonedTimestamp :: A.Parser ZonedTimestamp
124getZonedTimestamp = getUnbounded getZonedTime
180getZonedTimestamp = getUnbounded getZonedTime
125
181
126getUTCTime :: A.Parser UTCTime
182getUTCTime :: A.Parser UTCTime
127−getUTCTime = TP.utcTime
183+getUTCTime = do
184+ day <- getDay
185+ _ <- A.char ' '
186+ time <- getTimeOfDay
187+ zone <- getTimeZoneHMS
188+ let !(dayDelta,time') = localToUTCTimeOfDayHMS zone time
189+ let !day' = addDays dayDelta day
190+ let !time'' = timeOfDayToTime time'
191+ return $! UTCTime day' time''
128
192
129getUTCTimestamp :: A.Parser UTCTimestamp
193getUTCTimestamp :: A.Parser UTCTimestamp
130getUTCTimestamp = getUnbounded getUTCTime
194getUTCTimestamp = getUnbounded getUTCTime
131
195
132−getCalendarDiffTime :: A.Parser CalendarDiffTime
196+toNum :: Num n => B.ByteString -> n
133−getCalendarDiffTime = TP.calendarDiffTime
197+toNum = B.foldl' (\a c -> 10*a + digit c) 0
198+{-# INLINE toNum #-}
199+
200+digit :: Num n => Word8 -> n
201+digit c = fromIntegral (c .&. 0x0f)
202+{-# INLINE digit #-}
203+
204+digits :: Num n => String -> A.Parser n
205+digits msg = do
206+ x <- A.anyChar
207+ y <- A.anyChar
208+ if A.isDigit x && A.isDigit y
209+ then return $! (10 * digit (c2w x) + digit (c2w y))
210+ else fail (msg ++ " is not 2 digits")
211+{-# INLINE digits #-}
134
212
135dayToBuilder :: Day -> Builder
213dayToBuilder :: Day -> Builder
136−dayToBuilder = primBounded TPP.day
214+dayToBuilder (toGregorian -> (y,m,d)) = do
215+ pad4 y ++ fromChar '-' ++ pad2 m ++ fromChar '-' ++ pad2 d
137
216
138timeOfDayToBuilder :: TimeOfDay -> Builder
217timeOfDayToBuilder :: TimeOfDay -> Builder
139−timeOfDayToBuilder = primBounded TPP.timeOfDay
218+timeOfDayToBuilder (TimeOfDay h m s) = do
219+ pad2 h ++ fromChar ':' ++ pad2 m ++ fromChar ':' ++ showSeconds s
140
220
141timeZoneToBuilder :: TimeZone -> Builder
221timeZoneToBuilder :: TimeZone -> Builder
142−timeZoneToBuilder = primBounded TPP.timeZone
222+timeZoneToBuilder tz
223+ | m == 0 = sign h ++ pad2 (abs h)
224+ | otherwise = sign h ++ pad2 (abs h) ++ fromChar ':' ++ pad2 (abs m)
225+ where
226+ (h,m) = timeZoneMinutes tz `quotRem` 60
227+ sign h | h >= 0 = fromChar '+'
228+ | otherwise = fromChar '-'
143
229
144utcTimeToBuilder :: UTCTime -> Builder
230utcTimeToBuilder :: UTCTime -> Builder
145−utcTimeToBuilder = primBounded TPP.utcTime
231+utcTimeToBuilder (UTCTime day time) =
232+ dayToBuilder day ++ fromChar ' '
233+ ++ timeOfDayToBuilder (timeToTimeOfDay time) ++ fromByteString "+00"
146
234
147zonedTimeToBuilder :: ZonedTime -> Builder
235zonedTimeToBuilder :: ZonedTime -> Builder
148−zonedTimeToBuilder = primBounded TPP.zonedTime
236+zonedTimeToBuilder (ZonedTime localTime tz) =
237+ localTimeToBuilder localTime ++ timeZoneToBuilder tz
149
238
150localTimeToBuilder :: LocalTime -> Builder
239localTimeToBuilder :: LocalTime -> Builder
151−localTimeToBuilder = primBounded TPP.localTime
240+localTimeToBuilder (LocalTime day tod) =
241+ dayToBuilder day ++ fromChar ' ' ++ timeOfDayToBuilder tod
152
242
153unboundedToBuilder :: (a -> Builder) -> (Unbounded a -> Builder)
243unboundedToBuilder :: (a -> Builder) -> (Unbounded a -> Builder)
154unboundedToBuilder finiteToBuilder unbounded
244unboundedToBuilder finiteToBuilder unbounded
155 = case unbounded of
245 = case unbounded of
156− NegInfinity -> byteString "-infinity"
246+ NegInfinity -> fromByteString "-infinity"
157 Finite a -> finiteToBuilder a
247 Finite a -> finiteToBuilder a
158− PosInfinity -> byteString "infinity"
248+ PosInfinity -> fromByteString "infinity"
159
249
160utcTimestampToBuilder :: UTCTimestamp -> Builder
250utcTimestampToBuilder :: UTCTimestamp -> Builder
161utcTimestampToBuilder = unboundedToBuilder utcTimeToBuilder
251utcTimestampToBuilder = unboundedToBuilder utcTimeToBuilder
@@ -170,7 +260,64 @@ dateToBuilder :: Date -> Builder
170dateToBuilder = unboundedToBuilder dayToBuilder
260dateToBuilder = unboundedToBuilder dayToBuilder
171
261
172nominalDiffTimeToBuilder :: NominalDiffTime -> Builder
262nominalDiffTimeToBuilder :: NominalDiffTime -> Builder
173−nominalDiffTimeToBuilder = TPP.nominalDiffTime
263+nominalDiffTimeToBuilder xyz
174−
264+ | yz < 500000 = sign ++ integral x
175−calendarDiffTimeToBuilder :: CalendarDiffTime -> Builder
265+ | otherwise = sign ++ integral x ++ fromChar '.' ++ showD6 y
176−calendarDiffTimeToBuilder = TPP.calendarDiffTime
266+ where
267+ -- A kludge to work around the fact that Data.Fixed isn't very fast and
268+ -- doesn't give me access to the MkFixed constructor.
269+ sign = if xyz >= 0 then mempty else fromChar '-'
270+ (x,yz) = ((unsafeCoerce (abs xyz) :: Integer) + 500000) `quotRem` 1000000000000
271+ (fromIntegral -> y, _z) = yz `quotRem` 1000000
272+
273+showSeconds :: Pico -> Builder
274+showSeconds xyz
275+ | yz == 0 = pad2 x
276+ | z == 0 = pad2 x ++ fromChar '.' ++ showD6 y
277+ | otherwise = pad2 x ++ fromChar '.' ++ pad6 y ++ showD6 z
278+ where
279+ -- A kludge to work around the fact that Data.Fixed isn't very fast and
280+ -- doesn't give me access to the MkFixed constructor.
281+ (x_,yz) = (unsafeCoerce xyz :: Integer) `quotRem` 1000000000000
282+ x = fromIntegral x_ :: Int
283+ (fromIntegral -> y, fromIntegral -> z) = yz `quotRem` 1000000
284+
285+pad6 :: Int -> Builder
286+pad6 xy = let (x,y) = xy `quotRem` 1000
287+ in pad3 x ++ pad3 y
288+
289+showD6 :: Int -> Builder
290+showD6 xy = case xy `quotRem` 1000 of
291+ (x,0) -> showD3 x
292+ (x,y) -> pad3 x ++ showD3 y
293+
294+pad3 :: Int -> Builder
295+pad3 abc = let (ab,c) = abc `quotRem` 10
296+ (a,b) = ab `quotRem` 10
297+ in p a ++ p b ++ p c
298+
299+showD3 :: Int -> Builder
300+showD3 abc = case abc `quotRem` 100 of
301+ (a, 0) -> p a
302+ (a,bc) -> case bc `quotRem` 10 of
303+ (b,0) -> p a ++ p b
304+ (b,c) -> p a ++ p b ++ p c
305+
306+-- | p assumes its input is in the range [0..9]
307+p :: Integral n => n -> Builder
308+p n = fromChar (w2c (fromIntegral (n + 48)))
309+{-# INLINE p #-}
310+
311+-- | pad2 assumes its input is in the range [0..99]
312+pad2 :: Integral n => n -> Builder
313+pad2 n = let (a,b) = n `quotRem` 10 in p a ++ p b
314+{-# INLINE pad2 #-}
315+
316+-- | pad4 assumes its input is positive
317+pad4 :: (Integral n, Show n) => n -> Builder
318+pad4 abcd | abcd >= 10000 = integral abcd
319+ | otherwise = p a ++ p b ++ p c ++ p d
320+ where (ab,cd) = abcd `quotRem` 100
321+ (a,b) = ab `quotRem` 10
322+ (c,d) = cd `quotRem` 10
323+{-# INLINE pad4 #-}
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.hs+54−84
@@ -1,6 +1,5 @@
1{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-}
1{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-}
2{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
2{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
3−{-# LANGUAGE PolyKinds #-}
4
3
5------------------------------------------------------------------------------
4------------------------------------------------------------------------------
6-- |
5-- |
@@ -23,44 +22,38 @@ module Database.PostgreSQL.Simple.ToField
23 , inQuotes
22 , inQuotes
24 ) where
23 ) where
25
24
26−import Control.Applicative (Const(Const))
25+import Blaze.ByteString.Builder (Builder, fromByteString, toByteString)
26+import Blaze.ByteString.Builder.Char8 (fromChar)
27+import Blaze.Text (integral, double, float)
27import qualified Data.Aeson as JSON
28import qualified Data.Aeson as JSON
28−import Data.ByteString (ByteString)
29−import Data.ByteString.Builder
29+import Data.ByteString (ByteString)
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))
36import Data.Int (Int8, Int16, Int32, Int64)
30import Data.Int (Int8, Int16, Int32, Int64)
37import Data.List (intersperse)
31import Data.List (intersperse)
38import Data.Monoid (mappend)
32import Data.Monoid (mappend)
39−import Data.Time.Compat (Day, TimeOfDay, LocalTime, UTCTime, ZonedTime, NominalDiffTime)
33+import Data.Time (Day, TimeOfDay, LocalTime, UTCTime, ZonedTime, NominalDiffTime)
40−import Data.Time.LocalTime.Compat (CalendarDiffTime)
41import Data.Typeable (Typeable)
34import Data.Typeable (Typeable)
42import Data.Word (Word, Word8, Word16, Word32, Word64)
35import Data.Word (Word, Word8, Word16, Word32, Word64)
43import {-# SOURCE #-} Database.PostgreSQL.Simple.ToRow
36import {-# SOURCE #-} Database.PostgreSQL.Simple.ToRow
44import Database.PostgreSQL.Simple.Types
37import Database.PostgreSQL.Simple.Types
45−import Database.PostgreSQL.Simple.Compat (toByteString)
38+import qualified Blaze.ByteString.Builder.Char.Utf8 as Utf8
46−
47import qualified Data.ByteString as SB
39import qualified Data.ByteString as SB
48import qualified Data.ByteString.Lazy as LB
40import qualified Data.ByteString.Lazy as LB
49−import Data.CaseInsensitive (CI)
50−import qualified Data.CaseInsensitive as CI
51import qualified Data.Text as ST
41import qualified Data.Text as ST
52import qualified Data.Text.Encoding as ST
42import qualified Data.Text.Encoding as ST
53import qualified Data.Text.Lazy as LT
43import qualified Data.Text.Lazy as LT
54import qualified Data.Text.Lazy.Builder as LT
44import qualified Data.Text.Lazy.Builder as LT
55−import Data.UUID.Types (UUID)
45+import Data.UUID (UUID)
56−import qualified Data.UUID.Types as UUID
46+import qualified Data.UUID as UUID
57import Data.Vector (Vector)
47import Data.Vector (Vector)
58import qualified Data.Vector as V
48import qualified Data.Vector as V
59import qualified Database.PostgreSQL.LibPQ as PQ
49import qualified Database.PostgreSQL.LibPQ as PQ
60import Database.PostgreSQL.Simple.Time
50import Database.PostgreSQL.Simple.Time
61import Data.Scientific (Scientific)
51import Data.Scientific (Scientific)
52+#if MIN_VERSION_scientific(0,3,0)
62import Data.Text.Lazy.Builder.Scientific (scientificBuilder)
53import Data.Text.Lazy.Builder.Scientific (scientificBuilder)
63−import Foreign.C.Types (CUInt(..))
54+#else
55+import Data.Scientific (scientificBuilder)
56+#endif
64
57
65-- | How to render an element when substituting it into a query.
58-- | How to render an element when substituting it into a query.
66data Action =
59data Action =
@@ -100,98 +93,90 @@ instance ToField Action where
100 toField a = a
93 toField a = a
101 {-# INLINE toField #-}
94 {-# INLINE toField #-}
102
95
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−
111instance (ToField a) => ToField (Maybe a) where
96instance (ToField a) => ToField (Maybe a) where
112 toField Nothing = renderNull
97 toField Nothing = renderNull
113 toField (Just a) = toField a
98 toField (Just a) = toField a
114 {-# INLINE toField #-}
99 {-# INLINE toField #-}
115
100
116instance (ToField a) => ToField (In [a]) where
101instance (ToField a) => ToField (In [a]) where
117− toField (In []) = Plain $ byteString "(null)"
102+ toField (In []) = Plain $ fromByteString "(null)"
118 toField (In xs) = Many $
103 toField (In xs) = Many $
119− Plain (char8 '(') :
104+ Plain (fromChar '(') :
120− (intersperse (Plain (char8 ',')) . map toField $ xs) ++
105+ (intersperse (Plain (fromChar ',')) . map toField $ xs) ++
121− [Plain (char8 ')')]
106+ [Plain (fromChar ')')]
122
107
123renderNull :: Action
108renderNull :: Action
124−renderNull = Plain (byteString "null")
109+renderNull = Plain (fromByteString "null")
125
110
126instance ToField Null where
111instance ToField Null where
127 toField _ = renderNull
112 toField _ = renderNull
128 {-# INLINE toField #-}
113 {-# INLINE toField #-}
129
114
130instance ToField Default where
115instance ToField Default where
131− toField _ = Plain (byteString "default")
116+ toField _ = Plain (fromByteString "default")
132 {-# INLINE toField #-}
117 {-# INLINE toField #-}
133
118
134instance ToField Bool where
119instance ToField Bool where
135− toField True = Plain (byteString "true")
120+ toField True = Plain (fromByteString "true")
136− toField False = Plain (byteString "false")
121+ toField False = Plain (fromByteString "false")
137 {-# INLINE toField #-}
122 {-# INLINE toField #-}
138
123
139instance ToField Int8 where
124instance ToField Int8 where
140− toField = Plain . int8Dec
125+ toField = Plain . integral
141 {-# INLINE toField #-}
126 {-# INLINE toField #-}
142
127
143instance ToField Int16 where
128instance ToField Int16 where
144− toField = Plain . int16Dec
129+ toField = Plain . integral
145 {-# INLINE toField #-}
130 {-# INLINE toField #-}
146
131
147instance ToField Int32 where
132instance ToField Int32 where
148− toField = Plain . int32Dec
133+ toField = Plain . integral
149 {-# INLINE toField #-}
134 {-# INLINE toField #-}
150
135
151instance ToField Int where
136instance ToField Int where
152− toField = Plain . intDec
137+ toField = Plain . integral
153 {-# INLINE toField #-}
138 {-# INLINE toField #-}
154
139
155instance ToField Int64 where
140instance ToField Int64 where
156− toField = Plain . int64Dec
141+ toField = Plain . integral
157 {-# INLINE toField #-}
142 {-# INLINE toField #-}
158
143
159instance ToField Integer where
144instance ToField Integer where
160− toField = Plain . integerDec
145+ toField = Plain . integral
161 {-# INLINE toField #-}
146 {-# INLINE toField #-}
162
147
163instance ToField Word8 where
148instance ToField Word8 where
164− toField = Plain . word8Dec
149+ toField = Plain . integral
165 {-# INLINE toField #-}
150 {-# INLINE toField #-}
166
151
167instance ToField Word16 where
152instance ToField Word16 where
168− toField = Plain . word16Dec
153+ toField = Plain . integral
169 {-# INLINE toField #-}
154 {-# INLINE toField #-}
170
155
171instance ToField Word32 where
156instance ToField Word32 where
172− toField = Plain . word32Dec
157+ toField = Plain . integral
173 {-# INLINE toField #-}
158 {-# INLINE toField #-}
174
159
175instance ToField Word where
160instance ToField Word where
176− toField = Plain . wordDec
161+ toField = Plain . integral
177 {-# INLINE toField #-}
162 {-# INLINE toField #-}
178
163
179instance ToField Word64 where
164instance ToField Word64 where
180− toField = Plain . word64Dec
165+ toField = Plain . integral
181 {-# INLINE toField #-}
166 {-# INLINE toField #-}
182
167
183instance ToField PQ.Oid where
168instance ToField PQ.Oid where
184− toField = Plain . \(PQ.Oid (CUInt x)) -> word32Dec x
169+ toField = Plain . integral . \(PQ.Oid x) -> x
185 {-# INLINE toField #-}
170 {-# INLINE toField #-}
186
171
187instance ToField Float where
172instance ToField Float where
188− toField v | isNaN v || isInfinite v = Plain (inQuotes (floatDec v))
173+ toField v | isNaN v || isInfinite v = Plain (inQuotes (float v))
189− | otherwise = Plain (floatDec v)
174+ | otherwise = Plain (float v)
190 {-# INLINE toField #-}
175 {-# INLINE toField #-}
191
176
192instance ToField Double where
177instance ToField Double where
193− toField v | isNaN v || isInfinite v = Plain (inQuotes (doubleDec v))
178+ toField v | isNaN v || isInfinite v = Plain (inQuotes (double v))
194− | otherwise = Plain (doubleDec v)
179+ | otherwise = Plain (double v)
195 {-# INLINE toField #-}
180 {-# INLINE toField #-}
196
181
197instance ToField Scientific where
182instance ToField Scientific where
@@ -213,7 +198,7 @@ instance ToField Identifier where
213instance ToField QualifiedIdentifier where
198instance ToField QualifiedIdentifier where
214 toField (QualifiedIdentifier (Just s) t) =
199 toField (QualifiedIdentifier (Just s) t) =
215 Many [ EscapeIdentifier (ST.encodeUtf8 s)
200 Many [ EscapeIdentifier (ST.encodeUtf8 s)
216− , Plain (char8 '.')
201+ , Plain (fromChar '.')
217 , EscapeIdentifier (ST.encodeUtf8 t)
202 , EscapeIdentifier (ST.encodeUtf8 t)
218 ]
203 ]
219 toField (QualifiedIdentifier Nothing t) =
204 toField (QualifiedIdentifier Nothing t) =
@@ -233,22 +218,13 @@ instance ToField ST.Text where
233 {-# INLINE toField #-}
218 {-# INLINE toField #-}
234
219
235instance ToField [Char] where
220instance ToField [Char] where
236− toField = Escape . toByteString . stringUtf8
221+ toField = Escape . toByteString . Utf8.fromString
237 {-# INLINE toField #-}
222 {-# INLINE toField #-}
238
223
239instance ToField LT.Text where
224instance ToField LT.Text where
240 toField = toField . LT.toStrict
225 toField = toField . LT.toStrict
241 {-# INLINE toField #-}
226 {-# INLINE toField #-}
242
227
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
228
253instance ToField UTCTime where
229instance ToField UTCTime where
254 toField = Plain . inQuotes . utcTimeToBuilder
230 toField = Plain . inQuotes . utcTimeToBuilder
@@ -290,47 +266,41 @@ instance ToField NominalDiffTime where
290 toField = Plain . inQuotes . nominalDiffTimeToBuilder
266 toField = Plain . inQuotes . nominalDiffTimeToBuilder
291 {-# INLINE toField #-}
267 {-# INLINE toField #-}
292
268
293−instance ToField CalendarDiffTime where
294− toField = Plain . inQuotes . calendarDiffTimeToBuilder
295− {-# INLINE toField #-}
296−
297instance (ToField a) => ToField (PGArray a) where
269instance (ToField a) => ToField (PGArray a) where
298− toField pgArray =
270+ toField xs = Many $
299− case fromPGArray pgArray of
300− [] -> Plain (byteString "'{}'")
301− xs -> Many $
302− Plain (byteString "ARRAY[") :
271+ Plain (fromByteString "ARRAY[") :
303− (intersperse (Plain (char8 ',')) . map toField $ xs) ++
272+ (intersperse (Plain (fromChar ',')) . map toField $ fromPGArray xs) ++
304− [Plain (char8 ']')]
273+ [Plain (fromChar ']')]
305− -- Because the ARRAY[...] input syntax is being used, it is possible
274+ -- Because the ARRAY[...] input syntax is being used, it is possible
306− -- that the use of type-specific separator characters is unnecessary.
275+ -- that the use of type-specific separator characters is unnecessary.
307
276
308instance (ToField a) => ToField (Vector a) where
277instance (ToField a) => ToField (Vector a) where
309 toField = toField . PGArray . V.toList
278 toField = toField . PGArray . V.toList
310
279
311instance ToField UUID where
280instance ToField UUID where
312− toField = Plain . inQuotes . byteString . UUID.toASCIIBytes
281+ toField = Plain . inQuotes . fromByteString . UUID.toASCIIBytes
313
282
314instance ToField JSON.Value where
283instance ToField JSON.Value where
315 toField = toField . JSON.encode
284 toField = toField . JSON.encode
316
285
317−-- | Convert a Haskell value to JSON using 'JSON.toEncoding'.
286+-- | Convert a Haskell value to a JSON 'JSON.Value' using
287+-- 'JSON.toJSON' and convert that to a field using 'toField'.
318--
288--
319-- This can be used as the default implementation for the 'toField'
289-- This can be used as the default implementation for the 'toField'
320-- method for Haskell types that have a JSON representation in
290-- method for Haskell types that have a JSON representation in
321-- PostgreSQL.
291-- PostgreSQL.
322toJSONField :: JSON.ToJSON a => a -> Action
292toJSONField :: JSON.ToJSON a => a -> Action
323−toJSONField = toField . JSON.encode
293+toJSONField = toField . JSON.toJSON
324
294
325-- | Surround a string with single-quote characters: \"@'@\"
295-- | Surround a string with single-quote characters: \"@'@\"
326--
296--
327-- This function /does not/ perform any other escaping.
297-- This function /does not/ perform any other escaping.
328inQuotes :: Builder -> Builder
298inQuotes :: Builder -> Builder
329inQuotes b = quote `mappend` b `mappend` quote
299inQuotes b = quote `mappend` b `mappend` quote
330− where quote = char8 '\''
300+ where quote = Utf8.fromChar '\''
331
301
332interleaveFoldr :: (a -> [b] -> [b]) -> b -> [b] -> [a] -> [b]
302interleaveFoldr :: (a -> [b] -> [b]) -> b -> [b] -> [a] -> [b]
333−interleaveFoldr f b bs' as = foldr (\a bs -> b : f a bs) bs' as
303+interleaveFoldr f b bs as = foldr (\a bs -> b : f a bs) bs as
334{-# INLINE interleaveFoldr #-}
304{-# INLINE interleaveFoldr #-}
335
305
336instance ToRow a => ToField (Values a) where
306instance ToRow a => ToField (Values a) where
@@ -348,8 +318,8 @@ instance ToRow a => ToField (Values a) where
348 funcname = "Database.PostgreSQL.Simple.toField :: Values a -> Action"
318 funcname = "Database.PostgreSQL.Simple.toField :: Values a -> Action"
349 norows = funcname ++ " either values or types must be non-empty"
319 norows = funcname ++ " either values or types must be non-empty"
350 emptyrow = funcname ++ " each row must contain at least one column"
320 emptyrow = funcname ++ " each row must contain at least one column"
351− lit = Plain . byteString
321+ lit = Plain . fromByteString
352− litC = Plain . char8
322+ litC = Plain . fromChar
353 values x = Many (lit "(VALUES ": x)
323 values x = Many (lit "(VALUES ": x)
354
324
355 typedField :: (Action, QualifiedIdentifier) -> [Action] -> [Action]
325 typedField :: (Action, QualifiedIdentifier) -> [Action] -> [Action]
@@ -377,8 +347,8 @@ instance ToRow a => ToField (Values a) where
377
347
378 typedRows :: ToRow a => [a] -> [QualifiedIdentifier] -> [Action] -> [Action]
348 typedRows :: ToRow a => [a] -> [QualifiedIdentifier] -> [Action] -> [Action]
379 typedRows [] _ _ = error funcname
349 typedRows [] _ _ = error funcname
380− typedRows (val:vals) typs rest =
350+ typedRows (val:vals) types rest =
381− typedRow (toRow val) typs (multiRows vals rest)
351+ typedRow (toRow val) types (multiRows vals rest)
382
352
383 untypedRows :: ToRow a => [a] -> [Action] -> [Action]
353 untypedRows :: ToRow a => [a] -> [Action] -> [Action]
384 untypedRows [] _ = error funcname
354 untypedRows [] _ = error funcname
src/Database/PostgreSQL/Simple/ToField.hs-boot+1−1
@@ -1,7 +1,7 @@
1module Database.PostgreSQL.Simple.ToField where
1module Database.PostgreSQL.Simple.ToField where
2
2
3import Database.PostgreSQL.Simple.Types
3import Database.PostgreSQL.Simple.Types
4−import Data.ByteString.Builder(Builder)
4+import Blaze.ByteString.Builder(Builder)
5import Data.ByteString(ByteString)
5import Data.ByteString(ByteString)
6
6
7-- | How to render an element when substituting it into a query.
7-- | How to render an element when substituting it into a query.
src/Database/PostgreSQL/Simple/ToRow.hs−127
@@ -1,4 +1,3 @@
1−{-# LANGUAGE DefaultSignatures, FlexibleInstances, FlexibleContexts #-}
2------------------------------------------------------------------------------
1------------------------------------------------------------------------------
3-- |
2-- |
4-- Module: Database.PostgreSQL.Simple.ToRow
3-- Module: Database.PostgreSQL.Simple.ToRow
@@ -23,33 +22,14 @@ module Database.PostgreSQL.Simple.ToRow
23
22
24import Database.PostgreSQL.Simple.ToField (Action(..), ToField(..))
23import Database.PostgreSQL.Simple.ToField (Action(..), ToField(..))
25import Database.PostgreSQL.Simple.Types (Only(..), (:.)(..))
24import Database.PostgreSQL.Simple.Types (Only(..), (:.)(..))
26−import GHC.Generics
27
25
28-- | A collection type that can be turned into a list of rendering
26-- | A collection type that can be turned into a list of rendering
29-- 'Action's.
27-- 'Action's.
30--
28--
31-- Instances should use the 'toField' method of the 'ToField' class
29-- Instances should use the 'toField' method of the 'ToField' class
32-- to perform conversion of each element of the collection.
30-- 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.
49class ToRow a where
31class ToRow a where
50 toRow :: a -> [Action]
32 toRow :: a -> [Action]
51− default toRow :: (Generic a, GToRow (Rep a)) => a -> [Action]
52− toRow = gtoRow . from
53 -- ^ ToField a collection of values.
33 -- ^ ToField a collection of values.
54
34
55instance ToRow () where
35instance ToRow () where
@@ -105,115 +85,8 @@ instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,
105 [toField a, toField b, toField c, toField d, toField e, toField f,
85 [toField a, toField b, toField c, toField d, toField e, toField f,
106 toField g, toField h, toField i, toField j]
86 toField g, toField h, toField i, toField j]
107
87
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−
198instance (ToField a) => ToRow [a] where
88instance (ToField a) => ToRow [a] where
199 toRow = map toField
89 toRow = map toField
200
90
201instance (ToRow a, ToRow b) => ToRow (a :. b) where
91instance (ToRow a, ToRow b) => ToRow (a :. b) where
202 toRow (a :. b) = toRow a ++ toRow b
92 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-boot+1−10
@@ -1,18 +1,9 @@
1−{-# LANGUAGE DefaultSignatures, FlexibleInstances, FlexibleContexts #-}
2−module Database.PostgreSQL.Simple.ToRow (
1+module Database.PostgreSQL.Simple.ToRow where
3− ToRow(..)
4− ) where
5
2
6import Database.PostgreSQL.Simple.Types
3import Database.PostgreSQL.Simple.Types
7import {-# SOURCE #-} Database.PostgreSQL.Simple.ToField
4import {-# SOURCE #-} Database.PostgreSQL.Simple.ToField
8−import GHC.Generics
9
5
10class ToRow a where
6class ToRow a where
11 toRow :: a -> [Action]
7 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
8
18instance ToField a => ToRow (Only a)
9instance ToField a => ToRow (Only a)
src/Database/PostgreSQL/Simple/Transaction.hs+17−35
@@ -1,14 +1,4 @@
1−{-# LANGUAGE RecordWildCards, ScopedTypeVariables #-}
1+{-# LANGUAGE RecordWildCards #-}
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
2
13module Database.PostgreSQL.Simple.Transaction
3module Database.PostgreSQL.Simple.Transaction
14 (
4 (
@@ -17,7 +7,6 @@ module Database.PostgreSQL.Simple.Transaction
17 , withTransactionLevel
7 , withTransactionLevel
18 , withTransactionMode
8 , withTransactionMode
19 , withTransactionModeRetry
9 , withTransactionModeRetry
20− , withTransactionModeRetry'
21 , withTransactionSerializable
10 , withTransactionSerializable
22 , TransactionMode(..)
11 , TransactionMode(..)
23 , IsolationLevel(..)
12 , IsolationLevel(..)
@@ -56,7 +45,7 @@ import Database.PostgreSQL.Simple.Compat (mask, (<>))
56
45
57-- | Of the four isolation levels defined by the SQL standard,
46-- | Of the four isolation levels defined by the SQL standard,
58-- these are the three levels distinguished by PostgreSQL as of version 9.0.
47-- 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>
48+-- See <http://www.postgresql.org/docs/9.1/static/transaction-iso.html>
60-- for more information. Note that prior to PostgreSQL 9.0, 'RepeatableRead'
49-- for more information. Note that prior to PostgreSQL 9.0, 'RepeatableRead'
61-- was equivalent to 'Serializable'.
50-- was equivalent to 'Serializable'.
62
51
@@ -143,48 +132,41 @@ withTransactionMode :: TransactionMode -> Connection -> IO a -> IO a
143withTransactionMode mode conn act =
132withTransactionMode mode conn act =
144 mask $ \restore -> do
133 mask $ \restore -> do
145 beginMode mode conn
134 beginMode mode conn
146− r <- restore act `E.onException` rollback_ conn
135+ r <- restore act `E.onException` rollback conn
147 commit conn
136 commit conn
148 return r
137 return r
149
138
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
139-- | Like 'withTransactionMode', but also takes a custom callback to
155−-- determine if a transaction should be retried if an exception occurs.
140+-- determine if a transaction should be retried if an 'SqlError' occurs.
156−-- If the callback returns 'True', then the transaction will be retried.
141+-- If the callback returns True, then the transaction will be retried.
157−-- If the callback returns 'False', or an exception other than an @e@
142+-- If the callback returns False, or an exception other than an 'SqlError'
158-- occurs then the transaction will be rolled back and the exception rethrown.
143-- occurs then the transaction will be rolled back and the exception rethrown.
159--
144--
160-- This is used to implement 'withTransactionSerializable'.
145-- This is used to implement 'withTransactionSerializable'.
161−withTransactionModeRetry' :: forall a e. E.Exception e => TransactionMode -> (e -> Bool) -> Connection -> IO a -> IO a
146+withTransactionModeRetry :: TransactionMode -> (SqlError -> Bool) -> Connection -> IO a -> IO a
162−withTransactionModeRetry' mode shouldRetry conn act =
147+withTransactionModeRetry mode shouldRetry conn act =
163 mask $ \restore ->
148 mask $ \restore ->
164 retryLoop $ E.try $ do
149 retryLoop $ E.try $ do
165− a <- restore act `E.onException` rollback_ conn
150+ a <- restore act
166 commit conn
151 commit conn
167 return a
152 return a
168 where
153 where
169− retryLoop :: IO (Either e a) -> IO a
154+ retryLoop :: IO (Either E.SomeException a) -> IO a
170 retryLoop act' = do
155 retryLoop act' = do
171 beginMode mode conn
156 beginMode mode conn
172 r <- act'
157 r <- act'
173 case r of
158 case r of
174− Left e ->
159+ Left e -> do
160+ rollback conn
175− case shouldRetry e of
161+ case fmap shouldRetry (E.fromException e) of
176− True -> retryLoop act'
162+ Just True -> retryLoop act'
177− False -> E.throwIO e
163+ _ -> E.throwIO e
178 Right a ->
164 Right a ->
179 return a
165 return a
180
166
181-- | Rollback a transaction.
167-- | Rollback a transaction.
182rollback :: Connection -> IO ()
168rollback :: Connection -> IO ()
183−rollback conn = execute_ conn "ROLLBACK" >> return ()
169+rollback conn = execute_ conn "ABORT" >> return ()
184−
185−-- | Rollback a transaction, ignoring any @IOErrors@
186−rollback_ :: Connection -> IO ()
187−rollback_ conn = rollback conn `E.catch` \(_ :: IOError) -> return ()
188
170
189-- | Commit a transaction.
171-- | Commit a transaction.
190commit :: Connection -> IO ()
172commit :: Connection -> IO ()
@@ -221,7 +203,7 @@ beginMode mode conn = do
221-- be used inside of a transaction, and provides a sort of
203-- be used inside of a transaction, and provides a sort of
222-- \"nested transaction\".
204-- \"nested transaction\".
223--
205--
224−-- See <https://www.postgresql.org/docs/9.5/static/sql-savepoint.html>
206+-- See <http://www.postgresql.org/docs/current/static/sql-savepoint.html>
225withSavepoint :: Connection -> IO a -> IO a
207withSavepoint :: Connection -> IO a -> IO a
226withSavepoint conn body =
208withSavepoint conn body =
227 mask $ \restore -> do
209 mask $ \restore -> do
src/Database/PostgreSQL/Simple/TypeInfo.hs+9−9
@@ -50,21 +50,21 @@ import Database.PostgreSQL.Simple.TypeInfo.Static
50-- in the connections's cache.
50-- in the connections's cache.
51
51
52getTypeInfo :: Connection -> PQ.Oid -> IO TypeInfo
52getTypeInfo :: Connection -> PQ.Oid -> IO TypeInfo
53−getTypeInfo conn@Connection{..} oid' =
53+getTypeInfo conn@Connection{..} oid =
54− case staticTypeInfo oid' of
54+ case staticTypeInfo oid of
55− Just name' -> return name'
55+ Just name -> return name
56− Nothing -> modifyMVar connectionObjects $ getTypeInfo' conn oid'
56+ Nothing -> modifyMVar connectionObjects $ getTypeInfo' conn oid
57
57
58getTypeInfo' :: Connection -> PQ.Oid -> TypeInfoCache
58getTypeInfo' :: Connection -> PQ.Oid -> TypeInfoCache
59 -> IO (TypeInfoCache, TypeInfo)
59 -> IO (TypeInfoCache, TypeInfo)
60−getTypeInfo' conn oid' oidmap =
60+getTypeInfo' conn oid oidmap =
61− case IntMap.lookup (oid2int oid') oidmap of
61+ case IntMap.lookup (oid2int oid) oidmap of
62 Just typeinfo -> return (oidmap, typeinfo)
62 Just typeinfo -> return (oidmap, typeinfo)
63 Nothing -> do
63 Nothing -> do
64 names <- query conn "SELECT oid, typcategory, typdelim, typname,\
64 names <- query conn "SELECT oid, typcategory, typdelim, typname,\
65 \ typelem, typrelid\
65 \ typelem, typrelid\
66 \ FROM pg_type WHERE oid = ?"
66 \ FROM pg_type WHERE oid = ?"
67− (Only oid')
67+ (Only oid)
68 (oidmap', typeInfo) <-
68 (oidmap', typeInfo) <-
69 case names of
69 case names of
70 [] -> return $ throw (fatalError "invalid type oid")
70 [] -> return $ throw (fatalError "invalid type oid")
@@ -78,7 +78,7 @@ getTypeInfo' conn oid' oidmap =
78 rngsubtypeOids <- query conn "SELECT rngsubtype\
78 rngsubtypeOids <- query conn "SELECT rngsubtype\
79 \ FROM pg_range\
79 \ FROM pg_range\
80 \ WHERE rngtypid = ?"
80 \ WHERE rngtypid = ?"
81− (Only oid')
81+ (Only oid)
82 case rngsubtypeOids of
82 case rngsubtypeOids of
83 [Only rngsubtype_] -> do
83 [Only rngsubtype_] -> do
84 (oidmap', rngsubtype) <-
84 (oidmap', rngsubtype) <-
@@ -104,7 +104,7 @@ getTypeInfo' conn oid' oidmap =
104 _ -> fail "typename query returned more than one result"
104 _ -> fail "typename query returned more than one result"
105 -- oid is a primary key, so the query should
105 -- oid is a primary key, so the query should
106 -- never return more than one result
106 -- never return more than one result
107− let !oidmap'' = IntMap.insert (oid2int oid') typeInfo oidmap'
107+ let !oidmap'' = IntMap.insert (oid2int oid) typeInfo oidmap'
108 return $! (oidmap'', typeInfo)
108 return $! (oidmap'', typeInfo)
109
109
110getAttInfos :: Connection -> [(B.ByteString, PQ.Oid)] -> TypeInfoCache
110getAttInfos :: Connection -> [(B.ByteString, PQ.Oid)] -> TypeInfoCache
src/Database/PostgreSQL/Simple/TypeInfo/Macro.hs+3−9
@@ -1,9 +1,4 @@
1−{-# LANGUAGE CPP #-}
2−#if __GLASGOW_HASKELL__ >= 800
3−{-# LANGUAGE TemplateHaskellQuotes #-}
4−#else
5{-# LANGUAGE TemplateHaskell #-}
1{-# LANGUAGE TemplateHaskell #-}
6−#endif
7
2
8------------------------------------------------------------------------------
3------------------------------------------------------------------------------
9-- |
4-- |
@@ -27,12 +22,11 @@ import Database.PostgreSQL.Simple.TypeInfo.Static
27import Database.PostgreSQL.Simple.Types (Oid(..))
22import Database.PostgreSQL.Simple.Types (Oid(..))
28import Language.Haskell.TH
23import Language.Haskell.TH
29
24
25+
30-- | Returns an expression that has type @'Oid' -> 'Bool'@, true if the
26-- | 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.
27-- oid is equal to any one of the 'typoid's of the given 'TypeInfo's.
32mkCompats :: [TypeInfo] -> ExpQ
28mkCompats :: [TypeInfo] -> ExpQ
33−mkCompats tys = do
34− x <- newName "x"
35− lamE [conP 'Oid [varP x]] $ caseE (varE x) (map alt tys ++ [catchAll])
29+mkCompats tys = [| \(Oid x) -> $(caseE [| x |] (map alt tys ++ [catchAll])) |]
36 where
30 where
37 alt :: TypeInfo -> MatchQ
31 alt :: TypeInfo -> MatchQ
38 alt ty = match (inlineTypoidP ty) (normalB [| True |]) []
32 alt ty = match (inlineTypoidP ty) (normalB [| True |]) []
@@ -44,7 +38,7 @@ mkCompats tys = do
44-- Returns an expression of type 'Oid'. Useful because GHC tends
38-- Returns an expression of type 'Oid'. Useful because GHC tends
45-- not to fold constants.
39-- not to fold constants.
46inlineTypoid :: TypeInfo -> ExpQ
40inlineTypoid :: TypeInfo -> ExpQ
47−inlineTypoid ty = conE 'Oid `appE` litE (getTypoid ty)
41+inlineTypoid ty = [| Oid $(litE (getTypoid ty)) |]
48
42
49inlineTypoidP :: TypeInfo -> PatQ
43inlineTypoidP :: TypeInfo -> PatQ
50inlineTypoidP ty = litP (getTypoid ty)
44inlineTypoidP ty = litP (getTypoid ty)
src/Database/PostgreSQL/Simple/TypeInfo/Static.hs+74−1368
@@ -19,233 +19,53 @@ module Database.PostgreSQL.Simple.TypeInfo.Static
19 ( TypeInfo(..)
19 ( TypeInfo(..)
20 , staticTypeInfo
20 , staticTypeInfo
21 , bool
21 , bool
22− , boolOid
23 , bytea
22 , bytea
24− , byteaOid
25 , char
23 , char
26− , charOid
27 , name
24 , name
28− , nameOid
29 , int8
25 , int8
30− , int8Oid
31 , int2
26 , int2
32− , int2Oid
33 , int4
27 , int4
34− , int4Oid
35 , regproc
28 , regproc
36− , regprocOid
37 , text
29 , text
38− , textOid
39 , oid
30 , oid
40− , oidOid
41 , tid
31 , tid
42− , tidOid
43 , xid
32 , xid
44− , xidOid
45 , cid
33 , cid
46− , cidOid
47 , xml
34 , xml
48− , xmlOid
49 , point
35 , point
50− , pointOid
51 , lseg
36 , lseg
52− , lsegOid
53 , path
37 , path
54− , pathOid
55 , box
38 , box
56− , boxOid
57 , polygon
39 , polygon
58− , polygonOid
59 , line
40 , line
60− , lineOid
61 , cidr
41 , cidr
62− , cidrOid
63 , float4
42 , float4
64− , float4Oid
65 , float8
43 , float8
66− , float8Oid
44+ , abstime
45+ , reltime
46+ , tinterval
67 , unknown
47 , unknown
68− , unknownOid
69 , circle
48 , circle
70− , circleOid
71 , money
49 , money
72− , moneyOid
73 , macaddr
50 , macaddr
74− , macaddrOid
75 , inet
51 , inet
76− , inetOid
77 , bpchar
52 , bpchar
78− , bpcharOid
79 , varchar
53 , varchar
80− , varcharOid
81 , date
54 , date
82− , dateOid
83 , time
55 , time
84− , timeOid
85 , timestamp
56 , timestamp
86− , timestampOid
87 , timestamptz
57 , timestamptz
88− , timestamptzOid
89 , interval
58 , interval
90− , intervalOid
91 , timetz
59 , timetz
92− , timetzOid
93 , bit
60 , bit
94− , bitOid
95 , varbit
61 , varbit
96− , varbitOid
97 , numeric
62 , numeric
98− , numericOid
99 , refcursor
63 , refcursor
100− , refcursorOid
101 , record
64 , record
102− , recordOid
103 , void
65 , 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
66 , uuid
118− , uuidOid
119 , json
67 , json
120− , jsonOid
121 , jsonb
68 , 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
69 ) where
250
70
251import Database.PostgreSQL.LibPQ (Oid(..))
71import Database.PostgreSQL.LibPQ (Oid(..))
@@ -276,6 +96,9 @@ staticTypeInfo (Oid x) = case x of
276 650 -> Just cidr
96 650 -> Just cidr
277 700 -> Just float4
97 700 -> Just float4
278 701 -> Just float8
98 701 -> Just float8
99+ 702 -> Just abstime
100+ 703 -> Just reltime
101+ 704 -> Just tinterval
279 705 -> Just unknown
102 705 -> Just unknown
280 718 -> Just circle
103 718 -> Just circle
281 790 -> Just money
104 790 -> Just money
@@ -295,1508 +118,391 @@ staticTypeInfo (Oid x) = case x of
295 1790 -> Just refcursor
118 1790 -> Just refcursor
296 2249 -> Just record
119 2249 -> Just record
297 2278 -> Just void
120 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
121 2950 -> Just uuid
305 114 -> Just json
122 114 -> Just json
306 3802 -> Just jsonb
123 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
124 _ -> Nothing
371
125
372bool :: TypeInfo
126bool :: TypeInfo
373bool = Basic {
127bool = Basic {
374− typoid = boolOid,
128+ typoid = Oid 16,
375 typcategory = 'B',
129 typcategory = 'B',
376 typdelim = ',',
130 typdelim = ',',
377 typname = "bool"
131 typname = "bool"
378 }
132 }
379
133
380−boolOid :: Oid
381−boolOid = Oid 16
382−{-# INLINE boolOid #-}
383−
384bytea :: TypeInfo
134bytea :: TypeInfo
385bytea = Basic {
135bytea = Basic {
386− typoid = byteaOid,
136+ typoid = Oid 17,
387 typcategory = 'U',
137 typcategory = 'U',
388 typdelim = ',',
138 typdelim = ',',
389 typname = "bytea"
139 typname = "bytea"
390 }
140 }
391
141
392−byteaOid :: Oid
393−byteaOid = Oid 17
394−{-# INLINE byteaOid #-}
395−
396char :: TypeInfo
142char :: TypeInfo
397char = Basic {
143char = Basic {
398− typoid = charOid,
144+ typoid = Oid 18,
399 typcategory = 'S',
145 typcategory = 'S',
400 typdelim = ',',
146 typdelim = ',',
401 typname = "char"
147 typname = "char"
402 }
148 }
403
149
404−charOid :: Oid
405−charOid = Oid 18
406−{-# INLINE charOid #-}
407−
408name :: TypeInfo
150name :: TypeInfo
409name = Basic {
151name = Basic {
410− typoid = nameOid,
152+ typoid = Oid 19,
411 typcategory = 'S',
153 typcategory = 'S',
412 typdelim = ',',
154 typdelim = ',',
413 typname = "name"
155 typname = "name"
414 }
156 }
415
157
416−nameOid :: Oid
417−nameOid = Oid 19
418−{-# INLINE nameOid #-}
419−
420int8 :: TypeInfo
158int8 :: TypeInfo
421int8 = Basic {
159int8 = Basic {
422− typoid = int8Oid,
160+ typoid = Oid 20,
423 typcategory = 'N',
161 typcategory = 'N',
424 typdelim = ',',
162 typdelim = ',',
425 typname = "int8"
163 typname = "int8"
426 }
164 }
427
165
428−int8Oid :: Oid
429−int8Oid = Oid 20
430−{-# INLINE int8Oid #-}
431−
432int2 :: TypeInfo
166int2 :: TypeInfo
433int2 = Basic {
167int2 = Basic {
434− typoid = int2Oid,
168+ typoid = Oid 21,
435 typcategory = 'N',
169 typcategory = 'N',
436 typdelim = ',',
170 typdelim = ',',
437 typname = "int2"
171 typname = "int2"
438 }
172 }
439
173
440−int2Oid :: Oid
441−int2Oid = Oid 21
442−{-# INLINE int2Oid #-}
443−
444int4 :: TypeInfo
174int4 :: TypeInfo
445int4 = Basic {
175int4 = Basic {
446− typoid = int4Oid,
176+ typoid = Oid 23,
447 typcategory = 'N',
177 typcategory = 'N',
448 typdelim = ',',
178 typdelim = ',',
449 typname = "int4"
179 typname = "int4"
450 }
180 }
451
181
452−int4Oid :: Oid
453−int4Oid = Oid 23
454−{-# INLINE int4Oid #-}
455−
456regproc :: TypeInfo
182regproc :: TypeInfo
457regproc = Basic {
183regproc = Basic {
458− typoid = regprocOid,
184+ typoid = Oid 24,
459 typcategory = 'N',
185 typcategory = 'N',
460 typdelim = ',',
186 typdelim = ',',
461 typname = "regproc"
187 typname = "regproc"
462 }
188 }
463
189
464−regprocOid :: Oid
465−regprocOid = Oid 24
466−{-# INLINE regprocOid #-}
467−
468text :: TypeInfo
190text :: TypeInfo
469text = Basic {
191text = Basic {
470− typoid = textOid,
192+ typoid = Oid 25,
471 typcategory = 'S',
193 typcategory = 'S',
472 typdelim = ',',
194 typdelim = ',',
473 typname = "text"
195 typname = "text"
474 }
196 }
475
197
476−textOid :: Oid
477−textOid = Oid 25
478−{-# INLINE textOid #-}
479−
480oid :: TypeInfo
198oid :: TypeInfo
481oid = Basic {
199oid = Basic {
482− typoid = oidOid,
200+ typoid = Oid 26,
483 typcategory = 'N',
201 typcategory = 'N',
484 typdelim = ',',
202 typdelim = ',',
485 typname = "oid"
203 typname = "oid"
486 }
204 }
487
205
488−oidOid :: Oid
489−oidOid = Oid 26
490−{-# INLINE oidOid #-}
491−
492tid :: TypeInfo
206tid :: TypeInfo
493tid = Basic {
207tid = Basic {
494− typoid = tidOid,
208+ typoid = Oid 27,
495 typcategory = 'U',
209 typcategory = 'U',
496 typdelim = ',',
210 typdelim = ',',
497 typname = "tid"
211 typname = "tid"
498 }
212 }
499
213
500−tidOid :: Oid
501−tidOid = Oid 27
502−{-# INLINE tidOid #-}
503−
504xid :: TypeInfo
214xid :: TypeInfo
505xid = Basic {
215xid = Basic {
506− typoid = xidOid,
216+ typoid = Oid 28,
507 typcategory = 'U',
217 typcategory = 'U',
508 typdelim = ',',
218 typdelim = ',',
509 typname = "xid"
219 typname = "xid"
510 }
220 }
511
221
512−xidOid :: Oid
513−xidOid = Oid 28
514−{-# INLINE xidOid #-}
515−
516cid :: TypeInfo
222cid :: TypeInfo
517cid = Basic {
223cid = Basic {
518− typoid = cidOid,
224+ typoid = Oid 29,
519 typcategory = 'U',
225 typcategory = 'U',
520 typdelim = ',',
226 typdelim = ',',
521 typname = "cid"
227 typname = "cid"
522 }
228 }
523
229
524−cidOid :: Oid
525−cidOid = Oid 29
526−{-# INLINE cidOid #-}
527−
528xml :: TypeInfo
230xml :: TypeInfo
529xml = Basic {
231xml = Basic {
530− typoid = xmlOid,
232+ typoid = Oid 142,
531 typcategory = 'U',
233 typcategory = 'U',
532 typdelim = ',',
234 typdelim = ',',
533 typname = "xml"
235 typname = "xml"
534 }
236 }
535
237
536−xmlOid :: Oid
537−xmlOid = Oid 142
538−{-# INLINE xmlOid #-}
539−
540point :: TypeInfo
238point :: TypeInfo
541point = Basic {
239point = Basic {
542− typoid = pointOid,
240+ typoid = Oid 600,
543 typcategory = 'G',
241 typcategory = 'G',
544 typdelim = ',',
242 typdelim = ',',
545 typname = "point"
243 typname = "point"
546 }
244 }
547
245
548−pointOid :: Oid
549−pointOid = Oid 600
550−{-# INLINE pointOid #-}
551−
552lseg :: TypeInfo
246lseg :: TypeInfo
553lseg = Basic {
247lseg = Basic {
554− typoid = lsegOid,
248+ typoid = Oid 601,
555 typcategory = 'G',
249 typcategory = 'G',
556 typdelim = ',',
250 typdelim = ',',
557 typname = "lseg"
251 typname = "lseg"
558 }
252 }
559
253
560−lsegOid :: Oid
561−lsegOid = Oid 601
562−{-# INLINE lsegOid #-}
563−
564path :: TypeInfo
254path :: TypeInfo
565path = Basic {
255path = Basic {
566− typoid = pathOid,
256+ typoid = Oid 602,
567 typcategory = 'G',
257 typcategory = 'G',
568 typdelim = ',',
258 typdelim = ',',
569 typname = "path"
259 typname = "path"
570 }
260 }
571
261
572−pathOid :: Oid
573−pathOid = Oid 602
574−{-# INLINE pathOid #-}
575−
576box :: TypeInfo
262box :: TypeInfo
577box = Basic {
263box = Basic {
578− typoid = boxOid,
264+ typoid = Oid 603,
579 typcategory = 'G',
265 typcategory = 'G',
580 typdelim = ';',
266 typdelim = ';',
581 typname = "box"
267 typname = "box"
582 }
268 }
583
269
584−boxOid :: Oid
585−boxOid = Oid 603
586−{-# INLINE boxOid #-}
587−
588polygon :: TypeInfo
270polygon :: TypeInfo
589polygon = Basic {
271polygon = Basic {
590− typoid = polygonOid,
272+ typoid = Oid 604,
591 typcategory = 'G',
273 typcategory = 'G',
592 typdelim = ',',
274 typdelim = ',',
593 typname = "polygon"
275 typname = "polygon"
594 }
276 }
595
277
596−polygonOid :: Oid
597−polygonOid = Oid 604
598−{-# INLINE polygonOid #-}
599−
600line :: TypeInfo
278line :: TypeInfo
601line = Basic {
279line = Basic {
602− typoid = lineOid,
280+ typoid = Oid 628,
603 typcategory = 'G',
281 typcategory = 'G',
604 typdelim = ',',
282 typdelim = ',',
605 typname = "line"
283 typname = "line"
606 }
284 }
607
285
608−lineOid :: Oid
609−lineOid = Oid 628
610−{-# INLINE lineOid #-}
611−
612cidr :: TypeInfo
286cidr :: TypeInfo
613cidr = Basic {
287cidr = Basic {
614− typoid = cidrOid,
288+ typoid = Oid 650,
615 typcategory = 'I',
289 typcategory = 'I',
616 typdelim = ',',
290 typdelim = ',',
617 typname = "cidr"
291 typname = "cidr"
618 }
292 }
619
293
620−cidrOid :: Oid
621−cidrOid = Oid 650
622−{-# INLINE cidrOid #-}
623−
624float4 :: TypeInfo
294float4 :: TypeInfo
625float4 = Basic {
295float4 = Basic {
626− typoid = float4Oid,
296+ typoid = Oid 700,
627 typcategory = 'N',
297 typcategory = 'N',
628 typdelim = ',',
298 typdelim = ',',
629 typname = "float4"
299 typname = "float4"
630 }
300 }
631
301
632−float4Oid :: Oid
633−float4Oid = Oid 700
634−{-# INLINE float4Oid #-}
635−
636float8 :: TypeInfo
302float8 :: TypeInfo
637float8 = Basic {
303float8 = Basic {
638− typoid = float8Oid,
304+ typoid = Oid 701,
639 typcategory = 'N',
305 typcategory = 'N',
640 typdelim = ',',
306 typdelim = ',',
641 typname = "float8"
307 typname = "float8"
642 }
308 }
643
309
644−float8Oid :: Oid
310+abstime :: TypeInfo
645−float8Oid = Oid 701
311+abstime = Basic {
646−{-# INLINE float8Oid #-}
312+ typoid = Oid 702,
313+ typcategory = 'D',
314+ typdelim = ',',
315+ typname = "abstime"
316+ }
317+
318+reltime :: TypeInfo
319+reltime = Basic {
320+ typoid = Oid 703,
321+ typcategory = 'T',
322+ typdelim = ',',
323+ typname = "reltime"
324+ }
325+
326+tinterval :: TypeInfo
327+tinterval = Basic {
328+ typoid = Oid 704,
329+ typcategory = 'T',
330+ typdelim = ',',
331+ typname = "tinterval"
332+ }
647
333
648unknown :: TypeInfo
334unknown :: TypeInfo
649unknown = Basic {
335unknown = Basic {
650− typoid = unknownOid,
336+ typoid = Oid 705,
651 typcategory = 'X',
337 typcategory = 'X',
652 typdelim = ',',
338 typdelim = ',',
653 typname = "unknown"
339 typname = "unknown"
654 }
340 }
655
341
656−unknownOid :: Oid
657−unknownOid = Oid 705
658−{-# INLINE unknownOid #-}
659−
660circle :: TypeInfo
342circle :: TypeInfo
661circle = Basic {
343circle = Basic {
662− typoid = circleOid,
344+ typoid = Oid 718,
663 typcategory = 'G',
345 typcategory = 'G',
664 typdelim = ',',
346 typdelim = ',',
665 typname = "circle"
347 typname = "circle"
666 }
348 }
667
349
668−circleOid :: Oid
669−circleOid = Oid 718
670−{-# INLINE circleOid #-}
671−
672money :: TypeInfo
350money :: TypeInfo
673money = Basic {
351money = Basic {
674− typoid = moneyOid,
352+ typoid = Oid 790,
675 typcategory = 'N',
353 typcategory = 'N',
676 typdelim = ',',
354 typdelim = ',',
677 typname = "money"
355 typname = "money"
678 }
356 }
679
357
680−moneyOid :: Oid
681−moneyOid = Oid 790
682−{-# INLINE moneyOid #-}
683−
684macaddr :: TypeInfo
358macaddr :: TypeInfo
685macaddr = Basic {
359macaddr = Basic {
686− typoid = macaddrOid,
360+ typoid = Oid 829,
687 typcategory = 'U',
361 typcategory = 'U',
688 typdelim = ',',
362 typdelim = ',',
689 typname = "macaddr"
363 typname = "macaddr"
690 }
364 }
691
365
692−macaddrOid :: Oid
693−macaddrOid = Oid 829
694−{-# INLINE macaddrOid #-}
695−
696inet :: TypeInfo
366inet :: TypeInfo
697inet = Basic {
367inet = Basic {
698− typoid = inetOid,
368+ typoid = Oid 869,
699 typcategory = 'I',
369 typcategory = 'I',
700 typdelim = ',',
370 typdelim = ',',
701 typname = "inet"
371 typname = "inet"
702 }
372 }
703
373
704−inetOid :: Oid
705−inetOid = Oid 869
706−{-# INLINE inetOid #-}
707−
708bpchar :: TypeInfo
374bpchar :: TypeInfo
709bpchar = Basic {
375bpchar = Basic {
710− typoid = bpcharOid,
376+ typoid = Oid 1042,
711 typcategory = 'S',
377 typcategory = 'S',
712 typdelim = ',',
378 typdelim = ',',
713 typname = "bpchar"
379 typname = "bpchar"
714 }
380 }
715
381
716−bpcharOid :: Oid
717−bpcharOid = Oid 1042
718−{-# INLINE bpcharOid #-}
719−
720varchar :: TypeInfo
382varchar :: TypeInfo
721varchar = Basic {
383varchar = Basic {
722− typoid = varcharOid,
384+ typoid = Oid 1043,
723 typcategory = 'S',
385 typcategory = 'S',
724 typdelim = ',',
386 typdelim = ',',
725 typname = "varchar"
387 typname = "varchar"
726 }
388 }
727
389
728−varcharOid :: Oid
729−varcharOid = Oid 1043
730−{-# INLINE varcharOid #-}
731−
732date :: TypeInfo
390date :: TypeInfo
733date = Basic {
391date = Basic {
734− typoid = dateOid,
392+ typoid = Oid 1082,
735 typcategory = 'D',
393 typcategory = 'D',
736 typdelim = ',',
394 typdelim = ',',
737 typname = "date"
395 typname = "date"
738 }
396 }
739
397
740−dateOid :: Oid
741−dateOid = Oid 1082
742−{-# INLINE dateOid #-}
743−
744time :: TypeInfo
398time :: TypeInfo
745time = Basic {
399time = Basic {
746− typoid = timeOid,
400+ typoid = Oid 1083,
747 typcategory = 'D',
401 typcategory = 'D',
748 typdelim = ',',
402 typdelim = ',',
749 typname = "time"
403 typname = "time"
750 }
404 }
751
405
752−timeOid :: Oid
753−timeOid = Oid 1083
754−{-# INLINE timeOid #-}
755−
756timestamp :: TypeInfo
406timestamp :: TypeInfo
757timestamp = Basic {
407timestamp = Basic {
758− typoid = timestampOid,
408+ typoid = Oid 1114,
759 typcategory = 'D',
409 typcategory = 'D',
760 typdelim = ',',
410 typdelim = ',',
761 typname = "timestamp"
411 typname = "timestamp"
762 }
412 }
763
413
764−timestampOid :: Oid
765−timestampOid = Oid 1114
766−{-# INLINE timestampOid #-}
767−
768timestamptz :: TypeInfo
414timestamptz :: TypeInfo
769timestamptz = Basic {
415timestamptz = Basic {
770− typoid = timestamptzOid,
416+ typoid = Oid 1184,
771 typcategory = 'D',
417 typcategory = 'D',
772 typdelim = ',',
418 typdelim = ',',
773 typname = "timestamptz"
419 typname = "timestamptz"
774 }
420 }
775
421
776−timestamptzOid :: Oid
777−timestamptzOid = Oid 1184
778−{-# INLINE timestamptzOid #-}
779−
780interval :: TypeInfo
422interval :: TypeInfo
781interval = Basic {
423interval = Basic {
782− typoid = intervalOid,
424+ typoid = Oid 1186,
783 typcategory = 'T',
425 typcategory = 'T',
784 typdelim = ',',
426 typdelim = ',',
785 typname = "interval"
427 typname = "interval"
786 }
428 }
787
429
788−intervalOid :: Oid
789−intervalOid = Oid 1186
790−{-# INLINE intervalOid #-}
791−
792timetz :: TypeInfo
430timetz :: TypeInfo
793timetz = Basic {
431timetz = Basic {
794− typoid = timetzOid,
432+ typoid = Oid 1266,
795 typcategory = 'D',
433 typcategory = 'D',
796 typdelim = ',',
434 typdelim = ',',
797 typname = "timetz"
435 typname = "timetz"
798 }
436 }
799
437
800−timetzOid :: Oid
801−timetzOid = Oid 1266
802−{-# INLINE timetzOid #-}
803−
804bit :: TypeInfo
438bit :: TypeInfo
805bit = Basic {
439bit = Basic {
806− typoid = bitOid,
440+ typoid = Oid 1560,
807 typcategory = 'V',
441 typcategory = 'V',
808 typdelim = ',',
442 typdelim = ',',
809 typname = "bit"
443 typname = "bit"
810 }
444 }
811
445
812−bitOid :: Oid
813−bitOid = Oid 1560
814−{-# INLINE bitOid #-}
815−
816varbit :: TypeInfo
446varbit :: TypeInfo
817varbit = Basic {
447varbit = Basic {
818− typoid = varbitOid,
448+ typoid = Oid 1562,
819 typcategory = 'V',
449 typcategory = 'V',
820 typdelim = ',',
450 typdelim = ',',
821 typname = "varbit"
451 typname = "varbit"
822 }
452 }
823
453
824−varbitOid :: Oid
825−varbitOid = Oid 1562
826−{-# INLINE varbitOid #-}
827−
828numeric :: TypeInfo
454numeric :: TypeInfo
829numeric = Basic {
455numeric = Basic {
830− typoid = numericOid,
456+ typoid = Oid 1700,
831 typcategory = 'N',
457 typcategory = 'N',
832 typdelim = ',',
458 typdelim = ',',
833 typname = "numeric"
459 typname = "numeric"
834 }
460 }
835
461
836−numericOid :: Oid
837−numericOid = Oid 1700
838−{-# INLINE numericOid #-}
839−
840refcursor :: TypeInfo
462refcursor :: TypeInfo
841refcursor = Basic {
463refcursor = Basic {
842− typoid = refcursorOid,
464+ typoid = Oid 1790,
843 typcategory = 'U',
465 typcategory = 'U',
844 typdelim = ',',
466 typdelim = ',',
845 typname = "refcursor"
467 typname = "refcursor"
846 }
468 }
847
469
848−refcursorOid :: Oid
849−refcursorOid = Oid 1790
850−{-# INLINE refcursorOid #-}
851−
852record :: TypeInfo
470record :: TypeInfo
853record = Basic {
471record = Basic {
854− typoid = recordOid,
472+ typoid = Oid 2249,
855 typcategory = 'P',
473 typcategory = 'P',
856 typdelim = ',',
474 typdelim = ',',
857 typname = "record"
475 typname = "record"
858 }
476 }
859
477
860−recordOid :: Oid
861−recordOid = Oid 2249
862−{-# INLINE recordOid #-}
863−
864void :: TypeInfo
478void :: TypeInfo
865void = Basic {
479void = Basic {
866− typoid = voidOid,
480+ typoid = Oid 2278,
867 typcategory = 'P',
481 typcategory = 'P',
868 typdelim = ',',
482 typdelim = ',',
869 typname = "void"
483 typname = "void"
870 }
484 }
871
485
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−
949uuid :: TypeInfo
486uuid :: TypeInfo
950uuid = Basic {
487uuid = Basic {
951− typoid = uuidOid,
488+ typoid = Oid 2950,
952 typcategory = 'U',
489 typcategory = 'U',
953 typdelim = ',',
490 typdelim = ',',
954 typname = "uuid"
491 typname = "uuid"
955 }
492 }
956
493
957−uuidOid :: Oid
958−uuidOid = Oid 2950
959−{-# INLINE uuidOid #-}
960−
961json :: TypeInfo
494json :: TypeInfo
962json = Basic {
495json = Basic {
963− typoid = jsonOid,
496+ typoid = Oid 114,
964 typcategory = 'U',
497 typcategory = 'U',
965 typdelim = ',',
498 typdelim = ',',
966 typname = "json"
499 typname = "json"
967 }
500 }
968
501
969−jsonOid :: Oid
970−jsonOid = Oid 114
971−{-# INLINE jsonOid #-}
972−
973jsonb :: TypeInfo
502jsonb :: TypeInfo
974jsonb = Basic {
503jsonb = Basic {
975− typoid = jsonbOid,
504+ typoid = Oid 3802,
976 typcategory = 'U',
505 typcategory = 'U',
977 typdelim = ',',
506 typdelim = ',',
978 typname = "jsonb"
507 typname = "jsonb"
979 }
508 }
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/Types.hs+33−57
@@ -1,4 +1,4 @@
1−{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, GeneralizedNewtypeDeriving #-}
1+{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, GeneralizedNewtypeDeriving #-}
2
2
3------------------------------------------------------------------------------
3------------------------------------------------------------------------------
4-- |
4-- |
@@ -30,26 +30,27 @@ module Database.PostgreSQL.Simple.Types
30 , Values(..)
30 , Values(..)
31 ) where
31 ) where
32
32
33+import Blaze.ByteString.Builder (toByteString)
33import Control.Arrow (first)
34import Control.Arrow (first)
34import Data.ByteString (ByteString)
35import Data.ByteString (ByteString)
35import Data.Hashable (Hashable(hashWithSalt))
36import Data.Hashable (Hashable(hashWithSalt))
36−import Data.Foldable (toList)
37import Data.Monoid (Monoid(..))
37import Data.Monoid (Monoid(..))
38−import Data.Semigroup
39import Data.String (IsString(..))
38import Data.String (IsString(..))
40import Data.Typeable (Typeable)
39import Data.Typeable (Typeable)
41−import Data.ByteString.Builder ( stringUtf8 )
40+import qualified Blaze.ByteString.Builder.Char.Utf8 as Utf8
42import qualified Data.ByteString as B
41import qualified Data.ByteString as B
43import Data.Text (Text)
42import Data.Text (Text)
44import qualified Data.Text as T
43import qualified Data.Text as T
45−import Data.Tuple.Only (Only(..))
46import Database.PostgreSQL.LibPQ (Oid(..))
44import Database.PostgreSQL.LibPQ (Oid(..))
47−import Database.PostgreSQL.Simple.Compat (toByteString)
48
45
49-- | A placeholder for the SQL @NULL@ value.
46-- | A placeholder for the SQL @NULL@ value.
50data Null = Null
47data Null = Null
51 deriving (Read, Show, Typeable)
48 deriving (Read, Show, Typeable)
52
49
50+instance Eq Null where
51+ _ == _ = False
52+ _ /= _ = False
53+
53-- | A placeholder for the PostgreSQL @DEFAULT@ value.
54-- | A placeholder for the PostgreSQL @DEFAULT@ value.
54data Default = Default
55data Default = Default
55 deriving (Read, Show, Typeable)
56 deriving (Read, Show, Typeable)
@@ -84,61 +85,38 @@ instance Read Query where
84 readsPrec i = fmap (first Query) . readsPrec i
85 readsPrec i = fmap (first Query) . readsPrec i
85
86
86instance IsString Query where
87instance IsString Query where
87− fromString = Query . toByteString . stringUtf8
88+ fromString = Query . toByteString . Utf8.fromString
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)
93
89
94instance Monoid Query where
90instance Monoid Query where
95 mempty = Query B.empty
91 mempty = Query B.empty
92+ mappend (Query a) (Query b) = Query (B.append a b)
93+ {-# INLINE mappend #-}
94+ mconcat xs = Query (B.concat (map fromQuery xs))
96
95
97−-- | Wrap a list of values for use in an @IN@ clause. Replaces a
96+-- | A single-value \"collection\".
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--
97--
105−-- Note that @In []@ expands to @(null)@, which works as expected in
98+-- This is useful if you need to supply a single parameter to a SQL
106−-- the query above, but evaluates to the logical null value on every
99+-- query, or extract a single column from a SQL result.
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.
110--
100--
111−-- Since postgresql doesn't seem to provide a syntax for actually specifying
101+-- Parameter example:
112−-- an empty list, which could solve this completely, there are two
113−-- workarounds particularly worth mentioning, namely:
114--
102--
115−-- 1. Use postgresql-simple's 'Values' type instead, which can handle the
103+-- @query c \"select x from scores where x > ?\" ('Only' (42::Int))@
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.
120--
104--
121−-- > query c "select * from whatever where id not in ?"
105+-- Result example:
122−-- > (Only (Values ["int4"] [] :: Values (Only Int)))
123--
106--
107+-- @xs <- query_ c \"select id from users\"
108+--forM_ xs $ \\('Only' id) -> {- ... -}@
109+newtype Only a = Only {
110+ fromOnly :: a
111+ } deriving (Eq, Ord, Read, Show, Typeable, Functor)
112+
113+-- | Wrap a list of values for use in an @IN@ clause. Replaces a
114+-- single \"@?@\" character with a parenthesized list of rendered
115+-- values.
124--
116--
125−-- 2. Use sql's @COALESCE@ operator to turn a logical @null@ into the correct
117+-- Example:
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]))
131−--
132−-- > query c "select * from whatever where coalesce(id IN ?, FALSE)"
133−-- > (Only (In [] :: In [Int]))
134--
118--
135−-- Note that at as of PostgreSQL 9.4, the query planner cannot see inside
119+-- > query c "select * from whatever where id in ?" (Only (In [3,4,5]))
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−
142newtype In a = In a
120newtype In a = In a
143 deriving (Eq, Ord, Read, Show, Typeable, Functor)
121 deriving (Eq, Ord, Read, Show, Typeable, Functor)
144
122
@@ -201,9 +179,8 @@ infixr 3 :.
201newtype Savepoint = Savepoint Query
179newtype Savepoint = Savepoint Query
202 deriving (Eq, Ord, Show, Read, Typeable)
180 deriving (Eq, Ord, Show, Read, Typeable)
203
181
204−-- | Represents a @VALUES@ table literal, usable as an alternative to
182+-- | Represents a @VALUES@ table literal, usable as an alternative
205−-- 'Database.PostgreSQL.Simple.executeMany' and
206−-- 'Database.PostgreSQL.Simple.returning'. The main advantage is that
183+-- to @executeMany@ and @returning@. The main advantage is that
207-- you can parametrize more than just a single @VALUES@ expression.
184-- you can parametrize more than just a single @VALUES@ expression.
208-- For example, here's a query to insert a thing into one table
185-- For example, here's a query to insert a thing into one table
209-- and some attributes of that thing into another, returning the
186-- and some attributes of that thing into another, returning the
@@ -216,7 +193,7 @@ newtype Savepoint = Savepoint Query
216-- > ), new_attributes AS (
193-- > ), new_attributes AS (
217-- > INSERT INTO thing_attributes
194-- > INSERT INTO thing_attributes
218-- > SELECT new_thing.id, attrs.*
195-- > SELECT new_thing.id, attrs.*
219−-- > FROM new_thing JOIN ? attrs ON TRUE
196+-- > FROM new_thing JOIN ? attrs
220-- > ) SELECT * FROM new_thing
197-- > ) SELECT * FROM new_thing
221-- > |] ("foo", Values [ "int4", "text" ]
198-- > |] ("foo", Values [ "int4", "text" ]
222-- > [ ( 1 , "hello" )
199-- > [ ( 1 , "hello" )
@@ -242,8 +219,7 @@ newtype Savepoint = Savepoint Query
242-- is turned into a properly quoted identifier, the type name is case
219-- 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,
220-- sensitive and must be as it appears in the @pg_type@ table. Thus,
244-- you must write @timestamptz@ instead of @timestamp with time zone@,
221-- you must write @timestamptz@ instead of @timestamp with time zone@,
245−-- @int4@ instead of @integer@ or @serial@, @_int8@ instead of @bigint[]@,
222+-- @int4@ instead of @integer@, @_int8@ instead of @bigint[]@, etcetera.
246−-- etcetera.
247--
223--
248-- You may omit the type names, however, if you do so the list
224-- 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
225-- of values must be non-empty, and postgresql must be able to infer
@@ -252,7 +228,7 @@ newtype Savepoint = Savepoint Query
252-- without issuing the query. In the second case, the postgres server
228-- without issuing the query. In the second case, the postgres server
253-- will return an error which will be turned into a @SqlError@ exception.
229-- will return an error which will be turned into a @SqlError@ exception.
254--
230--
255−-- See <https://www.postgresql.org/docs/9.5/static/sql-values.html> for
231+-- See <http://www.postgresql.org/docs/9.3/static/sql-values.html> for
256-- more information.
232-- more information.
257data Values a = Values [QualifiedIdentifier] [a]
233data Values a = Values [QualifiedIdentifier] [a]
258 deriving (Eq, Ord, Show, Read, Typeable)
234 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.hs+2−2
@@ -1,6 +1,6 @@
1module Common (
1module Common (
2 module Database.PostgreSQL.Simple,
2 module Database.PostgreSQL.Simple,
3− module Test.Tasty.HUnit,
3+ module Test.HUnit,
4 TestEnv(..),
4 TestEnv(..),
5 md5,
5 md5,
6) where
6) where
@@ -8,7 +8,7 @@ module Common (
8import Data.ByteString (ByteString)
8import Data.ByteString (ByteString)
9import Data.Text (Text)
9import Data.Text (Text)
10import Database.PostgreSQL.Simple
10import Database.PostgreSQL.Simple
11−import Test.Tasty.HUnit
11+import Test.HUnit
12
12
13import qualified Crypto.Hash.MD5 as MD5
13import qualified Crypto.Hash.MD5 as MD5
14import qualified Data.ByteString.Base16 as Base16
14import qualified Data.ByteString.Base16 as Base16
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.hs+59−345
@@ -1,95 +1,53 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DeriveGeneric #-}
3{-# LANGUAGE DeriveDataTypeable #-}
1{-# LANGUAGE DeriveDataTypeable #-}
4{-# LANGUAGE DoAndIfThenElse #-}
2{-# LANGUAGE DoAndIfThenElse #-}
5{-# LANGUAGE ScopedTypeVariables #-}
3{-# LANGUAGE ScopedTypeVariables #-}
6−#if __GLASGOW_HASKELL__ >= 806
7−{-# LANGUAGE DerivingStrategies #-}
8−{-# LANGUAGE DerivingVia #-}
9−{-# LANGUAGE DeriveAnyClass #-}
10−#endif
11−module Main (main) where
12−
13import Common
4import Common
14−import Database.PostgreSQL.Simple.Copy
15−import Database.PostgreSQL.Simple.ToField (ToField)
16import Database.PostgreSQL.Simple.FromField (FromField)
5import Database.PostgreSQL.Simple.FromField (FromField)
6+import Database.PostgreSQL.Simple.Types(Query(..),Values(..))
17import Database.PostgreSQL.Simple.HStore
7import Database.PostgreSQL.Simple.HStore
18−import Database.PostgreSQL.Simple.Newtypes
8+import Database.PostgreSQL.Simple.Copy
19−import Database.PostgreSQL.Simple.Internal (breakOnSingleQuestionMark)
20−import Database.PostgreSQL.Simple.Types(Query(..),Values(..), PGArray(..))
21import qualified Database.PostgreSQL.Simple.Transaction as ST
9import qualified Database.PostgreSQL.Simple.Transaction as ST
22−
23import Control.Applicative
10import Control.Applicative
24import Control.Exception as E
11import Control.Exception as E
25import Control.Monad
12import Control.Monad
26−import Data.Char
13+import Data.ByteString (ByteString)
27−import Data.Foldable (toList)
28−import Data.List (concat, sort)
29import Data.IORef
14import Data.IORef
30−import Data.Monoid ((<>))
31−import Data.String (fromString)
32import Data.Typeable
15import Data.Typeable
33−import GHC.Generics (Generic)
34−
35−import Data.Aeson
36−import Data.ByteString (ByteString)
37import qualified Data.ByteString as B
16import 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
42import Data.Map (Map)
17import Data.Map (Map)
18+import Data.List (sort)
43import qualified Data.Map as Map
19import qualified Data.Map as Map
44import Data.Text(Text)
20import Data.Text(Text)
45import qualified Data.Text.Encoding as T
21import qualified Data.Text.Encoding as T
22+import System.Exit (exitFailure)
23+import System.IO
46import qualified Data.Vector as V
24import qualified Data.Vector as V
47−import System.FilePath
25+import Data.Aeson
48−import System.Timeout(timeout)
49−import Data.Time.Compat (getCurrentTime, diffUTCTime)
50−import System.Environment (getEnvironment)
51
26
52−import Test.Tasty
53−import Test.Tasty.Golden
54import Notify
27import Notify
55import Serializable
28import Serializable
56import Time
29import Time
57−import Interval
30+
58−import Exception (testExceptions)
59−
60−tests :: TestEnv -> TestTree
31+tests :: [TestEnv -> Test]
61−tests env = testGroup "tests"
32+tests =
62− $ map ($ env)
63− [ testBytea
33+ [ TestLabel "Bytea" . testBytea
64− , testCase "ExecuteMany" . testExecuteMany
34+ , TestLabel "ExecuteMany" . testExecuteMany
65− , testCase "Fold" . testFold
35+ , TestLabel "Fold" . testFold
66− , testCase "Notify" . testNotify
36+ , TestLabel "Notify" . testNotify
67− , testCase "Serializable" . testSerializable
37+ , TestLabel "Serializable" . testSerializable
68− , testCase "Time" . testTime
38+ , TestLabel "Time" . testTime
69− , testCase "Interval" . testInterval
70− , testCase "Array" . testArray
39+ , TestLabel "Array" . testArray
71− , testCase "Array of nullables" . testNullableArray
72− , testCase "HStore" . testHStore
40+ , TestLabel "HStore" . testHStore
73− , testCase "citext" . testCIText
74− , testCase "JSON" . testJSON
41+ , TestLabel "JSON" . testJSON
75− , testCase "Aeson newtype" . testAeson
76− , testCase "DerivingVia" . testDerivingVia
77− , testCase "Question mark escape" . testQM
78− , testCase "Savepoint" . testSavepoint
42+ , TestLabel "Savepoint" . testSavepoint
79− , testCase "Unicode" . testUnicode
43+ , TestLabel "Unicode" . testUnicode
80− , testCase "Values" . testValues
44+ , TestLabel "Values" . testValues
81− , testCase "Copy" . testCopy
45+ , TestLabel "Copy" . testCopy
82− , testCopyFailures
83− , testCase "Double" . testDouble
46+ , TestLabel "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 ]
47 ]
90
48
91−testBytea :: TestEnv -> TestTree
49+testBytea :: TestEnv -> Test
92−testBytea TestEnv{..} = testGroup "Bytea"
50+testBytea TestEnv{..} = TestList
93 [ testStr "empty" []
51 [ testStr "empty" []
94 , testStr "\"hello\"" $ map (fromIntegral . fromEnum) ("hello" :: String)
52 , testStr "\"hello\"" $ map (fromIntegral . fromEnum) ("hello" :: String)
95 , testStr "ascending" [0..255]
53 , testStr "ascending" [0..255]
@@ -98,7 +56,7 @@ testBytea TestEnv{..} = testGroup "Bytea"
98 , testStr "descending, doubled up" $ doubleUp [255,254..0]
56 , testStr "descending, doubled up" $ doubleUp [255,254..0]
99 ]
57 ]
100 where
58 where
101− testStr label bytes = testCase label $ do
59+ testStr label bytes = TestLabel label $ TestCase $ do
102 let bs = B.pack bytes
60 let bs = B.pack bytes
103
61
104 [Only h] <- query conn "SELECT md5(?::bytea)" [Binary bs]
62 [Only h] <- query conn "SELECT md5(?::bytea)" [Binary bs]
@@ -109,8 +67,8 @@ testBytea TestEnv{..} = testGroup "Bytea"
109
67
110 doubleUp = concatMap (\x -> [x, x])
68 doubleUp = concatMap (\x -> [x, x])
111
69
112−testExecuteMany :: TestEnv -> Assertion
70+testExecuteMany :: TestEnv -> Test
113−testExecuteMany TestEnv{..} = do
71+testExecuteMany TestEnv{..} = TestCase $ do
114 execute_ conn "CREATE TEMPORARY TABLE tmp_executeMany (i INT, t TEXT, b BYTEA)"
72 execute_ conn "CREATE TEMPORARY TABLE tmp_executeMany (i INT, t TEXT, b BYTEA)"
115
73
116 let rows :: [(Int, String, Binary ByteString)]
74 let rows :: [(Int, String, Binary ByteString)]
@@ -127,8 +85,8 @@ testExecuteMany TestEnv{..} = do
127
85
128 return ()
86 return ()
129
87
130−testFold :: TestEnv -> Assertion
88+testFold :: TestEnv -> Test
131−testFold TestEnv{..} = do
89+testFold TestEnv{..} = TestCase $ do
132 xs <- fold_ conn "SELECT generate_series(1,10000)"
90 xs <- fold_ conn "SELECT generate_series(1,10000)"
133 [] $ \xs (Only x) -> return (x:xs)
91 [] $ \xs (Only x) -> return (x:xs)
134 reverse xs @?= ([1..10000] :: [Int])
92 reverse xs @?= ([1..10000] :: [Int])
@@ -139,7 +97,7 @@ testFold TestEnv{..} = do
139 xs <- readIORef ref
97 xs <- readIORef ref
140 writeIORef ref $! (a,b):xs
98 writeIORef ref $! (a,b):xs
141 xs <- readIORef ref
99 xs <- readIORef ref
142− reverse xs @?= [(a,b) | b <- [1..50], a <- [1..100]]
100+ reverse xs @?= [(a,b) | a <- [1..100], b <- [1..50]]
143
101
144 -- Make sure fold propagates our exception.
102 -- Make sure fold propagates our exception.
145 ref <- newIORef []
103 ref <- newIORef []
@@ -197,8 +155,8 @@ queryFailure conn q resultType = do
197 ++ show (typeOf resultType)
155 ++ show (typeOf resultType)
198 ++ " -> " ++ show val)
156 ++ " -> " ++ show val)
199
157
200−testArray :: TestEnv -> Assertion
158+testArray :: TestEnv -> Test
201−testArray TestEnv{..} = do
159+testArray TestEnv{..} = TestCase $ do
202 xs <- query_ conn "SELECT '{1,2,3,4}'::_int4"
160 xs <- query_ conn "SELECT '{1,2,3,4}'::_int4"
203 xs @?= [Only (V.fromList [1,2,3,4 :: Int])]
161 xs @?= [Only (V.fromList [1,2,3,4 :: Int])]
204 xs <- query_ conn "SELECT '{{1,2},{3,4}}'::_int4"
162 xs <- query_ conn "SELECT '{{1,2},{3,4}}'::_int4"
@@ -207,16 +165,8 @@ testArray TestEnv{..} = do
207 queryFailure conn "SELECT '{1,2,3,4}'::_int4" (undefined :: V.Vector Bool)
165 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)
166 queryFailure conn "SELECT '{{1,2},{3,4}}'::_int4" (undefined :: V.Vector Int)
209
167
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
168+testHStore :: TestEnv -> Test
219−testHStore TestEnv{..} = do
169+testHStore TestEnv{..} = TestCase $ do
220 execute_ conn "CREATE EXTENSION IF NOT EXISTS hstore"
170 execute_ conn "CREATE EXTENSION IF NOT EXISTS hstore"
221 roundTrip []
171 roundTrip []
222 roundTrip [("foo","bar"),("bar","baz"),("baz","hello")]
172 roundTrip [("foo","bar"),("bar","baz"),("baz","hello")]
@@ -228,27 +178,12 @@ testHStore TestEnv{..} = do
228 m' <- query conn "SELECT ?::hstore" m
178 m' <- query conn "SELECT ?::hstore" m
229 [m] @?= m'
179 [m] @?= m'
230
180
231−testCIText :: TestEnv -> Assertion
181+testJSON :: TestEnv -> Test
232−testCIText TestEnv{..} = do
182+testJSON TestEnv{..} = TestCase $ 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)
183 roundTrip (Map.fromList [] :: Map Text Text)
247 roundTrip (Map.fromList [("foo","bar"),("bar","baz"),("baz","hello")] :: Map Text Text)
184 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)
185 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])
186 roundTrip (V.fromList [1,2,3,4,5::Int])
250− roundTrip ("foo" :: Text)
251− roundTrip (42 :: Int)
252 where
187 where
253 roundTrip :: ToJSON a => a -> Assertion
188 roundTrip :: ToJSON a => a -> Assertion
254 roundTrip a = do
189 roundTrip a = do
@@ -256,92 +191,8 @@ testJSON TestEnv{..} = do
256 js' <- query conn "SELECT ?::json" js
191 js' <- query conn "SELECT ?::json" js
257 [js] @?= js'
192 [js] @?= js'
258
193
259−testAeson :: TestEnv -> Assertion
194+testSavepoint :: TestEnv -> Test
260−testAeson TestEnv{..} = do
195+testSavepoint TestEnv{..} = TestCase $ 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 $
196 True <- expectError ST.isNoActiveTransactionError $
346 withSavepoint conn $ return ()
197 withSavepoint conn $ return ()
347
198
@@ -401,8 +252,8 @@ testSavepoint TestEnv{..} = do
401
252
402 return ()
253 return ()
403
254
404−testUnicode :: TestEnv -> Assertion
255+testUnicode :: TestEnv -> Test
405−testUnicode TestEnv{..} = do
256+testUnicode TestEnv{..} = TestCase $ do
406 let q = Query . T.encodeUtf8 -- Handle encoding ourselves to ensure
257 let q = Query . T.encodeUtf8 -- Handle encoding ourselves to ensure
407 -- the table gets created correctly.
258 -- the table gets created correctly.
408 let messages = map Only ["привет","мир"] :: [Only Text]
259 let messages = map Only ["привет","мир"] :: [Only Text]
@@ -411,8 +262,8 @@ testUnicode TestEnv{..} = do
411 messages' <- query_ conn "SELECT сообщение FROM ру́сский"
262 messages' <- query_ conn "SELECT сообщение FROM ру́сский"
412 sort messages @?= sort messages'
263 sort messages @?= sort messages'
413
264
414−testValues :: TestEnv -> Assertion
265+testValues :: TestEnv -> Test
415−testValues TestEnv{..} = do
266+testValues TestEnv{..} = TestCase $ do
416 execute_ conn "CREATE TEMPORARY TABLE values_test (x int, y text)"
267 execute_ conn "CREATE TEMPORARY TABLE values_test (x int, y text)"
417 test (Values ["int4","text"] [])
268 test (Values ["int4","text"] [])
418 test (Values ["int4","text"] [(1,"hello")])
269 test (Values ["int4","text"] [(1,"hello")])
@@ -429,8 +280,8 @@ testValues TestEnv{..} = do
429 sort vals @?= sort vals'
280 sort vals @?= sort vals'
430
281
431
282
432−testCopy :: TestEnv -> Assertion
283+testCopy :: TestEnv -> Test
433−testCopy TestEnv{..} = do
284+testCopy TestEnv{..} = TestCase $ do
434 execute_ conn "CREATE TEMPORARY TABLE copy_test (x int, y text)"
285 execute_ conn "CREATE TEMPORARY TABLE copy_test (x int, y text)"
435 copy_ conn "COPY copy_test FROM STDIN (FORMAT CSV)"
286 copy_ conn "COPY copy_test FROM STDIN (FORMAT CSV)"
436 mapM_ (putCopyData conn) copyRows
287 mapM_ (putCopyData conn) copyRows
@@ -447,14 +298,6 @@ testCopy TestEnv{..} = do
447 -- so that we can issue more queries:
298 -- so that we can issue more queries:
448 [Only (x::Int)] <- query_ conn "SELECT 2 + 2"
299 [Only (x::Int)] <- query_ conn "SELECT 2 + 2"
449 x @?= 4
300 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
301 where
459 copyRows = ["1,foo\n"
302 copyRows = ["1,foo\n"
460 ,"2,bar\n"]
303 ,"2,bar\n"]
@@ -465,70 +308,8 @@ testCopy TestEnv{..} = do
465 CopyOutDone _ -> return rows
308 CopyOutDone _ -> return rows
466 CopyOutRow row -> loop (row:rows)
309 CopyOutRow row -> loop (row:rows)
467
310
468−testCopyFailures :: TestEnv -> TestTree
311+testDouble :: TestEnv -> Test
469−testCopyFailures env = testGroup "Copy failures"
312+testDouble TestEnv{..} = TestCase $ do
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"
313 [Only (x :: Double)] <- query_ conn "SELECT 'NaN'::float8"
533 assertBool "expected NaN" (isNaN x)
314 assertBool "expected NaN" (isNaN x)
534 [Only (x :: Double)] <- query_ conn "SELECT 'Infinity'::float8"
315 [Only (x :: Double)] <- query_ conn "SELECT 'Infinity'::float8"
@@ -537,45 +318,6 @@ testDouble TestEnv{..} = do
537 x @?= (-1 / 0)
318 x @?= (-1 / 0)
538
319
539
320
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−
579data TestException
321data TestException
580 = TestException
322 = TestException
581 deriving (Eq, Show, Typeable)
323 deriving (Eq, Show, Typeable)
@@ -593,56 +335,28 @@ isUniqueViolation SqlError{..} = sqlState == "23505"
593isSyntaxError :: SqlError -> Bool
335isSyntaxError :: SqlError -> Bool
594isSyntaxError SqlError{..} = sqlState == "42601"
336isSyntaxError SqlError{..} = sqlState == "42601"
595
337
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------------------------------------------------------------------------
338------------------------------------------------------------------------
605
339
606-- | Action for connecting to the database that will be used for testing.
340-- | Action for connecting to the database that will be used for testing.
607--
341--
608-- Note that some tests, such as Notify, use multiple connections, and assume
342-- 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.
343-- that 'testConnect' connects to the same database every time it is called.
610−withTestEnv :: ByteString -> (TestEnv -> IO a) -> IO a
344+testConnect :: IO Connection
611−withTestEnv connstr cb =
345+testConnect = connectPostgreSQL ""
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
346
347+withTestEnv :: (TestEnv -> IO a) -> IO a
348+withTestEnv cb =
349+ withConn $ \conn ->
617 cb TestEnv
350 cb TestEnv
618 { conn = conn
351 { conn = conn
619 , withConn = withConn
352 , withConn = withConn
620 }
353 }
621 where
354 where
622− withConn = bracket (connectPostgreSQL connstr) close
355+ withConn = bracket testConnect close
623
356
624main :: IO ()
357main :: IO ()
625−main = withConnstring $ \connstring -> do
358+main = do
626− withTestEnv connstring (defaultMain . tests)
359+ mapM_ (`hSetBuffering` LineBuffering) [stdout, stderr]
627−
360+ Counts{cases, tried, errors, failures} <-
628−withConnstring :: (BS8.ByteString -> IO ()) -> IO ()
361+ withTestEnv $ \env -> runTestTT $ TestList $ map ($ env) tests
629−withConnstring kont = do
362+ when (cases /= tried || errors /= 0 || failures /= 0) $ exitFailure
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.hs+2−1
@@ -14,8 +14,9 @@ import qualified Data.ByteString as B
14-- TODO: Test with payload, but only for PostgreSQL >= 9.0
14-- TODO: Test with payload, but only for PostgreSQL >= 9.0
15-- (when that feature was introduced).
15-- (when that feature was introduced).
16
16
17−testNotify :: TestEnv -> Assertion
17+testNotify :: TestEnv -> Test
18testNotify TestEnv{..} =
18testNotify TestEnv{..} =
19+ TestCase $
19 withConn $ \conn2 -> do
20 withConn $ \conn2 -> do
20 execute_ conn "LISTEN foo"
21 execute_ conn "LISTEN foo"
21 execute_ conn "LISTEN bar"
22 execute_ conn "LISTEN bar"
test/Serializable.hs+2−1
@@ -23,8 +23,9 @@ putCounter conn n = do
23 1 <- execute conn "UPDATE testSerializableCounter SET n=?" (Only n)
23 1 <- execute conn "UPDATE testSerializableCounter SET n=?" (Only n)
24 return ()
24 return ()
25
25
26−testSerializable :: TestEnv -> Assertion
26+testSerializable :: TestEnv -> Test
27testSerializable TestEnv{..} =
27testSerializable TestEnv{..} =
28+ TestCase $
28 withConn $ \conn2 -> do
29 withConn $ \conn2 -> do
29 initCounter conn
30 initCounter conn
30
31
test/Time.hs+10−18
@@ -36,26 +36,26 @@ module Time (testTime) where
36
36
37import Common
37import Common
38import Control.Monad(forM_, replicateM_)
38import Control.Monad(forM_, replicateM_)
39−import Data.Time.Compat
39+import Data.Time
40import Data.ByteString(ByteString)
40import Data.ByteString(ByteString)
41import Database.PostgreSQL.Simple.SqlQQ
41import Database.PostgreSQL.Simple.SqlQQ
42
42
43numTests :: Int
43numTests :: Int
44numTests = 200
44numTests = 200
45
45
46−testTime :: TestEnv -> Assertion
46+testTime :: TestEnv -> Test
47−testTime env@TestEnv{..} = do
47+testTime env@TestEnv{..} = TestCase $ do
48 initializeTable env
48 initializeTable env
49 execute_ conn "SET timezone TO 'UTC'"
49 execute_ conn "SET timezone TO 'UTC'"
50− checkRoundTrips env "1860-01-01 00:00:00+00"
50+ checkRoundTrips env
51 execute_ conn "SET timezone TO 'America/Chicago'" -- -5:00
51 execute_ conn "SET timezone TO 'America/Chicago'" -- -5:00
52− checkRoundTrips env "1883-11-18 12:00:00-06"
52+ checkRoundTrips env
53 execute_ conn "SET timezone TO 'Asia/Tokyo'" -- +9:00
53 execute_ conn "SET timezone TO 'Asia/Tokyo'" -- +9:00
54− checkRoundTrips env "1888-01-01 00:00:00+09"
54+ checkRoundTrips env
55 execute_ conn "SET timezone TO 'Asia/Kathmandu'" -- +5:45
55 execute_ conn "SET timezone TO 'Asia/Kathmandu'" -- +5:45
56− checkRoundTrips env "1919-12-31 23:48:44+05:30"
56+ checkRoundTrips env
57 execute_ conn "SET timezone TO 'America/St_Johns'" -- -3:30
57 execute_ conn "SET timezone TO 'America/St_Johns'" -- -3:30
58− checkRoundTrips env "1935-03-30 00:00:52-03:30"
58+ checkRoundTrips env
59
59
60initializeTable :: TestEnv -> IO ()
60initializeTable :: TestEnv -> IO ()
61initializeTable TestEnv{..} = withTransaction conn $ do
61initializeTable TestEnv{..} = withTransaction conn $ do
@@ -102,18 +102,10 @@ initializeTable TestEnv{..} = withTransaction conn $ do
102 pop "100 milliseconds" 6.3113904e10
102 pop "100 milliseconds" 6.3113904e10
103 pop "1 second" 6.3113904e9
103 pop "1 second" 6.3113904e9
104
104
105−checkRoundTrips :: TestEnv -> ByteString -> IO ()
105+checkRoundTrips :: TestEnv -> IO ()
106−checkRoundTrips TestEnv{..} limit = do
106+checkRoundTrips TestEnv{..} = do
107 yxs :: [(UTCTime, Int)] <- query_ conn [sql| SELECT y, x FROM testtime |]
107 yxs :: [(UTCTime, Int)] <- query_ conn [sql| SELECT y, x FROM testtime |]
108 forM_ yxs $ \yx -> do
108 forM_ yxs $ \yx -> do
109 res <- query conn [sql| SELECT y=? FROM testtime WHERE x=? |] yx
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" $
110 assertBool "UTCTime did not round-trip from SQL to Haskell and back" $
111 res == [Only True]
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/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+183
@@ -0,0 +1,183 @@
1+------------------------------------------------------------------------------
2+-- |
3+-- Module: GenBuiltinTypes
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 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 ByteA
43+char
44+name
45+int8
46+int2
47+int4
48+regproc RegProc
49+text
50+oid
51+tid
52+xid
53+cid
54+xml
55+point
56+lseg LSeg
57+path
58+box
59+polygon
60+line
61+cidr
62+float4
63+float8
64+abstime AbsTime
65+reltime RelTime
66+tinterval TInterval
67+unknown
68+circle
69+money
70+macaddr MacAddr
71+inet
72+bpchar BpChar
73+varchar VarChar
74+date
75+time
76+timestamp
77+timestamptz TimestampTZ
78+interval
79+timetz TimeTZ
80+bit
81+varbit VarBit
82+numeric
83+refcursor RefCursor
84+record
85+void
86+uuid UUID
87+json JSON
88+jsonb JSONB
89+|]
90+
91+instance IsString Blaze.Builder where
92+ fromString = Blaze.fromByteString . fromString
93+
94+main = do
95+ conn <- connectPostgreSQL ""
96+ xs <- query conn "SELECT typname::text, oid::int\
97+ \ FROM pg_type\
98+ \ WHERE typname IN ?"
99+ (Only (In (sort (map fst builtins))))
100+ close conn
101+ let oidmap = Map.fromList xs :: Map
102+ L.writeFile "../src/Database/PostgreSQL/Simple/BuiltinTypes.hs"
103+ (Blaze.toLazyByteString (renderFile oidmap builtins))
104+
105+padCons str = fromString (replicate (len - B.length str) ' ')
106+ where
107+ len = maximum (map (B.length . snd) builtins)
108+
109+renderOid oidmap x
110+ = case Map.lookup x oidmap of
111+ Nothing -> error (B.unpack x)
112+ Just (show -> n) -> fromString (replicate (4 - length n) ' ')
113+ ++ fromString n
114+
115+renderOid' oidmap x
116+ = case Map.lookup x oidmap of
117+ Nothing -> error (B.unpack x)
118+ Just (show -> n) -> fromString n
119+ ++ fromString (replicate (4 - length n) ' ')
120+
121+bs = Blaze.fromByteString
122+
123+renderFile :: Map -> [(B.ByteString,B.ByteString)] -> Blaze.Builder
124+renderFile oidmap builtins = ([longstring|
125+{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}
126+
127+------------------------------------------------------------------------------
128+-- |
129+-- Module: Database.PostgreSQL.Simple.BuiltinTypes
130+-- Copyright: (c) 2011-2012 Leon P Smith
131+-- License: BSD3
132+-- Maintainer: Leon P Smith <leon@melding-monads.com>
133+-- Stability: experimental
134+--
135+------------------------------------------------------------------------------
136+
137+-- Note that this file is generated by tools/GenBuiltinTypes.hs, and should
138+-- not be edited directly
139+
140+module Database.PostgreSQL.Simple.BuiltinTypes
141+ {-# DEPRECATED "Use TypeInfo instead" #-}
142+ ( BuiltinType (..)
143+ , builtin2oid
144+ , oid2builtin
145+ , builtin2typname
146+ , oid2typname
147+ ) where
148+
149+import Data.Typeable
150+import Data.ByteString (ByteString)
151+import qualified Database.PostgreSQL.LibPQ as PQ
152+
153+data BuiltinType
154+ = |] ++ mconcat (intersperse "\n | " (map (Blaze.fromByteString . snd) builtins)) ++ [longstring|
155+
156+ deriving (Eq, Ord, Enum, Bounded, Read, Show, Typeable)
157+
158+builtin2oid :: BuiltinType -> PQ.Oid
159+builtin2oid typ = PQ.Oid $ case typ of
160+|] ++ mconcat [mconcat [ " ", bs y, padCons y, " -> "
161+ , renderOid oidmap x, "\n" ]
162+ | (x,y) <- builtins ] ++ [longstring|
163+
164+oid2builtin :: PQ.Oid -> Maybe BuiltinType
165+oid2builtin (PQ.Oid x) = case x of
166+|] ++ mconcat [mconcat [ " ", renderOid' oidmap x, " -> Just ", bs y, "\n" ]
167+ | (x,y) <- builtins ] ++ [longstring|
168+ _ -> Nothing
169+
170+builtin2typname :: BuiltinType -> ByteString
171+builtin2typname typ = case typ of
172+|] ++ mconcat [mconcat [ " ", bs y, padCons y, " -> ", bs x, "\n"]
173+ | (x,y) <- builtins] ++ [longstring|
174+
175+oid2typname :: PQ.Oid -> Maybe ByteString
176+oid2typname (PQ.Oid x) = case x of
177+|] ++ mconcat [mconcat [ " ", renderOid' oidmap x, " -> Just ", bs x, "\n" ]
178+ | (x,y) <- builtins ]
179+ ++ " _ -> Nothing\n"
180+ ++ mconcat [mconcat [ "\n"
181+ , bs x, " :: ByteString\n"
182+ , bs x, " = \"", bs x, "\"\n"]
183+ | (x,_y) <- builtins ])
tools/GenTypeInfo.hs+39−169
@@ -21,9 +21,6 @@
21-- know about. It then constructs a TypeInfo record and stores it in
21-- know about. It then constructs a TypeInfo record and stores it in
22-- a per-connection cache for later use.
22-- a per-connection cache for later use.
23--
23--
24−-- @
25−-- runghc -itools tools/GenTypeInfo.hs
26−-- @
27------------------------------------------------------------------------------
24------------------------------------------------------------------------------
28
25
29{-# LANGUAGE OverloadedStrings, QuasiQuotes, ViewPatterns, RecordWildCards #-}
26{-# LANGUAGE OverloadedStrings, QuasiQuotes, ViewPatterns, RecordWildCards #-}
@@ -41,10 +38,12 @@ import Database.PostgreSQL.Simple.FromRow
41import Database.PostgreSQL.Simple.Ok
38import Database.PostgreSQL.Simple.Ok
42import Database.PostgreSQL.Simple.Types(Oid(..))
39import Database.PostgreSQL.Simple.Types(Oid(..))
43import Database.PostgreSQL.Simple.SqlQQ
40import Database.PostgreSQL.Simple.SqlQQ
44−import qualified Data.ByteString.Char8 as B8
41+import qualified Data.ByteString.Char8 as B
45import Data.ByteString(ByteString)
42import Data.ByteString(ByteString)
46import qualified Data.ByteString.Lazy as L
43import qualified Data.ByteString.Lazy as L
47−import qualified Data.ByteString.Builder as Blaze
44+import qualified Blaze.ByteString.Builder as Blaze
45+import qualified Blaze.ByteString.Builder.ByteString as Blaze
46+import qualified Blaze.ByteString.Builder.Char8 as Blaze
48import Data.String
47import Data.String
49import Data.List ( sort, intersperse )
48import Data.List ( sort, intersperse )
50import qualified Data.Map as Map
49import qualified Data.Map as Map
@@ -64,17 +63,16 @@ data TypeInfo = TypeInfo
64 , typdelim :: Char
63 , typdelim :: Char
65 , typname :: ByteString
64 , typname :: ByteString
66 , typelem :: Oid
65 , typelem :: Oid
67− , rngsubtype :: Maybe Oid
68 }
66 }
69
67
70−instance FromRow TypeInfo where
68+instance FromRow TypeInfo where
71− fromRow = TypeInfo <$> field <*> field <*> field <*> field <*> field <*> field
69+ fromRow = TypeInfo <$> field <*> field <*> field <*> field <*> field
72
70
73−type NameMap = Map.Map B8.ByteString TypeInfo
71+type NameMap = Map.Map B.ByteString TypeInfo
74
72
75type OidMap = Map.Map Oid TypeInfo
73type OidMap = Map.Map Oid TypeInfo
76
74
77−type TypeName = (B8.ByteString, B8.ByteString)
75+type TypeName = (B.ByteString, B.ByteString)
78
76
79type TypeNames = [TypeName]
77type TypeNames = [TypeName]
80
78
@@ -105,6 +103,9 @@ line
105cidr
103cidr
106float4
104float4
107float8
105float8
106+abstime
107+reltime
108+tinterval
108unknown
109unknown
109circle
110circle
110money
111money
@@ -124,118 +125,49 @@ numeric
124refcursor
125refcursor
125record
126record
126void
127void
127−_record array_record
128−regprocedure
129−regoper
130−regoperator
131−regclass
132−regtype
133uuid
128uuid
134json
129json
135jsonb
130jsonb
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|]
131|]
200
132
133+instance IsString Blaze.Builder where
134+ fromString = Blaze.fromByteString . fromString
135+
201connectionString = "dbname=postgres"
136connectionString = "dbname=postgres"
202
137
203withPostgreSQL = bracket (connectPostgreSQL connectionString) close
138withPostgreSQL = bracket (connectPostgreSQL connectionString) close
204
139
205getTypeInfos :: TypeNames -> IO (OidMap, NameMap)
140getTypeInfos :: TypeNames -> IO (OidMap, NameMap)
206getTypeInfos typnames = withPostgreSQL $ \conn -> do
141getTypeInfos typnames = withPostgreSQL $ \conn -> do
207− infos <- query conn [sql|
142+ infos <- query conn [sql|
208− WITH types AS
209− (SELECT oid, typcategory, typdelim, typname, typelem
143+ SELECT oid, typcategory, typdelim, typname, typelem
144+ FROM pg_type
210− FROM pg_type WHERE typname IN ?)
145+ WHERE typname IN ?
211− SELECT types.*, rngsubtype FROM types LEFT JOIN pg_range ON oid = rngtypid
146+ |]
212− |] (Only (In (sort (map pg typnames))))
147+ (Only (In (sort (map pg typnames))))
213 loop conn (oidMap infos) (nameMap infos) infos
148 loop conn (oidMap infos) (nameMap infos) infos
214 where
149 where
215 oidMap = Map.fromList . map (typoid &&& id)
150 oidMap = Map.fromList . map (typoid &&& id)
216 nameMap = Map.fromList . map (typname &&& id)
151 nameMap = Map.fromList . map (typname &&& id)
217 loop conn oids names infos = do
152 loop conn oids names infos = do
218− let unknowns = [ x | x <- map typelem infos ++
153+ let unknowns = [ x | x <- map typelem infos,
219− [ x | Just x <- map rngsubtype infos ],
220 x /= Oid 0,
154 x /= Oid 0,
221 not (Map.member x oids) ]
155 not (Map.member x oids) ]
222 case unknowns of
156 case unknowns of
223 [] -> return (oids, names)
157 [] -> return (oids, names)
224 (_:_) -> do
158 (_:_) -> do
225 infos' <- query conn [sql|
159 infos' <- query conn [sql|
226− WITH types AS
227− (SELECT oid, typcategory, typdelim, typname, typelem
160+ SELECT oid, typcategory, typdelim, typname, typelem
228− FROM pg_type WHERE oid IN ?)
161+ FROM pg_type
229− SELECT types.*, rngsubtype
162+ WHERE oid IN ?
230− FROM types LEFT JOIN pg_range ON oid = rngtypid
231− |] (Only (In (sort unknowns)))
163+ |] (Only (In (sort unknowns)))
232 let oids' = oids `Map.union` oidMap infos'
164 let oids' = oids `Map.union` oidMap infos'
233 names' = names `Map.union` nameMap infos'
165 names' = names `Map.union` nameMap infos'
234 loop conn oids' names' infos'
166 loop conn oids' names' infos'
235
167
236main = do
168main = do
237 (oidmap, namemap) <- getTypeInfos typeNames
169 (oidmap, namemap) <- getTypeInfos typeNames
238− L.writeFile "src/Database/PostgreSQL/Simple/TypeInfo/Static.hs"
170+ L.writeFile "../src/Database/PostgreSQL/Simple/TypeInfo/Static.hs"
239 (Blaze.toLazyByteString (renderFile oidmap namemap typeNames))
171 (Blaze.toLazyByteString (renderFile oidmap namemap typeNames))
240
172
241
173
@@ -244,7 +176,7 @@ showOid (Oid n) = show n
244renderOid :: NameMap -> TypeName -> Blaze.Builder
176renderOid :: NameMap -> TypeName -> Blaze.Builder
245renderOid byName name
177renderOid byName name
246 = case Map.lookup (pg name) byName of
178 = case Map.lookup (pg name) byName of
247− Nothing -> error (B8.unpack (pg name))
179+ Nothing -> error (B.unpack (pg name))
248 Just (showOid . typoid -> n) -> fromString n
180 Just (showOid . typoid -> n) -> fromString n
249 ++ fromString (replicate (4 - length n) ' ')
181 ++ fromString (replicate (4 - length n) ' ')
250
182
@@ -255,83 +187,13 @@ renderElem byOid elemOid
255 Nothing -> error ("oid not found: " ++ show elemOid)
187 Nothing -> error ("oid not found: " ++ show elemOid)
256 Just x -> "Just " ++ bs (typname x)
188 Just x -> "Just " ++ bs (typname x)
257
189
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.
190-- FIXME: add in any names that we need that we didn't specify, (i.e.
329-- the "unknowns" in getTypeInfos
191-- the "unknowns" in getTypeInfos
330-- and munge them into a valid haskell identifier if needed.
192-- and munge them into a valid haskell identifier if needed.
331getNames :: NameMap -> TypeNames -> TypeNames
193getNames :: NameMap -> TypeNames -> TypeNames
332getNames _ x = x
194getNames _ x = x
333
195
334−bs = Blaze.byteString
196+bs = Blaze.fromByteString
335
197
336pg = fst
198pg = fst
337
199
@@ -360,7 +222,6 @@ module Database.PostgreSQL.Simple.TypeInfo.Static
360 ( TypeInfo(..)
222 ( TypeInfo(..)
361 , staticTypeInfo
223 , staticTypeInfo
362|] ++ concat [ " , " ++ bs (hs name) ++ "\n"
224|] ++ concat [ " , " ++ bs (hs name) ++ "\n"
363− ++ " , " ++ bs (hs name) ++ "Oid\n"
364 | name <- names ] ++ [longstring|
225 | name <- names ] ++ [longstring|
365 ) where
226 ) where
366
227
@@ -376,6 +237,15 @@ staticTypeInfo (Oid x) = case x of
376 ++ [longstring|
237 ++ [longstring|
377 _ -> Nothing
238 _ -> Nothing
378|]
239|]
379− ++ concat [ renderTypeInfo byOid typeInfo name
240+ ++ concat [concat
241+ [ "\n"
242+ , bs (hs name), " :: TypeInfo\n"
243+ , bs (hs name), " = Basic {\n"
244+ , " typoid = ", fromString (show typoid), ",\n"
245+ , " typcategory = '", Blaze.fromChar typcategory, "',\n"
246+ , " typdelim = '", Blaze.fromChar typdelim, "',\n"
247+ , " typname = \"", bs typname, "\"\n"
248+ , " }\n"
249+ ]
380 | name <- getNames byName names
250 | name <- getNames byName names
381− , let (Just typeInfo) = Map.lookup (pg name) byName])
251+ , let (Just (TypeInfo{..})) = Map.lookup (pg name) byName])