git.iko.soy/typeable/postgresql-simple
on master help sign in
swap
3ac2949243 ahead, 0 behind
59 files changed+3865−882
since splitsnapshots
unifiedsplit
.ghci−16 .github/workflows/haskell-ci.yml+256 .github/workflows/simple.yml+58 .gitignore+6 .travis.yml−11 CHANGES.md+314−68 CONTRIBUTING.md+13 CONTRIBUTORS+7 README.md−3 bench/Select.hs+32 cabal.haskell-ci+5 cabal.project+4 cabal.project.local.win+4 postgresql-simple.cabal+153−96 sdist.sh+25 src/Database/PostgreSQL/Simple.hs+38−98 src/Database/PostgreSQL/Simple/Arrays.hs+2−2 src/Database/PostgreSQL/Simple/Compat.hs−44 src/Database/PostgreSQL/Simple/Copy.hs+36−6 src/Database/PostgreSQL/Simple/Cursor.hs+98 src/Database/PostgreSQL/Simple/Errors.hs+12−11 src/Database/PostgreSQL/Simple/FromField.hs+152−77 src/Database/PostgreSQL/Simple/FromRow.hs+239−6 src/Database/PostgreSQL/Simple/HStore.hs+2−2 src/Database/PostgreSQL/Simple/HStore/Implementation.hs+11−11 src/Database/PostgreSQL/Simple/HStore/Internal.hs−2 src/Database/PostgreSQL/Simple/Internal.hs+84−25 src/Database/PostgreSQL/Simple/Internal/PQResultUtils.hs+123 src/Database/PostgreSQL/Simple/LargeObjects.hs+1−1 src/Database/PostgreSQL/Simple/Newtypes.hs+49 src/Database/PostgreSQL/Simple/Notification.hs+62−32 src/Database/PostgreSQL/Simple/Ok.hs+10−4 src/Database/PostgreSQL/Simple/Range.hs+14−10 src/Database/PostgreSQL/Simple/SqlQQ.hs+10−9 src/Database/PostgreSQL/Simple/Time.hs+215−50 src/Database/PostgreSQL/Simple/Time/Implementation.hs+11−1 src/Database/PostgreSQL/Simple/Time/Internal/Parser.hs+18−6 src/Database/PostgreSQL/Simple/Time/Internal/Printer.hs+19−7 src/Database/PostgreSQL/Simple/ToField.hs+42−17 src/Database/PostgreSQL/Simple/ToRow.hs+127 src/Database/PostgreSQL/Simple/ToRow.hs-boot+10−1 src/Database/PostgreSQL/Simple/Transaction.hs+35−17 src/Database/PostgreSQL/Simple/TypeInfo.hs+9−9 src/Database/PostgreSQL/Simple/TypeInfo/Macro.hs+9−3 src/Database/PostgreSQL/Simple/TypeInfo/Static.hs+684−114 src/Database/PostgreSQL/Simple/Types.hs+54−30 src/Database/PostgreSQL/Simple/Vector.hs+45 src/Database/PostgreSQL/Simple/Vector/Unboxed.hs+44 test/Common.hs+2−2 test/Exception.hs+70 test/Inspection.hs+79 test/Interval.hs+176 test/Main.hs+343−59 test/Notify.hs+1−2 test/Serializable.hs+1−2 test/Time.hs+3−3 test/results/malformed-input.expected+4 test/results/unique-constraint-violation.expected+5 tools/GenTypeInfo.hs+39−25
.ghcideleted−16
@@ -1,16 +0,0 @@
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.ymlnew file+256
@@ -0,0 +1,256 @@
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.ymlnew file+58
@@ -0,0 +1,58 @@
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,5 +7,11 @@ dist/
77*.o
88\#*\#
99.#*
10+/CHANGELOG.md
1011.cabal-sandbox/
12+.stack-work/
1113cabal.sandbox.config
14+/dist-newstyle
15+.ghc.environment.*
16+cabal.project.local
17+dump-core
.travis.ymldeleted−11
@@ -1,11 +0,0 @@
1−language: haskell
2−
3−ghc:
4− - 7.6
5− - 7.8
6−
7−addons:
8− postgresql: "9.3"
9−
10−before_install:
11− - createdb `whoami` || true
CHANGES.md+314−68
@@ -1,22 +1,268 @@
1−Version 0.5.0.0 (2015-09-19)
2− * Removed the deprecated BuiltinTypes module.
1+### Version 0.7.0.0 (2023-07-31)
32
4− * Modified the SQL quasiquoter so that it returns a Query, not
5− an overloaded string, and so that the OverloadedStrings language
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
6252 extension is no longer necessary, thanks to Mike Ledger.
7253
8− * Moved away from blaze-builder in favor of bytestring-builder. This
254+ * Moved away from `blaze-builder` in favor of `bytestring-builder`. This
9255 shouldn't affect very many people, but does reduce the transitive
10256 dependencies.
11257
12258 * Rewrote the timestamp printers to use the new `Prim`
13− infrastructure in bytestring-builder. The new printers should
259+ infrastructure in `bytestring-builder`. The new printers should
14260 be a fair bit faster.
15261
16− * Added support for exclusion violations to the ConstraintViolation
262+ * Added support for exclusion violations to the `ConstraintViolation`
17263 type in the Errors module, thanks to João Cristóvão.
18264
19− * Moved away from the uuid package in favor of the uuid-types package,
265+ * Moved away from the `uuid` package in favor of the `uuid-types` package,
20266 thanks to Bardur Arantsson. This shouldn't affect anybody, but does
21267 reduce the transitive dependencies.
22268
@@ -25,17 +271,17 @@ Version 0.5.0.0 (2015-09-19)
25271 support UTF8 except for Mule Internal Code, the Multilingual
26272 Extensions for Emacs. An exception should be raised upon
27273 connecting to a database by the backend if the backend cannot
28− accomodate this requirement.
274+ accommodate this requirement.
29275
30− * Added Eq and Typeable instance for Connection.
276+ * Added `Eq` and `Typeable` instances for `Connection`.
31277
32− * Added the foldWith, forEachWith, and returningWith families of functions
33− courtesy of Travis Staton.
278+ * Added the `foldWith`, `forEachWith`, and `returningWith` families
279+ of functions courtesy of Travis Staton.
34280
35281 * Support for Ranged types, with thanks to Leonid Onokhov for his
36282 contributions.
37283
38− * The FromField instance for JSON now allows for top-level values that
284+ * The `FromField` instance for JSON now allows for top-level values that
39285 are not objects or arrays, thanks to Sam Rijs.
40286
41287 * The timestamp parsers have been replaced with those now in Aeson.
@@ -45,7 +291,7 @@ Version 0.5.0.0 (2015-09-19)
45291 bring the effort full circle, the result has been brought back to
46292 postgresql-simple, with some adaptations.
47293
48− * Fixed a bug in the typeinfo system where postgresql's _record type
294+ * Fixed a bug in the typeinfo system where postgresql's `_record` type
49295 was being reported as a basic type and not an array type. Thanks to
50296 Nickolay Kolev for helping to expose this issue.
51297
@@ -53,13 +299,13 @@ Version 0.5.0.0 (2015-09-19)
53299 case of parsing subfields of arrays and composites, it would fetch the
54300 `TypeInfo` of the array or composite type and not the subtype.
55301
56−Version 0.4.10.0 (2015-02-26)
302+### Version 0.4.10.0 (2015-02-26)
57303 * Added a blurb about SSL/TLS in the documentation for connectPostgreSQL
58304
59305 * Moved some functions into the Internal module, courtesy of Aleksey
60306 Uimanov.
61307
62−Version 0.4.9.0 (2014-12-27)
308+### Version 0.4.9.0 (2014-12-27)
63309 * Made the fromField method for PGArray available as pgArrayFieldParser,
64310 outside of the typeclass courtesy of Tom Ellis.
65311
@@ -67,13 +313,13 @@ Version 0.4.9.0 (2014-12-27)
67313
68314 * Fixed deprecation warnings, courtesy of Simon Hengel.
69315
70−Version 0.4.8.0 (2014-11-24)
316+### Version 0.4.8.0 (2014-11-24)
71317 * Added support for postgresql's citext type extension via the
72318 case-insensitive package.
73319
74320 * Added the function parseHStoreList to the HStore module.
75321
76−Version 0.4.7.0 (2014-10-27)
322+### Version 0.4.7.0 (2014-10-27)
77323 * Added support for very old timestamps to UTCTime. Depending on time
78324 zone, very old timestamps can be returned with a offset from UTC that
79325 contains seconds.
@@ -93,24 +339,24 @@ Version 0.4.7.0 (2014-10-27)
93339
94340 Thanks to Michael Snoyman for his assistance with this issue.
95341
96−Version 0.4.6.0 (2014-10-07)
342+### Version 0.4.6.0 (2014-10-07)
97343 * Added an instance ToField NominalDiffTime.
98344
99−Version 0.4.5.0 (2014-09-26)
345+### Version 0.4.5.0 (2014-09-26)
100346 * Added support for retrieving NaN and ±Infinity floating point values
101347 from postgres to the FromField instances for Float, Double, and Rational.
102348 The instance for Scientific is unchanged due to the fact it has no
103349 way of representing these special values. Thanks goes to Tom Nielsen
104350 for reporting the issue.
105351
106−Version 0.4.4.1 (2014-09-07)
352+### Version 0.4.4.1 (2014-09-07)
107353 * Fixed a rather serious bug that prevented the COPY module from working
108354 at all on unix clients since version 0.4.3.0. Thanks goes to
109355 Dmitry Dzhus for reporting the issue.
110356
111357 * Added a regression test for the COPY module to the test suite.
112358
113−Version 0.4.4.0 (2014-08-26)
359+### Version 0.4.4.0 (2014-08-26)
114360 * Added the jsonb type debuting in PostgreSQL 9.4 to the TypeInfo.Static
115361 and Builtin tables, and extended the out-of-box json instances to
116362 be compatible with the new type. Thanks to Tobias Florek for the
@@ -119,7 +365,7 @@ Version 0.4.4.0 (2014-08-26)
119365 * Ported some expanded documentation from mysql-simple, and fixed
120366 a documentation typo.
121367
122−Version 0.4.3.0 (2014-07-10)
368+### Version 0.4.3.0 (2014-07-10)
123369 * connect and exec now use libpq asynchronously on non-Windows platforms.
124370 This means we are using threadWaitRead and threadWaitWrite to
125371 have GHC's IO manager schedule non-blocking C calls to libpq,
@@ -133,7 +379,7 @@ Version 0.4.3.0 (2014-07-10)
133379 that originate from client-side code. However, this goal
134380 isn't perfectly achieved as of yet.
135381
136−Version 0.4.2.3 (2014-06-04)
382+### Version 0.4.2.3 (2014-06-04)
137383 * This is strictly a documentation release, with no code changes.
138384
139385 * Fixed several documentation typos, thanks to Chris Allen and remdezx.
@@ -144,13 +390,13 @@ Version 0.4.2.3 (2014-06-04)
144390
145391 * De-emphasized connect and ConnectInfo in favor of connectPostgreSQL.
146392
147−Version 0.4.2.2 (2014-05-15)
148− * Fixed compatibility with scientific-0.3.*, thanks to Adam Bergmark
393+### Version 0.4.2.2 (2014-05-15)
394+ * Fixed compatibility with scientific-0.3.\*, thanks to Adam Bergmark
149395
150396 * Improved documentation of the FromField module, as well as the fold,
151397 foldWithOptions, executeMany, and returning operators.
152398
153−Version 0.4.2.1 (2014-03-27)
399+### Version 0.4.2.1 (2014-03-27)
154400 * Fixed bug in Values syntax generation
155401
156402 * Improved documentation, including examples of multi-row update,
@@ -158,17 +404,17 @@ Version 0.4.2.1 (2014-03-27)
158404 floating point numbers from the database, and the IsString instance
159405 for QualifiedIdentifier.
160406
161−Version 0.4.2.0 (2014-03-22)
407+### Version 0.4.2.0 (2014-03-22)
162408 * Added ToField and FromField instances for the scientific package
163409
164410 * Changed the Identifier and QualifiedIdentifier to use Text in
165411 order to avoid encoding errors. Technically this requires a
166− major verson bump, but let's pretend 0.4.1.0 didn't happen.
412+ major version bump, but let's pretend 0.4.1.0 didn't happen.
167413
168414 * Removed non-exhaustive cases in the ToField instance for Values,
169415 and tweaked error messages.
170416
171−Version 0.4.1.0 (2014-03-22)
417+### Version 0.4.1.0 (2014-03-22)
172418 * Fixed the parsing of arrays containing null values, courtesy of
173419 Francesco Mazzoli
174420
@@ -180,17 +426,17 @@ Version 0.4.1.0 (2014-03-22)
180426 more general than executeMany and returning. See the
181427 Database.PostgreSQL.Simple.Types.Values data type.
182428
183−Version 0.4.0.2 (2014-01-12)
429+### Version 0.4.0.2 (2014-01-12)
184430 * Tweaked C preprocessor directive to be more portable
185431
186432 * Tweaked testsuite for compatibility with aeson-0.7
187433
188−Version 0.4.0.1 (2013-12-21)
434+### Version 0.4.0.1 (2013-12-21)
189435 * Relaxed dependency on aeson to >= 0.6
190436
191437 * Update the documentation of `fromField`
192438
193−Version 0.4.0.0 (2013-12-21)
439+### Version 0.4.0.0 (2013-12-21)
194440 * Changed the calling code of `fromField` so that it always sends
195441 a copy of the raw data. This should be a small but significant
196442 performance bump for most people most of the time; however it
@@ -206,15 +452,15 @@ Version 0.4.0.0 (2013-12-21)
206452
207453 * Added FromField instances for IORef, MVar, and IOVector.
208454
209−Version 0.3.10.0 (2013-12-17)
455+### Version 0.3.10.0 (2013-12-17)
210456 * Added the queryWith function, courtesy of Leonid Onokhov
211457
212458 * Added the Default type, for representing postgresql's default values
213459
214−Version 0.3.9.1 (2013-10-28)
460+### Version 0.3.9.1 (2013-10-28)
215461 * Removed dependency on hashable
216462
217−Version 0.3.9.0 (2013-10-27)
463+### Version 0.3.9.0 (2013-10-27)
218464 * Added FromField and ToField instances for the `uuid` package,
219465 courtesy of Bas van Dijk.
220466
@@ -224,16 +470,16 @@ Version 0.3.9.0 (2013-10-27)
224470 * Added the fromBinary, fromHStoreMap, and fromHStoreList newtype
225471 unwrapper functions, courtesy of Bas van Dijk.
226472
227−Version 0.3.8.0 (2013-10-11)
473+### Version 0.3.8.0 (2013-10-11)
228474 * Fixed the example code in `FromField`, thanks to Adam Bergmark.
229475
230476 * Added `Notification.getBackendPID`.
231477
232−Version 0.3.7.1 (2013-09-12)
478+### Version 0.3.7.1 (2013-09-12)
233479 * Relaxed the dependency on bytestring-0.10 back to bytestring-0.9,
234480 courtesy of Michael Snoyman
235481
236−Version 0.3.7.0 (2013-09-11)
482+### Version 0.3.7.0 (2013-09-11)
237483 * Added `aeson` as a dependency.
238484
239485 * Added ToField and FromField instances for aeson's JSON.Value type,
@@ -254,7 +500,7 @@ Version 0.3.7.0 (2013-09-11)
254500
255501 * Various documentation fixes.
256502
257−Version 0.3.6.0 (2013-08-19)
503+### Version 0.3.6.0 (2013-08-19)
258504 * Added the json type to BuiltinTypes and TypeInfo.Static, courtesy of
259505 Manuel Gómez.
260506
@@ -265,14 +511,14 @@ Version 0.3.6.0 (2013-08-19)
265511 months from now. Fixed the example code in FromField to reflect
266512 this change.
267513
268−Version 0.3.5.0 (2013-08-09)
514+### Version 0.3.5.0 (2013-08-09)
269515 * Added an FromRow instance for Vector, semantically identical to the
270516 existing FromRow instance for [], courtesy of Doug Beardsley
271517
272518 * Reworked the documentation for the Copy module, and tweaked the
273519 documentation for the LargeObjects module.
274520
275−Version 0.3.4.0 (2013-07-23)
521+### Version 0.3.4.0 (2013-07-23)
276522 * Added direct support for COPY IN and COPY OUT, without having
277523 to use raw postgresql-libpq calls and postgresql-simple's Internal
278524 module.
@@ -281,49 +527,49 @@ Version 0.3.4.0 (2013-07-23)
281527 exception instead of an ErrorCall exception when it fails to fetch
282528 the connection's file descriptor from libpq.
283529
284−Version 0.3.3.2 (2013-06-18)
530+### Version 0.3.3.2 (2013-06-18)
285531 * Optimized the definition of `mconcat` in the Monoid instance for
286532 the Query type, courtesy of Joey Adams.
287533
288−Version 0.3.3.1 (2013-06-06)
534+### Version 0.3.3.1 (2013-06-06)
289535 * `getNotification` now works on Windows, albeit using a one-second
290536 polling loop, courtesy of Joey Adams.
291537
292−Version 0.3.3.0 (2013-05-29)
538+### Version 0.3.3.0 (2013-05-29)
293539 * Fixed two issues with the fold operator: fold would raise the wrong
294540 exception, and gave the database cursor a static name preventing
295541 folds from being nested. Thanks to Joey Adams for his
296542 work on these issues.
297543
298−Version 0.3.2.0 (2013-05-20)
544+### Version 0.3.2.0 (2013-05-20)
299545 * Added a savepoint abstraction to the Transaction module, courtesy
300546 of Joey Adams
301547
302−Version 0.3.1.2 (2013-04-29)
548+### Version 0.3.1.2 (2013-04-29)
303549 * Fixed hstore parser to not unnecessarily reverse the key-value pairs
304550
305−Version 0.3.1.1 (2013-04-29)
551+### Version 0.3.1.1 (2013-04-29)
306552 * Fixed hstore parser to recognize empty hstores, courtesy of Simon
307553 Meier
308554
309−Version 0.3.1.0 (2013-04-26)
555+### Version 0.3.1.0 (2013-04-26)
310556 * Added support for Range and Composite types to the TypeInfo system.
311557
312558 * Added support for hstore types in the Simple.HStore module.
313559
314560 * Improved documentation of the FromField module.
315561
316−Version 0.3.0.1 (2013-03-26)
562+### Version 0.3.0.1 (2013-03-26)
317563 * A large chunk of the documentation inside the FromField module had
318564 silently failed to render in Haddock.
319565
320−Version 0.3.0.0 (2013-03-25)
566+### Version 0.3.0.0 (2013-03-25)
321567 * Added support for PostgreSQL's Array Types. Thanks to Jason Dusek
322568 for his work on this feature.
323569
324570 * Added a brand new TypeInfo system that gives FromField instances
325571 convenient and efficient access to the pg_type metatable. This
326− replaced the older typename cache, and was neccesary to properly
572+ replaced the older typename cache, and was necessary to properly
327573 support postgres array types. Thanks to Bas van Dijk for his
328574 work on this feature.
329575
@@ -359,33 +605,33 @@ Version 0.3.0.0 (2013-03-25)
359605 now stripped out.
360606
361607
362−Version 0.2.4.1 (2012-08-29)
608+### Version 0.2.4.1 (2012-08-29)
363609 * Fixed the documentation of `In`. Thanks to rekado and dstcruz for
364610 pointing this out.
365611
366−Version 0.2.4.0 (2012-08-23)
612+### Version 0.2.4.0 (2012-08-23)
367613 * Added the `withTransactionSerializable` and `withTransactionModeRetry`
368614 operators, thanks to Joey Adams.
369615
370−Version 0.2.3.0 (2012-08-09)
616+### Version 0.2.3.0 (2012-08-09)
371617 * Added the `returning` operator, thanks to Jason Dusek
372618
373−Version 0.2.2.0 (2012-07-26)
619+### Version 0.2.2.0 (2012-07-26)
374620 * Added a ToRow instance for the (:.) type, courtesy of Leonid Onokhov
375621
376622 * Added the type oid for PostgreSQL's `uuid` type to BuiltinTypes
377623
378−Version 0.2.1.0 (2012-07-23)
624+### Version 0.2.1.0 (2012-07-23)
379625 * Added the FromRow.fieldWith operator, thanks to Leonid Onokhov
380626
381627 * Added a type synonym for FieldParser
382628
383−Version 0.2.0.1 (2012-06-21)
629+### Version 0.2.0.1 (2012-06-21)
384630 * Fixed a compatibility problem with PostgreSQL 8.1, which does not allow
385631 clients to set their own value for `standard_conforming_strings`. This
386632 connection variable is still set to `on` for PostgreSQL 8.2 and later.
387633
388−Version 0.2: (2012-06-19)
634+### Version 0.2: (2012-06-19)
389635 * Removed the conversion from `timestamp` to `UTCTime`. Some code will be
390636 broken even though it will still compile.
391637
@@ -394,16 +640,16 @@ Version 0.2: (2012-06-19)
394640 * Exported ToRow/FromRow from Database.PostgreSQL.Simple
395641
396642
397−Version 0.1.4.3: (2012-06-10)
643+### Version 0.1.4.3: (2012-06-10)
398644 * Fix language extensions for compatibility with GHC 7.0
399645
400−Version 0.1.4.2: (2012-06-10)
646+### Version 0.1.4.2: (2012-06-10)
401647 * Fix a wayward dependency on Text.
402648
403−Version 0.1.4.1: (2012-06-10)
649+### Version 0.1.4.1: (2012-06-10)
404650 * Added support for timezones with minutes in their UTC offset.
405651
406−Version 0.1.4: (2012-06-10)
652+### Version 0.1.4: (2012-06-10)
407653 * Removed pcre-light dependency, courtesy of Joey Adams.
408654
409655 * Reworked support for the Time types.
@@ -415,7 +661,7 @@ Version 0.1.4: (2012-06-10)
415661 now the preferred way of dealing with `timestamp` (without time zone).
416662
417663 * `Database.PostgreSQL.Simple.Time` is a new module that offers types
418− that accomodate PostgreSQL's infinities.
664+ that accommodate PostgreSQL's infinities.
419665
420666 * All time-related `FromField`/`ToField` instances are now based on new,
421667 higher-speed parsers and printers instead of those provided by the
@@ -428,13 +674,13 @@ Version 0.1.4: (2012-06-10)
428674 * Renaming some of the type names in `BuiltinTypes`.
429675
430676
431−Version 0.1.3: (2012-05-30)
677+### Version 0.1.3: (2012-05-30)
432678 * Made ZonedTime an instance of FromField and ToField
433679
434680 * Added getNotificationNonBlocking
435681
436682
437−Version 0.1.2: (2012-05-09)
683+### Version 0.1.2: (2012-05-09)
438684 * Switched to libpq-based escaping for bytea types; Binary now works with
439685 PostgreSQL 8 courtesy of Joey Adams.
440686
@@ -447,7 +693,7 @@ Version 0.1.2: (2012-05-09)
447693 * Exported (:.) from Database.PostgreSQL.Simple
448694
449695
450−Version 0.1.1: (2012-05-06)
696+### Version 0.1.1: (2012-05-06)
451697 * Added some preliminary documentation for the Ok, Notification, and
452698 LargeObjects modules
453699
@@ -456,7 +702,7 @@ Version 0.1.1: (2012-05-06)
456702 * Fixed a bug relating to handling the transaction level
457703
458704
459−Version 0.1: (2012-05-04)
705+### Version 0.1: (2012-05-04)
460706 * Renamed several modules, typeclasses, and functions:
461707
462708 QueryParams (renderParams) -> ToRow (toRow)
CONTRIBUTING.mdnew file+13
@@ -0,0 +1,13 @@
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+7
@@ -27,3 +27,10 @@ Travis Staton <hello@travisstaton.com>
2727Sam Rijs <srijs@airpost.net>
2828Janne Hellsten <jjhellst@gmail.com>
2929Timmy 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.md−3
@@ -1,7 +1,4 @@
1−[![Continuous Integration status][status-png]][status]
21[![Hackage page (downloads and API reference)][hackage-png]][hackage]
32
4− [status-png]: https://api.travis-ci.org/lpsmith/postgresql-simple.svg
5− [status]: http://travis-ci.org/lpsmith/postgresql-simple?branch=master
63 [hackage-png]: http://img.shields.io/hackage/v/postgresql-simple.svg
74 [hackage]: http://hackage.haskell.org/package/postgresql-simple
bench/Select.hsnew file+32
@@ -0,0 +1,32 @@
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-cinew file+5
@@ -0,0 +1,5 @@
1+branches: master
2+postgresql: True
3+
4+-- services aren't supported on Travis on macOS
5+-- osx: 8.4.4
cabal.projectnew file+4
@@ -0,0 +1,4 @@
1+packages: .
2+tests: true
3+
4+allow-newer: cryptohash-md5-0.11.100.1:base
cabal.project.local.winnew file+4
@@ -0,0 +1,4 @@
1+constraints: these -assoc
2+
3+package postgresql-libpq
4+ flags: -use-pkg-config
postgresql-simple.cabal+153−96
@@ -1,118 +1,175 @@
1−Name: postgresql-simple
2−Version: 0.5.0.0
3−Synopsis: Mid-Level PostgreSQL client library
4−Description:
5− Mid-Level PostgreSQL client library, forked from mysql-simple.
6−License: BSD3
7−License-file: LICENSE
8−Author: Bryan O'Sullivan, Leon P Smith
9−Maintainer: Leon P Smith <leon@melding-monads.com>
10−Copyright: (c) 2011 MailRank, Inc.
11− (c) 2011-2013 Leon P Smith
12−Category: Database
13−Build-type: Simple
1+cabal-version: 1.12
2+name: postgresql-simple
3+version: 0.7.0.0
4+x-revision: 1
5+synopsis: Mid-Level PostgreSQL client library
6+description:
7+ Mid-Level PostgreSQL client library, forked from mysql-simple.
148
15−Cabal-version: >= 1.9.2
9+license: BSD3
10+license-file: LICENSE
11+author: Bryan O'Sullivan, Leon P Smith
12+maintainer: Oleg Grenrus <oleg.grenrus@iki.fi>
13+copyright:
14+ (c) 2011 MailRank, Inc.
15+ (c) 2011-2018 Leon P Smith
16+ (c) 2018-2020 Oleg Grenrus
1617
18+category: Database
19+build-type: Simple
1720extra-source-files:
18− CONTRIBUTORS
21+ CHANGES.md
22+ CONTRIBUTORS
23+ test/results/malformed-input.expected
24+ test/results/unique-constraint-violation.expected
1925
20−Library
21− hs-source-dirs: src
22− Exposed-modules:
23− Database.PostgreSQL.Simple
24− Database.PostgreSQL.Simple.Arrays
25− Database.PostgreSQL.Simple.Copy
26− Database.PostgreSQL.Simple.FromField
27− Database.PostgreSQL.Simple.FromRow
28− Database.PostgreSQL.Simple.LargeObjects
29− Database.PostgreSQL.Simple.HStore
30− Database.PostgreSQL.Simple.HStore.Internal
31− Database.PostgreSQL.Simple.Notification
32− Database.PostgreSQL.Simple.Ok
33− Database.PostgreSQL.Simple.Range
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
26+tested-with:
27+ GHC ==8.6.5
28+ || ==8.8.4
29+ || ==8.10.7
30+ || ==9.0.2
31+ || ==9.2.8
32+ || ==9.4.8
33+ || ==9.6.3
34+ || ==9.8.1
4735
48− Other-modules:
49− Database.PostgreSQL.Simple.Compat
50− Database.PostgreSQL.Simple.HStore.Implementation
51− Database.PostgreSQL.Simple.Time.Implementation
52− Database.PostgreSQL.Simple.Time.Internal.Parser
53− Database.PostgreSQL.Simple.Time.Internal.Printer
54− Database.PostgreSQL.Simple.TypeInfo.Types
36+library
37+ default-language: Haskell2010
38+ hs-source-dirs: src
39+ exposed-modules:
40+ Database.PostgreSQL.Simple
41+ Database.PostgreSQL.Simple.Arrays
42+ Database.PostgreSQL.Simple.Copy
43+ Database.PostgreSQL.Simple.Cursor
44+ Database.PostgreSQL.Simple.Errors
45+ Database.PostgreSQL.Simple.FromField
46+ Database.PostgreSQL.Simple.FromRow
47+ Database.PostgreSQL.Simple.HStore
48+ Database.PostgreSQL.Simple.HStore.Internal
49+ Database.PostgreSQL.Simple.Internal
50+ Database.PostgreSQL.Simple.LargeObjects
51+ Database.PostgreSQL.Simple.Newtypes
52+ Database.PostgreSQL.Simple.Notification
53+ Database.PostgreSQL.Simple.Ok
54+ Database.PostgreSQL.Simple.Range
55+ Database.PostgreSQL.Simple.SqlQQ
56+ Database.PostgreSQL.Simple.Time
57+ Database.PostgreSQL.Simple.Time.Internal
58+ Database.PostgreSQL.Simple.ToField
59+ Database.PostgreSQL.Simple.ToRow
60+ Database.PostgreSQL.Simple.Transaction
61+ Database.PostgreSQL.Simple.TypeInfo
62+ Database.PostgreSQL.Simple.TypeInfo.Macro
63+ Database.PostgreSQL.Simple.TypeInfo.Static
64+ Database.PostgreSQL.Simple.Types
65+ Database.PostgreSQL.Simple.Vector
66+ Database.PostgreSQL.Simple.Vector.Unboxed
5567
56− Build-depends:
57− aeson >= 0.6,
58− attoparsec >= 0.10.3,
59− base < 5,
60− bytestring >= 0.9,
61− bytestring-builder,
62− case-insensitive,
63− containers,
64− hashable,
65− postgresql-libpq >= 0.9 && < 0.10,
66− template-haskell,
67− text >= 0.11.1,
68− time,
69− transformers,
70− uuid-types >= 1.0.0,
71− scientific,
72− vector
68+ -- Other-modules:
69+ other-modules:
70+ Database.PostgreSQL.Simple.Compat
71+ Database.PostgreSQL.Simple.HStore.Implementation
72+ Database.PostgreSQL.Simple.Internal.PQResultUtils
73+ Database.PostgreSQL.Simple.Time.Implementation
74+ Database.PostgreSQL.Simple.Time.Internal.Parser
75+ Database.PostgreSQL.Simple.Time.Internal.Printer
76+ Database.PostgreSQL.Simple.TypeInfo.Types
77+
78+ -- GHC bundled libs
79+ build-depends:
80+ base >=4.12.0.0 && <4.20
81+ , bytestring >=0.10.8.2 && <0.13
82+ , containers >=0.6.0.1 && <0.7
83+ , template-haskell >=2.14.0.0 && <2.22
84+ , text >=1.2.3.0 && <1.3 || >=2.0 && <2.2
85+ , time-compat >=1.9.5 && <1.12
86+ , transformers >=0.5.6.2 && <0.7
87+
88+ -- Other dependencies
89+ build-depends:
90+ aeson >=2.1.2.1 && <2.3
91+ , attoparsec >=0.14.4 && <0.15
92+ , case-insensitive >=1.2.1.0 && <1.3
93+ , hashable >=1.4.3.0 && <1.5
94+ , Only >=0.1 && <0.1.1
95+ , postgresql-libpq >=0.10.0.0 && <0.11
96+ , scientific >=0.3.7.0 && <0.4
97+ , uuid-types >=1.0.5 && <1.1
98+ , vector >=0.13.0.0 && <0.14
7399
74− extensions: DoAndIfThenElse, OverloadedStrings, BangPatterns, ViewPatterns
75− TypeOperators
100+ default-extensions:
101+ BangPatterns
102+ DoAndIfThenElse
103+ OverloadedStrings
104+ TypeOperators
105+ ViewPatterns
76106
77− ghc-options: -Wall -fno-warn-name-shadowing
107+ ghc-options: -Wall -fno-warn-name-shadowing
78108
79109source-repository head
80110 type: git
81− location: http://github.com/lpsmith/postgresql-simple
111+ location: http://github.com/haskellari/postgresql-simple
82112
83−source-repository this
84− type: git
85− location: http://github.com/lpsmith/postgresql-simple
86− tag: v0.5.0.0
113+test-suite inspection
114+ default-language: Haskell2010
115+ type: exitcode-stdio-1.0
116+ hs-source-dirs: test
117+ main-is: Inspection.hs
118+ build-depends:
119+ base
120+ , inspection-testing >=0.4.1.1 && <0.6
121+ , postgresql-libpq
122+ , postgresql-simple
123+ , tasty
124+ , tasty-hunit
87125
88126test-suite test
89− type: exitcode-stdio-1.0
90−
91− hs-source-dirs: test
92− main-is: Main.hs
127+ default-language: Haskell2010
128+ type: exitcode-stdio-1.0
129+ hs-source-dirs: test
130+ main-is: Main.hs
93131 other-modules:
94132 Common
133+ Exception
134+ Interval
95135 Notify
96136 Serializable
97137 Time
98138
99− ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind
139+ ghc-options: -threaded
140+ ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind
141+ default-extensions:
142+ NamedFieldPuns
143+ OverloadedStrings
144+ PatternGuards
145+ Rank2Types
146+ RecordWildCards
147+ ScopedTypeVariables
100148
101− extensions: NamedFieldPuns
102− , OverloadedStrings
103− , Rank2Types
104− , RecordWildCards
105− , PatternGuards
106− , ScopedTypeVariables
149+ build-depends:
150+ aeson
151+ , base
152+ , base16-bytestring
153+ , bytestring
154+ , case-insensitive
155+ , containers
156+ , cryptohash-md5 >=0.11.100.1 && <0.12
157+ , filepath
158+ , HUnit
159+ , postgresql-simple
160+ , tasty
161+ , tasty-golden
162+ , tasty-hunit
163+ , text
164+ , time-compat
165+ , vector
107166
108− build-depends: base
109− , aeson
110− , base16-bytestring
111− , bytestring
112− , containers
113− , cryptohash
114− , HUnit
115− , postgresql-simple
116− , text
117− , time
118− , vector
167+benchmark select
168+ default-language: Haskell2010
169+ type: exitcode-stdio-1.0
170+ hs-source-dirs: bench
171+ main-is: Select.hs
172+ build-depends:
173+ base
174+ , postgresql-simple
175+ , vector
sdist.shnew file+25
@@ -0,0 +1,25 @@
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+38−98
@@ -64,6 +64,7 @@ module Database.PostgreSQL.Simple
6464 , Only(..)
6565 , (:.)(..)
6666 -- ** Exceptions
67+ , SomePostgreSqlException(..)
6768 , SqlError(..)
6869 , PQ.ExecStatus(..)
6970 , FormatError(..)
@@ -73,6 +74,7 @@ module Database.PostgreSQL.Simple
7374 , Base.connectPostgreSQL
7475 , Base.close
7576 , Base.connect
77+ , Base.withConnect
7678 , Base.ConnectInfo(..)
7779 , Base.defaultConnectInfo
7880 , Base.postgreSQLConnectionString
@@ -118,30 +120,26 @@ module Database.PostgreSQL.Simple
118120 , formatQuery
119121 ) where
120122
121−import Data.ByteString.Builder
122− ( Builder, byteString, char8, intDec )
123+import Data.ByteString.Builder (Builder, byteString, char8)
123124import Control.Applicative ((<$>))
124125import Control.Exception as E
125−import Control.Monad (foldM)
126126import Data.ByteString (ByteString)
127127import Data.Int (Int64)
128128import Data.List (intersperse)
129129import Data.Monoid (mconcat)
130−import Database.PostgreSQL.Simple.Compat ( (<>), toByteString )
130+import Database.PostgreSQL.Simple.Compat ((<>), toByteString)
131+import Database.PostgreSQL.Simple.Cursor
131132import Database.PostgreSQL.Simple.FromField (ResultError(..))
132133import Database.PostgreSQL.Simple.FromRow (FromRow(..))
133−import Database.PostgreSQL.Simple.Ok
134134import Database.PostgreSQL.Simple.ToField (Action(..))
135135import Database.PostgreSQL.Simple.ToRow (ToRow(..))
136136import Database.PostgreSQL.Simple.Types
137137 ( Binary(..), In(..), Only(..), Query(..), (:.)(..) )
138138import Database.PostgreSQL.Simple.Internal as Base
139+import Database.PostgreSQL.Simple.Internal.PQResultUtils
139140import Database.PostgreSQL.Simple.Transaction
140−import Database.PostgreSQL.Simple.TypeInfo
141141import qualified Database.PostgreSQL.LibPQ as PQ
142142import qualified Data.ByteString.Char8 as B
143−import Control.Monad.Trans.Reader
144−import Control.Monad.Trans.State.Strict
145143
146144
147145-- | Format a query string.
@@ -280,21 +278,31 @@ parseTemplate template =
280278 skipSpace = B.dropWhile isSpace_ascii
281279
282280
283−
284281buildQuery :: Connection -> Query -> ByteString -> [Action] -> IO Builder
285282buildQuery conn q template xs =
286283 zipParams (split template) <$> mapM (buildAction conn q xs) xs
287284 where split s =
288− let (h,t) = B.break (=='?') s
285+ -- This part escapes double '??'s to make literal '?'s possible
286+ -- in PostgreSQL queries using the JSON operators: @?@, @?|@ and @?&@
287+ let (h,t) = breakOnSingleQuestionMark s
289288 in byteString h
290289 : if B.null t
291290 then []
292291 else split (B.tail t)
293292 zipParams (t:ts) (p:ps) = t <> p <> zipParams ts ps
294293 zipParams [t] [] = t
295− zipParams _ _ = fmtError (show (B.count '?' template) ++
296− " '?' characters, but " ++
294+ zipParams _ _ = fmtError (show countSingleQs ++
295+ " single '?' characters, but " ++
297296 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
298306
299307-- | Execute an @INSERT@, @UPDATE@, or other SQL query that is not
300308-- expected to return results.
@@ -332,10 +340,10 @@ execute conn template qs = do
332340-- @
333341-- executeMany c [sql|
334342-- UPDATE sometable
335−-- SET sometable.y = upd.y
343+-- SET y = upd.y
336344-- FROM (VALUES (?,?)) as upd(x,y)
337345-- WHERE sometable.x = upd.x
338−-- |] [(1, \"hello\"),(2, \"world\")
346+-- |] [(1, \"hello\"),(2, \"world\")]
339347-- @
340348
341349executeMany :: (ToRow q) => Connection -> Query -> [q] -> IO Int64
@@ -359,6 +367,7 @@ executeMany conn q qs = do
359367returning :: (ToRow q, FromRow r) => Connection -> Query -> [q] -> IO [r]
360368returning = returningWith fromRow
361369
370+-- | A version of 'returning' taking parser as argument
362371returningWith :: (ToRow q) => RowParser r -> Connection -> Query -> [q] -> IO [r]
363372returningWith _ _ _ [] = return []
364373returningWith parser conn q qs = do
@@ -508,7 +517,7 @@ fold_ :: (FromRow r) =>
508517 -> IO a
509518fold_ = foldWithOptions_ defaultFoldOptions
510519
511−-- | A version of 'foldWith' taking a parser as an argument
520+-- | A version of 'fold_' taking a parser as an argument
512521foldWith_ :: RowParser r
513522 -> Connection
514523 -> Query
@@ -524,7 +533,7 @@ foldWithOptions_ :: (FromRow r) =>
524533 -> a -- ^ Initial state for result consumer.
525534 -> (a -> r -> IO a) -- ^ Result consumer.
526535 -> IO a
527−foldWithOptions_ opts conn query a f = doFold opts fromRow conn query query a f
536+foldWithOptions_ opts conn query' a f = doFold opts fromRow conn query' query' a f
528537
529538-- | A version of 'foldWithOptions_' taking a parser as an argument
530539foldWithOptionsAndParser_ :: FoldOptions
@@ -534,7 +543,7 @@ foldWithOptionsAndParser_ :: FoldOptions
534543 -> a -- ^ Initial state for result consumer.
535544 -> (a -> r -> IO a) -- ^ Result consumer.
536545 -> IO a
537−foldWithOptionsAndParser_ opts parser conn query a f = doFold opts parser conn query query a f
546+foldWithOptionsAndParser_ opts parser conn query' a f = doFold opts parser conn query' query' a f
538547
539548doFold :: FoldOptions
540549 -> RowParser row
@@ -562,28 +571,17 @@ doFold FoldOptions{..} parser conn _template q a0 f = do
562571 PQ.TransUnknown -> fail "foldWithOpts FIXME: PQ.TransUnknown"
563572 -- Not sure what this means.
564573 where
565− declare = do
566− name <- newTempName conn
567− _ <- execute_ conn $ mconcat
568− [ "DECLARE ", name, " NO SCROLL CURSOR FOR ", q ]
569− return name
570− fetch (Query name) = queryWith_ parser conn $
571− Query (toByteString (byteString "FETCH FORWARD "
572− <> intDec chunkSize
573− <> byteString " FROM "
574− <> byteString name
575− ))
576− close name =
577− (execute_ conn ("CLOSE " <> name) >> return ()) `E.catch` \ex ->
578− -- Don't throw exception if CLOSE failed because the transaction is
579− -- aborted. Otherwise, it will throw away the original error.
580− if isFailedTransactionError ex then return () else throwIO ex
581−
582− go = bracket declare close $ \name ->
583− let loop a = do
584− rs <- fetch name
585− if null rs then return a else foldM f a rs >>= loop
586− in loop a0
574+ declare =
575+ declareCursor conn q
576+ fetch cursor a =
577+ foldForwardWithParser cursor parser chunkSize f a
578+
579+ go = bracket declare closeCursor $ \cursor ->
580+ let loop a = fetch cursor a >>=
581+ \r -> case r of
582+ Left x -> return x
583+ Right x -> loop x
584+ in loop a0
587585
588586-- FIXME: choose the Automatic chunkSize more intelligently
589587-- One possibility is to use the type of the results, although this
@@ -633,64 +631,6 @@ forEachWith_ :: RowParser r
633631forEachWith_ parser conn template = foldWith_ parser conn template () . const
634632{-# INLINE forEachWith_ #-}
635633
636−forM' :: (Ord n, Num n) => n -> n -> (n -> IO a) -> IO [a]
637−forM' lo hi m = loop hi []
638− where
639− loop !n !as
640− | n < lo = return as
641− | otherwise = do
642− a <- m n
643− loop (n-1) (a:as)
644−
645−finishQuery :: FromRow r => Connection -> Query -> PQ.Result -> IO [r]
646−finishQuery = finishQueryWith fromRow
647−
648−finishQueryWith :: RowParser r -> Connection -> Query -> PQ.Result -> IO [r]
649−finishQueryWith parser conn q result = do
650− status <- PQ.resultStatus result
651− case status of
652− PQ.EmptyQuery ->
653− throwIO $ QueryError "query: Empty query" q
654− PQ.CommandOk -> do
655− throwIO $ QueryError "query resulted in a command response" q
656− PQ.TuplesOk -> do
657− let unCol (PQ.Col x) = fromIntegral x :: Int
658− nrows <- PQ.ntuples result
659− ncols <- PQ.nfields result
660− forM' 0 (nrows-1) $ \row -> do
661− let rw = Row row result
662− okvc <- runConversion (runStateT (runReaderT (unRP parser) rw) 0) conn
663− case okvc of
664− Ok (val,col) | col == ncols -> return val
665− | otherwise -> do
666− vals <- forM' 0 (ncols-1) $ \c -> do
667− tinfo <- getTypeInfo conn =<< PQ.ftype result c
668− v <- PQ.getvalue result row c
669− return ( tinfo
670− , fmap ellipsis v )
671− throw (ConversionFailed
672− (show (unCol ncols) ++ " values: " ++ show vals)
673− Nothing
674− ""
675− (show (unCol col) ++ " slots in target type")
676− "mismatch between number of columns to \
677− \convert and number in target type")
678− Errors [] -> throwIO $ ConversionFailed "" Nothing "" "" "unknown error"
679− Errors [x] -> throwIO x
680− Errors xs -> throwIO $ ManyErrors xs
681− PQ.CopyOut ->
682− throwIO $ QueryError "query: COPY TO is not supported" q
683− PQ.CopyIn ->
684− throwIO $ QueryError "query: COPY FROM is not supported" q
685− PQ.BadResponse -> throwResultError "query" result status
686− PQ.NonfatalError -> throwResultError "query" result status
687− PQ.FatalError -> throwResultError "query" result status
688−
689−ellipsis :: ByteString -> ByteString
690−ellipsis bs
691− | B.length bs > 15 = B.take 10 bs `B.append` "[...]"
692− | otherwise = bs
693−
694634
695635-- $use
696636--
@@ -962,7 +902,7 @@ ellipsis bs
962902-- all values of the given PostgreSQL type is considered \"compatible\".
963903-- For instance, you can always extract a PostgreSQL 16-bit @SMALLINT@
964904-- column to a Haskell 'Int'. The Haskell 'Float' type can accurately
965−-- represent a @SMALLINT@, so it is considered compatble with those types.
905+-- represent a @SMALLINT@, so it is considered compatible with those types.
966906--
967907-- * A numeric compatibility check is based only on the type of a
968908-- 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 '}'
4242quoted :: Parser ByteString
4343quoted = char '"' *> option "" contents <* char '"'
4444 where
45− esc = char '\\' *> (char '\\' <|> char '"')
45+ esc' = char '\\' *> (char '\\' <|> char '"')
4646 unQ = takeWhile1 (notInClass "\"\\")
47− contents = mconcat <$> many (unQ <|> B.singleton <$> esc)
47+ contents = mconcat <$> many (unQ <|> B.singleton <$> esc')
4848
4949-- | Recognizes a plain string literal, not containing quotes or brackets and
5050-- not containing the delimiter character.
src/Database/PostgreSQL/Simple/Compat.hs−44
@@ -12,31 +12,13 @@ module Database.PostgreSQL.Simple.Compat
1212 ) where
1313
1414import qualified Control.Exception as E
15−import Data.Monoid
1615import Data.ByteString (ByteString)
1716import Data.ByteString.Lazy (toStrict)
1817import Data.ByteString.Builder (Builder, toLazyByteString)
19−
20−#if MIN_VERSION_scientific(0,3,0)
2118import Data.Text.Lazy.Builder.Scientific (scientificBuilder)
22−#else
23−import Data.Scientific (scientificBuilder)
24−#endif
25−
26−#if __GLASGOW_HASKELL__ >= 702
2719import System.IO.Unsafe (unsafeDupablePerformIO)
28−#elif __GLASGOW_HASKELL__ >= 611
29−import GHC.IO (unsafeDupablePerformIO)
30−#else
31−import GHC.IOBase (unsafeDupablePerformIO)
32−#endif
33−
3420import Data.Fixed (Pico)
35−#if MIN_VERSION_base(4,7,0)
3621import Data.Fixed (Fixed(MkFixed))
37−#else
38−import Unsafe.Coerce (unsafeCoerce)
39−#endif
4022
4123-- | Like 'E.mask', but backported to base before version 4.3.0.
4224--
@@ -46,40 +28,14 @@ import Unsafe.Coerce (unsafeCoerce)
4628-- 'withTransactionMode' function calls the restore callback only once, so we
4729-- don't need that polymorphism.
4830mask :: ((IO a -> IO a) -> IO b) -> IO b
49−#if MIN_VERSION_base(4,3,0)
5031mask io = E.mask $ \restore -> io restore
51−#else
52−mask io = do
53− b <- E.blocked
54− E.block $ io $ \m -> if b then m else E.unblock m
55−#endif
5632{-# INLINE mask #-}
5733
58−#if !MIN_VERSION_base(4,5,0)
59−infixr 6 <>
60−
61−(<>) :: Monoid m => m -> m -> m
62−(<>) = mappend
63−{-# INLINE (<>) #-}
64−#endif
65−
6634toByteString :: Builder -> ByteString
6735toByteString x = toStrict (toLazyByteString x)
6836
69−#if MIN_VERSION_base(4,7,0)
70−
7137toPico :: Integer -> Pico
7238toPico = MkFixed
7339
7440fromPico :: Pico -> Integer
7541fromPico (MkFixed i) = i
76−
77−#else
78−
79−toPico :: Integer -> Pico
80−toPico = unsafeCoerce
81−
82−fromPico :: Pico -> Integer
83−fromPico = unsafeCoerce
84−
85−#endif
src/Database/PostgreSQL/Simple/Copy.hs+36−6
@@ -9,7 +9,7 @@
99-- Stability: experimental
1010--
1111-- mid-level support for COPY IN and COPY OUT. See
12−-- <http://www.postgresql.org/docs/9.2/static/sql-copy.html> for
12+-- <https://www.postgresql.org/docs/9.5/static/sql-copy.html> for
1313-- more information.
1414--
1515-- To use this binding, first call 'copy' with an appropriate
@@ -32,6 +32,7 @@ module Database.PostgreSQL.Simple.Copy
3232 ( copy
3333 , copy_
3434 , CopyOutResult(..)
35+ , foldCopyData
3536 , getCopyData
3637 , putCopyData
3738 , putCopyEnd
@@ -48,13 +49,13 @@ import qualified Data.ByteString.Char8 as B
4849import qualified Database.PostgreSQL.LibPQ as PQ
4950import Database.PostgreSQL.Simple
5051import Database.PostgreSQL.Simple.Types
51−import Database.PostgreSQL.Simple.Internal
52+import Database.PostgreSQL.Simple.Internal hiding (result, row)
5253
5354
5455-- | Issue a @COPY FROM STDIN@ or @COPY TO STDOUT@ query. In the former
5556-- case, the connection's state will change to @CopyIn@; in the latter,
5657-- @CopyOut@. The connection must be in the ready state in order
57−-- to call this function. Performs parameter subsitution.
58+-- to call this function. Performs parameter substitution.
5859
5960copy :: ( ToRow params ) => Connection -> Query -> params -> IO ()
6061copy conn template qs = do
@@ -75,15 +76,18 @@ doCopy :: B.ByteString -> Connection -> Query -> B.ByteString -> IO ()
7576doCopy funcName conn template q = do
7677 result <- exec conn q
7778 status <- PQ.resultStatus result
78− let err = throwIO $ QueryError
79− (B.unpack funcName ++ " " ++ show status)
79+ let errMsg msg = throwIO $ QueryError
80+ (B.unpack funcName ++ " " ++ msg)
8081 template
82+ let err = errMsg $ show status
8183 case status of
8284 PQ.EmptyQuery -> err
8385 PQ.CommandOk -> err
8486 PQ.TuplesOk -> err
8587 PQ.CopyOut -> return ()
8688 PQ.CopyIn -> return ()
89+ PQ.CopyBoth -> errMsg "COPY BOTH is not supported"
90+ PQ.SingleTuple -> errMsg "single-row mode is not supported"
8791 PQ.BadResponse -> throwResultError funcName result status
8892 PQ.NonfatalError -> throwResultError funcName result status
8993 PQ.FatalError -> throwResultError funcName result status
@@ -97,6 +101,30 @@ data CopyOutResult
97101 deriving (Eq, Typeable, Show)
98102
99103
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+
100128-- | Retrieve some data from a @COPY TO STDOUT@ query. A connection
101129-- must be in the @CopyOut@ state in order to call this function. If this
102130-- returns a 'CopyOutRow', the connection remains in the @CopyOut@ state,
@@ -224,7 +252,9 @@ getCopyCommandTag funcName pqconn = do
224252 consumeResults pqconn
225253 let rowCount = P.string "COPY " *> (P.decimal <* P.endOfInput)
226254 case P.parseOnly rowCount cmdStat of
227− Left _ -> fail errCmdStatusFmt
255+ Left _ -> do mmsg <- PQ.errorMessage pqconn
256+ fail $ errCmdStatusFmt
257+ ++ maybe "" (\msg -> "\nConnection error: "++B.unpack msg) mmsg
228258 Right n -> return $! n
229259 where
230260 errCmdStatus = B.unpack funcName ++ ": failed to fetch command status"
src/Database/PostgreSQL/Simple/Cursor.hsnew file+98
@@ -0,0 +1,98 @@
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+12−11
@@ -25,7 +25,6 @@ module Database.PostgreSQL.Simple.Errors
2525 )
2626 where
2727
28−import Control.Applicative
2928import Control.Exception as E
3029
3130import Data.Attoparsec.ByteString.Char8
@@ -60,16 +59,18 @@ data ConstraintViolation
6059 deriving (Show, Eq, Ord, Typeable)
6160
6261-- Default instance should be enough
63−instance Exception ConstraintViolation
62+instance Exception ConstraintViolation where
63+ toException = postgresqlExceptionToException
64+ fromException = postgresqlExceptionFromException
6465
6566
6667-- | Tries to convert 'SqlError' to 'ConstrainViolation', checks sqlState and
67−-- succeedes only if able to parse sqlErrorMsg.
68+-- succeeds only if able to parse sqlErrorMsg.
6869--
69−-- > createUser = catchJust constraintViolation catcher $ execute conn ...
70+-- > createUser = handleJust constraintViolation handler $ execute conn ...
7071-- > where
71−-- > catcher UniqueViolation "user_login_key" = ...
72−-- > catcher _ = ...
72+-- > handler (UniqueViolation "user_login_key") = ...
73+-- > handler _ = ...
7374constraintViolation :: SqlError -> Maybe ConstraintViolation
7475constraintViolation e =
7576 case sqlState e of
@@ -84,16 +85,16 @@ constraintViolation e =
8485
8586-- | Like constraintViolation, but also packs original SqlError.
8687--
87−-- > createUser = catchJust constraintViolationE catcher $ execute conn ...
88+-- > createUser = handleJust constraintViolationE handler $ execute conn ...
8889-- > where
89−-- > catcher (_, UniqueViolation "user_login_key") = ...
90−-- > catcher (e, _) = throwIO e
90+-- > handler (_, UniqueViolation "user_login_key") = ...
91+-- > handler (e, _) = throwIO e
9192--
9293constraintViolationE :: SqlError -> Maybe (SqlError, ConstraintViolation)
9394constraintViolationE e = fmap ((,) e) $ constraintViolation e
9495
9596-- | Catches SqlError, tries to convert to ConstraintViolation, re-throws
96−-- on fail. Provides alternative interface to catchJust
97+-- on fail. Provides alternative interface to 'E.handleJust'
9798--
9899-- > createUser = catchViolation catcher $ execute conn ...
99100-- > where
@@ -124,7 +125,7 @@ parseMaybe p b = either (const Nothing) Just $ parseOnly p b
124125------------------------------------------------------------------------
125126-- Error predicates
126127--
127−-- http://www.postgresql.org/docs/current/static/errcodes-appendix.html
128+-- https://www.postgresql.org/docs/9.5/static/errcodes-appendix.html
128129
129130isSerializationError :: SqlError -> Bool
130131isSerializationError = isSqlState "40001"
src/Database/PostgreSQL/Simple/FromField.hs+152−77
@@ -1,7 +1,8 @@
11{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-}
22{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
33{-# LANGUAGE PatternGuards, ScopedTypeVariables #-}
4−{-# LANGUAGE RecordWildCards, TemplateHaskell #-}
4+{-# LANGUAGE RecordWildCards #-}
5+{-# LANGUAGE PolyKinds #-}
56
67{- |
78Module: Database.PostgreSQL.Simple.FromField
@@ -106,24 +107,27 @@ module Database.PostgreSQL.Simple.FromField
106107 , PQ.Oid(..)
107108 , PQ.Format(..)
108109 , pgArrayFieldParser
110+ , attoFieldParser
109111
112+ , optionalField
110113 , fromJSONField
114+ , fromFieldJSONByteString
111115 ) where
112116
113117#include "MachDeps.h"
114118
115−import Control.Applicative ( (<|>), (<$>), pure, (*>), (<*) )
119+import Control.Applicative ( Const(Const), (<|>), (<$>), pure, (*>), (<*) )
116120import Control.Concurrent.MVar (MVar, newMVar)
117−import Control.Exception (Exception)
121+import Control.Exception (Exception (toException, fromException))
118122import qualified Data.Aeson as JSON
119−import qualified Data.Aeson.Parser as JSON (value')
120123import Data.Attoparsec.ByteString.Char8 hiding (Result)
121124import Data.ByteString (ByteString)
122125import qualified Data.ByteString.Char8 as B
126+import Data.Functor.Identity (Identity(Identity))
123127import Data.Int (Int16, Int32, Int64)
124128import Data.IORef (IORef, newIORef)
125129import Data.Ratio (Ratio)
126−import Data.Time ( UTCTime, ZonedTime, LocalTime, Day, TimeOfDay )
130+import Data.Time.Compat ( UTCTime, ZonedTime, LocalTime, Day, TimeOfDay, CalendarDiffTime )
127131import Data.Typeable (Typeable, typeOf)
128132import Data.Vector (Vector)
129133import Data.Vector.Mutable (IOVector)
@@ -134,7 +138,6 @@ import Database.PostgreSQL.Simple.Ok
134138import Database.PostgreSQL.Simple.Types
135139import Database.PostgreSQL.Simple.TypeInfo as TI
136140import qualified Database.PostgreSQL.Simple.TypeInfo.Static as TI
137−import Database.PostgreSQL.Simple.TypeInfo.Macro as TI
138141import Database.PostgreSQL.Simple.Time
139142import Database.PostgreSQL.Simple.Arrays as Arrays
140143import qualified Database.PostgreSQL.LibPQ as PQ
@@ -151,6 +154,8 @@ import qualified Data.UUID.Types as UUID
151154import Data.Scientific (Scientific)
152155import GHC.Real (infinity, notANumber)
153156
157+import qualified Data.Aeson.Types as JSON
158+
154159-- | Exception thrown if conversion from a SQL value to a Haskell
155160-- value fails.
156161data ResultError = Incompatible { errSQLType :: String
@@ -177,7 +182,9 @@ data ResultError = Incompatible { errSQLType :: String
177182 -- between metadata and actual data in a row).
178183 deriving (Eq, Show, Typeable)
179184
180−instance Exception ResultError
185+instance Exception ResultError where
186+ toException = postgresqlExceptionToException
187+ fromException = postgresqlExceptionFromException
181188
182189left :: Exception a => a -> Conversion b
183190left = conversionError
@@ -243,9 +250,11 @@ tableOid Field{..} = toMaybeOid (unsafeDupablePerformIO (PQ.ftable result column
243250 then Nothing
244251 else Just x
245252
246−-- | If the column has a table associated with it, this returns the number
247−-- off the associated table column. Numbering starts from 0. Analogous
248−-- to libpq's @PQftablecol@.
253+-- | If the column has a table associated with it, this returns the
254+-- number of the associated table column. Table columns have
255+-- nonzero numbers. Zero is returned if the specified column is not
256+-- a simple reference to a table column, or when using pre-3.0
257+-- protocol. Analogous to libpq's @PQftablecol@.
249258
250259tableColumn :: Field -> Int
251260tableColumn Field{..} = fromCol (unsafeDupablePerformIO (PQ.ftablecol result column))
@@ -261,16 +270,33 @@ format Field{..} = unsafeDupablePerformIO (PQ.fformat result column)
261270-- | void
262271instance FromField () where
263272 fromField f _bs
264− | typeOid f /= $(inlineTypoid TI.void) = returnError Incompatible f ""
273+ | typeOid f /= TI.voidOid = returnError Incompatible f ""
265274 | otherwise = pure ()
266275
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+
267282-- | For dealing with null values. Compatible with any postgresql type
268283-- compatible with type @a@. Note that the type is not checked if
269284-- the value is null, although it is inadvisable to rely on this
270285-- behavior.
271−instance (FromField a) => FromField (Maybe a) where
272− fromField _ Nothing = pure Nothing
273− fromField f bs = Just <$> fromField f bs
286+instance FromField a => FromField (Maybe a) where
287+ fromField = optionalField fromField
288+
289+-- | For dealing with SQL @null@ values outside of the 'FromField' class.
290+-- Alternatively, one could use 'Control.Applicative.optional', but that
291+-- also turns type and conversion errors into 'Nothing', whereas this is
292+-- more specific and turns only @null@ values into 'Nothing'.
293+
294+optionalField :: FieldParser a -> FieldParser (Maybe a)
295+optionalField p f mv =
296+ case mv of
297+ Nothing -> pure Nothing
298+ Just _ -> Just <$> p f mv
299+{-# INLINE optionalField #-}
274300
275301-- | compatible with any data type, but the value must be null
276302instance FromField Null where
@@ -280,30 +306,30 @@ instance FromField Null where
280306-- | bool
281307instance FromField Bool where
282308 fromField f bs
283− | typeOid f /= $(inlineTypoid TI.bool) = returnError Incompatible f ""
309+ | typeOid f /= TI.boolOid = returnError Incompatible f ""
284310 | bs == Nothing = returnError UnexpectedNull f ""
285311 | bs == Just "t" = pure True
286312 | bs == Just "f" = pure False
287313 | otherwise = returnError ConversionFailed f ""
288314
289−-- | \"char\"
315+-- | \"char\", bpchar
290316instance FromField Char where
291− fromField f bs =
292− if typeOid f /= $(inlineTypoid TI.char)
293− then returnError Incompatible f ""
294− else case bs of
317+ fromField f bs0 =
318+ if (eq TI.charOid \/ eq TI.bpcharOid) (typeOid f)
319+ then case bs0 of
295320 Nothing -> returnError UnexpectedNull f ""
296321 Just bs -> if B.length bs /= 1
297322 then returnError ConversionFailed f "length not 1"
298323 else return $! (B.head bs)
324+ else returnError Incompatible f ""
299325
300326-- | int2
301327instance FromField Int16 where
302− fromField = atto ok16 $ signed decimal
328+ fromField = attoFieldParser ok16 $ signed decimal
303329
304330-- | int2, int4
305331instance FromField Int32 where
306− fromField = atto ok32 $ signed decimal
332+ fromField = attoFieldParser ok32 $ signed decimal
307333
308334#if WORD_SIZE_IN_BITS < 64
309335-- | int2, int4, and if compiled as 64-bit code, int8 as well.
@@ -313,37 +339,37 @@ instance FromField Int32 where
313339-- This library was compiled as 64-bit code.
314340#endif
315341instance FromField Int where
316− fromField = atto okInt $ signed decimal
342+ fromField = attoFieldParser okInt $ signed decimal
317343
318344-- | int2, int4, int8
319345instance FromField Int64 where
320− fromField = atto ok64 $ signed decimal
346+ fromField = attoFieldParser ok64 $ signed decimal
321347
322348-- | int2, int4, int8
323349instance FromField Integer where
324− fromField = atto ok64 $ signed decimal
350+ fromField = attoFieldParser ok64 $ signed decimal
325351
326352-- | int2, float4 (Uses attoparsec's 'double' routine, for
327353-- better accuracy convert to 'Scientific' or 'Rational' first)
328354instance FromField Float where
329− fromField = atto ok (realToFrac <$> pg_double)
330− where ok = $(mkCompats [TI.float4,TI.int2])
355+ fromField = attoFieldParser ok (realToFrac <$> pg_double)
356+ where ok = eq TI.float4Oid \/ eq TI.int2Oid
331357
332358-- | int2, int4, float4, float8 (Uses attoparsec's 'double' routine, for
333359-- better accuracy convert to 'Scientific' or 'Rational' first)
334360instance FromField Double where
335− fromField = atto ok pg_double
336− where ok = $(mkCompats [TI.float4,TI.float8,TI.int2,TI.int4])
361+ fromField = attoFieldParser ok pg_double
362+ where ok = eq TI.float4Oid \/ eq TI.float8Oid \/ eq TI.int2Oid \/ eq TI.int4Oid
337363
338364-- | int2, int4, int8, float4, float8, numeric
339365instance FromField (Ratio Integer) where
340− fromField = atto ok pg_rational
341− where ok = $(mkCompats [TI.float4,TI.float8,TI.int2,TI.int4,TI.int8,TI.numeric])
366+ fromField = attoFieldParser ok pg_rational
367+ where ok = eq TI.float4Oid \/ eq TI.float8Oid \/ eq TI.int2Oid \/ eq TI.int4Oid \/ eq TI.int8Oid \/ eq TI.numericOid
342368
343369-- | int2, int4, int8, float4, float8, numeric
344370instance FromField Scientific where
345− fromField = atto ok rational
346− where ok = $(mkCompats [TI.float4,TI.float8,TI.int2,TI.int4,TI.int8,TI.numeric])
371+ fromField = attoFieldParser ok rational
372+ where ok = eq TI.float4Oid \/ eq TI.float8Oid \/ eq TI.int2Oid \/ eq TI.int4Oid \/ eq TI.int8Oid \/ eq TI.numericOid
347373
348374unBinary :: Binary t -> t
349375unBinary (Binary x) = x
@@ -364,13 +390,13 @@ pg_rational
364390
365391-- | bytea, name, text, \"char\", bpchar, varchar, unknown
366392instance FromField SB.ByteString where
367− fromField f dat = if typeOid f == $(inlineTypoid TI.bytea)
393+ fromField f dat = if typeOid f == TI.byteaOid
368394 then unBinary <$> fromField f dat
369395 else doFromField f okText' pure dat
370396
371397-- | oid
372398instance FromField PQ.Oid where
373− fromField f dat = PQ.Oid <$> atto (== $(inlineTypoid TI.oid)) decimal f dat
399+ fromField f dat = PQ.Oid <$> attoFieldParser (== TI.oidOid) decimal f dat
374400
375401-- | bytea, name, text, \"char\", bpchar, varchar, unknown
376402instance FromField LB.ByteString where
@@ -378,7 +404,7 @@ instance FromField LB.ByteString where
378404
379405unescapeBytea :: Field -> SB.ByteString
380406 -> Conversion (Binary SB.ByteString)
381−unescapeBytea f str = case unsafeDupablePerformIO (PQ.unescapeBytea str) of
407+unescapeBytea f str' = case unsafeDupablePerformIO (PQ.unescapeBytea str') of
382408 Nothing -> returnError ConversionFailed f "unescapeBytea failed"
383409 Just str -> pure (Binary str)
384410
@@ -429,48 +455,57 @@ instance FromField [Char] where
429455
430456-- | timestamptz
431457instance FromField UTCTime where
432− fromField = ff $(inlineTypoid TI.timestamptz) "UTCTime" parseUTCTime
458+ fromField = ff TI.timestamptzOid "UTCTime" parseUTCTime
433459
434460-- | timestamptz
435461instance FromField ZonedTime where
436− fromField = ff $(inlineTypoid TI.timestamptz) "ZonedTime" parseZonedTime
462+ fromField = ff TI.timestamptzOid "ZonedTime" parseZonedTime
437463
438464-- | timestamp
439465instance FromField LocalTime where
440− fromField = ff $(inlineTypoid TI.timestamp) "LocalTime" parseLocalTime
466+ fromField = ff TI.timestampOid "LocalTime" parseLocalTime
441467
442468-- | date
443469instance FromField Day where
444− fromField = ff $(inlineTypoid TI.date) "Day" parseDay
470+ fromField = ff TI.dateOid "Day" parseDay
445471
446472-- | time
447473instance FromField TimeOfDay where
448− fromField = ff $(inlineTypoid TI.time) "TimeOfDay" parseTimeOfDay
474+ fromField = ff TI.timeOid "TimeOfDay" parseTimeOfDay
449475
450476-- | timestamptz
451477instance FromField UTCTimestamp where
452− fromField = ff $(inlineTypoid TI.timestamptz) "UTCTimestamp" parseUTCTimestamp
478+ fromField = ff TI.timestamptzOid "UTCTimestamp" parseUTCTimestamp
453479
454480-- | timestamptz
455481instance FromField ZonedTimestamp where
456− fromField = ff $(inlineTypoid TI.timestamptz) "ZonedTimestamp" parseZonedTimestamp
482+ fromField = ff TI.timestamptzOid "ZonedTimestamp" parseZonedTimestamp
457483
458484-- | timestamp
459485instance FromField LocalTimestamp where
460− fromField = ff $(inlineTypoid TI.timestamp) "LocalTimestamp" parseLocalTimestamp
486+ fromField = ff TI.timestampOid "LocalTimestamp" parseLocalTimestamp
461487
462488-- | date
463489instance FromField Date where
464− fromField = ff $(inlineTypoid TI.date) "Date" parseDate
490+ fromField = ff TI.dateOid "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
465500
466501ff :: PQ.Oid -> String -> (B8.ByteString -> Either String a)
467502 -> Field -> Maybe B8.ByteString -> Conversion a
468−ff compatOid hsType parse f mstr =
503+ff compatOid hsType parseBS f mstr =
469504 if typeOid f /= compatOid
470505 then err Incompatible ""
471506 else case mstr of
472507 Nothing -> err UnexpectedNull ""
473− Just str -> case parse str of
508+ Just str -> case parseBS str of
474509 Left msg -> err ConversionFailed msg
475510 Right val -> return val
476511 where
@@ -508,13 +543,13 @@ pgArrayFieldParser fieldParser f mdat = do
508543 _ -> returnError Incompatible f ""
509544
510545fromArray :: FieldParser a -> TypeInfo -> Field -> Parser (Conversion [a])
511−fromArray fieldParser typeInfo f = sequence . (parseIt <$>) <$> array delim
546+fromArray fieldParser typInfo f = sequence . (parseIt <$>) <$> array delim
512547 where
513− delim = typdelim (typelem typeInfo)
514− fElem = f{ typeOid = typoid (typelem typeInfo) }
548+ delim = typdelim (typelem typInfo)
549+ fElem = f{ typeOid = typoid (typelem typInfo) }
515550
516551 parseIt item =
517− fieldParser f' $ if item' == "NULL" then Nothing else Just item'
552+ fieldParser f' $ if item == Arrays.Plain "NULL" then Nothing else Just item'
518553 where
519554 item' = fmt delim item
520555 f' | Arrays.Array _ <- item = f
@@ -529,7 +564,7 @@ instance (FromField a, Typeable a) => FromField (IOVector a) where
529564-- | uuid
530565instance FromField UUID where
531566 fromField f mbs =
532− if typeOid f /= $(inlineTypoid TI.uuid)
567+ if typeOid f /= TI.uuidOid
533568 then returnError Incompatible f ""
534569 else case mbs of
535570 Nothing -> returnError UnexpectedNull f ""
@@ -538,20 +573,26 @@ instance FromField UUID where
538573 Nothing -> returnError ConversionFailed f "Invalid UUID"
539574 Just uuid -> pure uuid
540575
541−-- | json
576+-- | json, jsonb
542577instance FromField JSON.Value where
543− fromField f mbs =
544− if typeOid f /= $(inlineTypoid TI.json) && typeOid f /= $(inlineTypoid TI.jsonb)
578+ fromField f mbs = parseBS =<< fromFieldJSONByteString f mbs
579+ where parseBS bs = case JSON.eitherDecodeStrict' bs of
580+ Left err -> returnError ConversionFailed f err
581+ Right val -> pure val
582+
583+-- | Return the JSON ByteString directly
584+--
585+-- @since 0.6.3
586+fromFieldJSONByteString :: Field -> Maybe ByteString -> Conversion ByteString
587+fromFieldJSONByteString f mbs =
588+ if typeOid f /= TI.jsonOid && typeOid f /= TI.jsonbOid
545589 then returnError Incompatible f ""
546590 else case mbs of
547591 Nothing -> returnError UnexpectedNull f ""
548− Just bs ->
549− case parseOnly (JSON.value' <* endOfInput) bs of
550− Left err -> returnError ConversionFailed f err
551− Right val -> pure val
592+ Just bs -> pure bs
552593
553594-- | Parse a field to a JSON 'JSON.Value' and convert that into a
554−-- Haskell value using 'JSON.fromJSON'.
595+-- Haskell value using the 'JSON.FromJSON' instance.
555596--
556597-- This can be used as the default implementation for the 'fromField'
557598-- method for Haskell types that have a JSON representation in
@@ -559,14 +600,23 @@ instance FromField JSON.Value where
559600--
560601-- The 'Typeable' constraint is required to show more informative
561602-- 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@
562613fromJSONField :: (JSON.FromJSON a, Typeable a) => FieldParser a
563614fromJSONField f mbBs = do
564615 value <- fromField f mbBs
565− case JSON.fromJSON value of
566− JSON.Error err -> returnError ConversionFailed f $
567− "JSON decoding error: " ++ err
568− JSON.Success x -> pure x
569−
616+ case JSON.ifromJSON value of
617+ JSON.IError path err -> returnError ConversionFailed f $
618+ "JSON decoding error: " ++ (JSON.formatError path err)
619+ JSON.ISuccess x -> pure x
570620
571621-- | Compatible with the same set of types as @a@. Note that
572622-- modifying the 'IORef' does not have any effects outside
@@ -583,20 +633,33 @@ instance FromField a => FromField (MVar a) where
583633type Compat = PQ.Oid -> Bool
584634
585635okText, okText', okBinary, ok16, ok32, ok64, okInt :: Compat
586−okText = $( mkCompats [ TI.name, TI.text, TI.char,
587− TI.bpchar, TI.varchar ] )
588−okText' = $( mkCompats [ TI.name, TI.text, TI.char,
589− TI.bpchar, TI.varchar, TI.unknown ] )
590−okBinary = (== $( inlineTypoid TI.bytea ))
591−ok16 = (== $( inlineTypoid TI.int2 ))
592−ok32 = $( mkCompats [TI.int2,TI.int4] )
593−ok64 = $( mkCompats [TI.int2,TI.int4,TI.int8] )
636+okText = eq TI.nameOid \/ eq TI.textOid \/ eq TI.charOid
637+ \/ eq TI.bpcharOid \/ eq TI.varcharOid
638+okText' = eq TI.nameOid \/ eq TI.textOid \/ eq TI.charOid
639+ \/ eq TI.bpcharOid \/ eq TI.varcharOid \/ eq TI.unknownOid
640+okBinary = eq TI.byteaOid
641+ok16 = eq TI.int2Oid
642+ok32 = eq TI.int2Oid \/ eq TI.int4Oid
643+ok64 = eq TI.int2Oid \/ eq TI.int4Oid \/ eq TI.int8Oid
594644#if WORD_SIZE_IN_BITS < 64
595645okInt = ok32
596646#else
597647okInt = ok64
598648#endif
599649
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+
600663doFromField :: forall a . (Typeable a)
601664 => Field -> Compat -> (ByteString -> Conversion a)
602665 -> Maybe ByteString -> Conversion a
@@ -621,10 +684,22 @@ returnError mkErr f msg = do
621684 (show (typeOf (undefined :: a)))
622685 msg
623686
624−atto :: forall a. (Typeable a)
625− => Compat -> Parser a -> Field -> Maybe ByteString
626− -> Conversion a
627−atto types p0 f dat = doFromField f types (go p0) dat
687+-- | Construct a field parser from an attoparsec parser. An 'Incompatible' error is thrown if the
688+-- PostgreSQL oid does not match the specified predicate.
689+--
690+-- @
691+-- instance FromField Int16 where
692+-- fromField = attoFieldParser ok16 (signed decimal)
693+-- @
694+--
695+-- @since 0.6.3
696+attoFieldParser :: forall a. (Typeable a)
697+ => (PQ.Oid -> Bool)
698+ -- ^ Predicate for whether the postgresql type oid is compatible with this parser
699+ -> Parser a
700+ -- ^ An attoparsec parser.
701+ -> FieldParser a
702+attoFieldParser types p0 f dat = doFromField f types (go p0) dat
628703 where
629704 go :: Parser a -> ByteString -> Conversion a
630705 go p s =
src/Database/PostgreSQL/Simple/FromRow.hs+239−6
@@ -1,4 +1,6 @@
1−{-# LANGUAGE RecordWildCards, FlexibleInstances #-}
1+{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE RecordWildCards, FlexibleInstances, DefaultSignatures #-}
3+
24
35------------------------------------------------------------------------------
46-- |
@@ -27,7 +29,7 @@ module Database.PostgreSQL.Simple.FromRow
2729 ) where
2830
2931import Prelude hiding (null)
30−import Control.Applicative (Applicative(..), (<$>), (<|>), (*>))
32+import Control.Applicative (Applicative(..), (<$>), (<|>), (*>), liftA2)
3133import Control.Monad (replicateM, replicateM_)
3234import Control.Monad.Trans.State.Strict
3335import Control.Monad.Trans.Reader
@@ -45,13 +47,17 @@ import Database.PostgreSQL.Simple.Ok
4547import Database.PostgreSQL.Simple.Types ((:.)(..), Null)
4648import Database.PostgreSQL.Simple.TypeInfo
4749
50+import GHC.Generics
51+
52+
4853-- | A collection type that can be converted from a sequence of fields.
4954-- Instances are provided for tuples up to 10 elements and lists of any length.
5055--
5156-- Note that instances can be defined outside of postgresql-simple, which is
5257-- often useful. For example, here's an instance for a user-defined pair:
5358--
54−-- @data User = User { name :: String, fileQuota :: Int }
59+-- @
60+-- data User = User { name :: String, fileQuota :: Int }
5561--
5662-- instance 'FromRow' User where
5763-- fromRow = User \<$\> 'field' \<*\> 'field'
@@ -61,13 +67,32 @@ import Database.PostgreSQL.Simple.TypeInfo
6167-- in a single row of the query result. Otherwise, a 'ConversionFailed'
6268-- exception will be thrown.
6369--
64−-- Note that 'field' evaluates it's result to WHNF, so the caveats listed in
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
6588-- mysql-simple and very early versions of postgresql-simple no longer apply.
6689-- Instead, look at the caveats associated with user-defined implementations
6790-- of 'fromField'.
6891
6992class FromRow a where
7093 fromRow :: RowParser a
94+ default fromRow :: (Generic a, GFromRow (Rep a)) => RowParser a
95+ fromRow = to <$> gfromRow
7196
7297getvalue :: PQ.Result -> PQ.Row -> PQ.Column -> Maybe ByteString
7398getvalue result row col = unsafeDupablePerformIO (PQ.getvalue' result row col)
@@ -106,8 +131,8 @@ fieldWith fieldP = RP $ do
106131 else do
107132 let !result = rowresult
108133 !typeOid = unsafeDupablePerformIO (PQ.ftype result column)
109− !field = Field{..}
110− lift (lift (fieldP field (getvalue result row column)))
134+ !field' = Field{..}
135+ lift (lift (fieldP field' (getvalue result row column)))
111136
112137field :: FromField a => RowParser a
113138field = fieldWith fromField
@@ -230,6 +255,196 @@ instance (FromField a, FromField b, FromField c, FromField d, FromField e,
230255 null *> null *> null *> null *> null *> pure Nothing)
231256 <|> (Just <$> fromRow)
232257
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+
233448instance FromField a => FromRow [a] where
234449 fromRow = do
235450 n <- numFieldsRemaining
@@ -252,3 +467,21 @@ instance FromField a => FromRow (Maybe (Vector a)) where
252467
253468instance (FromRow a, FromRow b) => FromRow (a :. b) where
254469 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 @@
88--
99-- Parsers and printers for hstore, a extended type bundled with
1010-- PostgreSQL providing finite maps from text strings to text strings.
11−-- See <http://www.postgresql.org/docs/9.2/static/hstore.html> for more
11+-- See <https://www.postgresql.org/docs/9.5/static/hstore.html> for more
1212-- information.
1313--
1414-- Note that in order to use this type, a database superuser must
1515-- install it by running a sql script in the share directory. This
1616-- can be done on PostgreSQL 9.1 and later with the command
1717-- @CREATE EXTENSION hstore@. See
18−-- <http://www.postgresql.org/docs/9.2/static/contrib.html> for more
18+-- <https://www.postgresql.org/docs/9.5/static/contrib.html> for more
1919-- information.
2020--
2121------------------------------------------------------------------------------
src/Database/PostgreSQL/Simple/HStore/Implementation.hs+11−11
@@ -22,9 +22,6 @@ import Data.ByteString.Builder (Builder, byteString, char8)
2222import qualified Data.ByteString.Builder as BU
2323import Data.ByteString.Internal (c2w, w2c)
2424import qualified Data.ByteString.Lazy as BL
25−#if !MIN_VERSION_bytestring(0,10,0)
26−import qualified Data.ByteString.Lazy.Internal as BL (foldrChunks)
27−#endif
2825import Data.Map(Map)
2926import qualified Data.Map as Map
3027import Data.Text(Text)
@@ -34,6 +31,7 @@ import Data.Text.Encoding.Error(UnicodeException)
3431import qualified Data.Text.Lazy as TL
3532import Data.Typeable
3633import Data.Monoid(Monoid(..))
34+import Data.Semigroup
3735import Database.PostgreSQL.Simple.FromField
3836import Database.PostgreSQL.Simple.ToField
3937
@@ -52,26 +50,28 @@ instance ToHStore HStoreBuilder where
5250toBuilder :: HStoreBuilder -> Builder
5351toBuilder x = case x of
5452 Empty -> mempty
55− Comma x -> x
53+ Comma c -> c
5654
5755toLazyByteString :: HStoreBuilder -> BL.ByteString
5856toLazyByteString x = case x of
5957 Empty -> BL.empty
60− Comma x -> BU.toLazyByteString x
58+ Comma c -> BU.toLazyByteString c
6159
62−instance Monoid HStoreBuilder where
63− mempty = Empty
64− mappend Empty x = x
65− mappend (Comma a) x
60+instance Semigroup HStoreBuilder where
61+ Empty <> x = x
62+ Comma a <> x
6663 = Comma (a `mappend` case x of
6764 Empty -> mempty
6865 Comma b -> char8 ',' `mappend` b)
6966
67+instance Monoid HStoreBuilder where
68+ mempty = Empty
69+
7070class ToHStoreText a where
7171 toHStoreText :: a -> HStoreText
7272
7373-- | Represents escape text, ready to be the key or value to a hstore value
74−newtype HStoreText = HStoreText Builder deriving (Typeable, Monoid)
74+newtype HStoreText = HStoreText Builder deriving (Typeable, Semigroup, Monoid)
7575
7676instance ToHStoreText HStoreText where
7777 toHStoreText = id
@@ -144,7 +144,7 @@ newtype HStoreMap = HStoreMap {fromHStoreMap :: Map Text Text} deriving (Eq, Or
144144
145145instance ToHStore HStoreMap where
146146 toHStore (HStoreMap xs) = Map.foldrWithKey f mempty xs
147− where f k v xs = hstore k v `mappend` xs
147+ where f k v xs' = hstore k v `mappend` xs'
148148
149149instance ToField HStoreMap where
150150 toField xs = toField (toHStore xs)
src/Database/PostgreSQL/Simple/HStore/Internal.hs−2
@@ -1,5 +1,3 @@
1−{-# OPTIONS_HADDOCK hide #-}
2−
31------------------------------------------------------------------------------
42-- |
53-- Module: Database.PostgreSQL.Simple.HStore.Internal
src/Database/PostgreSQL/Simple/Internal.hs+84−25
@@ -1,10 +1,13 @@
11{-# LANGUAGE CPP, BangPatterns, DoAndIfThenElse, RecordWildCards #-}
2−{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
2+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}
3+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4+{-# LANGUAGE ExistentialQuantification #-}
5+{-# LANGUAGE InstanceSigs #-}
36
47------------------------------------------------------------------------------
58-- |
69-- Module: Database.PostgreSQL.Simple.Internal
7−-- Copyright: (c) 2011-2012 Leon P Smith
10+-- Copyright: (c) 2011-2015 Leon P Smith
811-- License: BSD3
912-- Maintainer: Leon P Smith <leon@melding-monads.com>
1013-- Stability: experimental
@@ -33,7 +36,6 @@ import Data.Int (Int64)
3336import qualified Data.IntMap as IntMap
3437import Data.IORef
3538import Data.Maybe(fromMaybe)
36−import Data.Monoid
3739import Data.String
3840import qualified Data.Text as T
3941import qualified Data.Text.Encoding as TE
@@ -50,6 +52,7 @@ import Database.PostgreSQL.Simple.TypeInfo.Types(TypeInfo)
5052import Control.Monad.Trans.State.Strict
5153import Control.Monad.Trans.Reader
5254import Control.Monad.Trans.Class
55+import GHC.Generics
5356import GHC.IO.Exception
5457#if !defined(mingw32_HOST_OS)
5558import Control.Concurrent(threadWaitRead, threadWaitWrite)
@@ -80,18 +83,40 @@ data Connection = Connection {
8083instance Eq Connection where
8184 x == y = connectionHandle x == connectionHandle y
8285
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+
83105data SqlError = SqlError {
84106 sqlState :: ByteString
85107 , sqlExecStatus :: ExecStatus
86108 , sqlErrorMsg :: ByteString
87109 , sqlErrorDetail :: ByteString
88110 , sqlErrorHint :: ByteString
89− } deriving (Show, Typeable)
111+ } deriving (Eq, Show, Typeable)
90112
91113fatalError :: ByteString -> SqlError
92114fatalError msg = SqlError "" FatalError msg "" ""
93115
94−instance Exception SqlError
116+instance Exception SqlError where
117+ toException = postgresqlExceptionToException
118+ fromException = postgresqlExceptionFromException
119+
95120
96121-- | Exception thrown if 'query' is used to perform an @INSERT@-like
97122-- operation, or 'execute' is used to perform a @SELECT@-like operation.
@@ -100,7 +125,9 @@ data QueryError = QueryError {
100125 , qeQuery :: Query
101126 } deriving (Eq, Show, Typeable)
102127
103−instance Exception QueryError
128+instance Exception QueryError where
129+ toException = postgresqlExceptionToException
130+ fromException = postgresqlExceptionFromException
104131
105132-- | Exception thrown if a 'Query' could not be formatted correctly.
106133-- This may occur if the number of \'@?@\' characters in the query
@@ -111,7 +138,9 @@ data FormatError = FormatError {
111138 , fmtParams :: [ByteString]
112139 } deriving (Eq, Show, Typeable)
113140
114−instance Exception FormatError
141+instance Exception FormatError where
142+ toException = postgresqlExceptionToException
143+ fromException = postgresqlExceptionFromException
115144
116145data ConnectInfo = ConnectInfo {
117146 connectHost :: String
@@ -119,7 +148,7 @@ data ConnectInfo = ConnectInfo {
119148 , connectUser :: String
120149 , connectPassword :: String
121150 , connectDatabase :: String
122− } deriving (Eq,Read,Show,Typeable)
151+ } deriving (Generic,Eq,Read,Show,Typeable)
123152
124153-- | Default information for setting up a connection.
125154--
@@ -153,10 +182,20 @@ defaultConnectInfo = ConnectInfo {
153182connect :: ConnectInfo -> IO Connection
154183connect = connectPostgreSQL . postgreSQLConnectionString
155184
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+
156191-- | Attempt to make a connection based on a libpq connection string.
157−-- See <http://www.postgresql.org/docs/9.3/static/libpq-connect.html#LIBPQ-CONNSTRING>
158−-- for more information. Here is an example with some
159−-- of the most commonly used parameters:
192+-- See <https://www.postgresql.org/docs/9.5/static/libpq-connect.html#LIBPQ-CONNSTRING>
193+-- for more information. Also note that environment variables also affect
194+-- parameters not provided, parameters provided as the empty string, and a
195+-- few other things; see
196+-- <https://www.postgresql.org/docs/9.5/static/libpq-envars.html>
197+-- for details. Here is an example with some of the most commonly used
198+-- parameters:
160199--
161200-- > host='db.somedomain.com' port=5432 ...
162201--
@@ -184,8 +223,9 @@ connect = connectPostgreSQL . postgreSQLConnectionString
184223--
185224-- Omitting @password@ will default to an appropriate password found
186225-- in the @pgpass@ file, or no password at all if a matching line is
187−-- not found. See
188−-- <http://www.postgresql.org/docs/9.3/static/libpq-pgpass.html> for
226+-- not found. The path of the @pgpass@ file may be specified by setting
227+-- the @PGPASSFILE@ environment variable. See
228+-- <https://www.postgresql.org/docs/9.5/static/libpq-pgpass.html> for
189229-- more information regarding this file.
190230--
191231-- As all parameters are optional and the defaults are sensible, the
@@ -203,18 +243,20 @@ connect = connectPostgreSQL . postgreSQLConnectionString
203243-- or production machines, or you will need to use a @pgpass@ file
204244-- with the @password@ or @md5@ authentication methods.
205245--
206−-- See <http://www.postgresql.org/docs/9.3/static/client-authentication.html>
246+-- See <https://www.postgresql.org/docs/9.5/static/client-authentication.html>
207247-- for more information regarding the authentication process.
208248--
209249-- SSL/TLS will typically "just work" if your postgresql server supports or
210250-- requires it. However, note that libpq is trivially vulnerable to a MITM
211−-- attack without setting additional SSL parameters in the connection string.
212−-- In particular, @sslmode@ needs to be set to @require@, @verify-ca@, or
251+-- attack without setting additional SSL connection parameters. In
252+-- particular, @sslmode@ needs to be set to @require@, @verify-ca@, or
213253-- @verify-full@ in order to perform certificate validation. When @sslmode@
214254-- is @require@, then you will also need to specify a @sslrootcert@ file,
215255-- otherwise no validation of the server's identity will be performed.
216256-- Client authentication via certificates is also possible via the
217−-- @sslcert@ and @sslkey@ parameters.
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.
218260
219261connectPostgreSQL :: ByteString -> IO Connection
220262connectPostgreSQL connstr = do
@@ -281,7 +323,7 @@ postgreSQLConnectionString connectInfo = fromString connstr
281323
282324 str name field
283325 | null value = id
284− | otherwise = showString name . quote value . space
326+ | otherwise = showString name . addQuotes value . space
285327 where value = field connectInfo
286328
287329 num name field
@@ -289,7 +331,7 @@ postgreSQLConnectionString connectInfo = fromString connstr
289331 | otherwise = showString name . shows value . space
290332 where value = field connectInfo
291333
292− quote str rest = '\'' : foldr delta ('\'' : rest) str
334+ addQuotes s rest = '\'' : foldr delta ('\'' : rest) s
293335 where
294336 delta c cs = case c of
295337 '\\' -> '\\' : '\\' : cs
@@ -345,6 +387,7 @@ exec conn sql =
345387 Just res -> do
346388 status <- PQ.resultStatus res
347389 case status of
390+ -- FIXME: handle PQ.CopyBoth and PQ.SingleTuple
348391 PQ.EmptyQuery -> getResult h mres'
349392 PQ.CommandOk -> getResult h mres'
350393 PQ.TuplesOk -> getResult h mres'
@@ -365,6 +408,7 @@ finishExecute :: Connection -> Query -> PQ.Result -> IO Int64
365408finishExecute _conn q result = do
366409 status <- PQ.resultStatus result
367410 case status of
411+ -- FIXME: handle PQ.CopyBoth and PQ.SingleTuple
368412 PQ.EmptyQuery -> throwIO $ QueryError "execute: Empty query" q
369413 PQ.CommandOk -> do
370414 ncols <- PQ.nfields result
@@ -375,7 +419,7 @@ finishExecute _conn q result = do
375419 nstr <- PQ.cmdTuples result
376420 return $ case nstr of
377421 Nothing -> 0 -- is this appropriate?
378− Just str -> toInteger str
422+ Just str -> mkInteger str
379423 PQ.TuplesOk -> do
380424 ncols <- PQ.nfields result
381425 throwIO $ QueryError ("execute resulted in " ++ show ncols ++
@@ -388,7 +432,7 @@ finishExecute _conn q result = do
388432 PQ.NonfatalError -> throwResultError "execute" result status
389433 PQ.FatalError -> throwResultError "execute" result status
390434 where
391− toInteger str = B8.foldl' delta 0 str
435+ mkInteger str = B8.foldl' delta 0 str
392436 where
393437 delta acc c =
394438 if '0' <= c && c <= '9'
@@ -403,8 +447,8 @@ throwResultError _ result status = do
403447 PQ.resultErrorField result PQ.DiagMessageDetail
404448 hint <- fromMaybe "" <$>
405449 PQ.resultErrorField result PQ.DiagMessageHint
406− state <- maybe "" id <$> PQ.resultErrorField result PQ.DiagSqlstate
407− throwIO $ SqlError { sqlState = state
450+ state' <- maybe "" id <$> PQ.resultErrorField result PQ.DiagSqlstate
451+ throwIO $ SqlError { sqlState = state'
408452 , sqlExecStatus = status
409453 , sqlErrorMsg = errormsg
410454 , sqlErrorDetail = detail
@@ -473,7 +517,6 @@ instance Alternative Conversion where
473517 Errors _ -> (oka <|>) <$> runConversion mb conn
474518
475519instance Monad Conversion where
476− return a = Conversion $ \_conn -> return (return a)
477520 m >>= f = Conversion $ \conn -> do
478521 oka <- runConversion m conn
479522 case oka of
@@ -488,7 +531,7 @@ conversionMap :: (Ok a -> Ok b) -> Conversion a -> Conversion b
488531conversionMap f m = Conversion $ \conn -> f <$> runConversion m conn
489532
490533conversionError :: Exception err => err -> Conversion a
491−conversionError err = Conversion $ \_ -> return (Errors [SomeException err])
534+conversionError err = Conversion $ \_ -> return (Errors [toException err])
492535
493536newTempName :: Connection -> IO Query
494537newTempName Connection{..} = do
@@ -576,3 +619,19 @@ escapeIdentifier = escapeWrap PQ.escapeIdentifier
576619
577620escapeByteaConn :: Connection -> ByteString -> IO (Either ByteString ByteString)
578621escapeByteaConn = 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.hsnew file+123
@@ -0,0 +1,123 @@
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+1−1
@@ -7,7 +7,7 @@
77-- Maintainer : leon@melding-monads.com
88--
99-- Support for PostgreSQL's Large Objects; see
10−-- <http://www.postgresql.org/docs/9.1/static/largeobjects.html> for more
10+-- <https://www.postgresql.org/docs/9.5/static/largeobjects.html> for more
1111-- information.
1212--
1313-- Note that Large Object File Descriptors are only valid within a single
src/Database/PostgreSQL/Simple/Newtypes.hsnew file+49
@@ -0,0 +1,49 @@
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+62−32
@@ -5,7 +5,8 @@
55-----------------------------------------------------------------------------
66-- |
77-- Module : Database.PostgreSQL.Simple.Notification
8−-- Copyright : (c) 2011-2012 Leon P Smith
8+-- Copyright : (c) 2011-2015 Leon P Smith
9+-- (c) 2012 Joey Adams
910-- License : BSD3
1011--
1112-- Maintainer : leon@melding-monads.com
@@ -13,7 +14,7 @@
1314--
1415-- Support for receiving asynchronous notifications via PostgreSQL's
1516-- Listen/Notify mechanism. See
16−-- <http://www.postgresql.org/docs/9.1/static/sql-notify.html> for more
17+-- <https://www.postgresql.org/docs/9.5/static/sql-notify.html> for more
1718-- information.
1819--
1920-- Note that on Windows, @getNotification@ currently uses a polling loop
@@ -24,7 +25,7 @@
2425-- Notifications do not create any extra work for the backend, and are
2526-- likely cheaper on the client side as well.
2627--
27−-- <http://hackage.haskell.org/trac/ghc/ticket/7353>
28+-- <https://hackage.haskell.org/trac/ghc/ticket/7353>
2829--
2930-----------------------------------------------------------------------------
3031
@@ -35,19 +36,27 @@ module Database.PostgreSQL.Simple.Notification
3536 , getBackendPID
3637 ) where
3738
38−import Control.Concurrent
39−import Control.Monad ( when )
40−import Control.Exception ( throwIO )
39+import Control.Monad ( join, void )
40+import Control.Exception ( throwIO, catch )
4141import qualified Data.ByteString as B
42+import qualified Data.ByteString.Char8 as B8
4243import Database.PostgreSQL.Simple.Internal
4344import qualified Database.PostgreSQL.LibPQ as PQ
4445import 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
4554
4655data Notification = Notification
47− { notificationPid :: !CPid
48− , notificationChannel :: !B.ByteString
49− , notificationData :: !B.ByteString
50− }
56+ { notificationPid :: {-# UNPACK #-} !CPid
57+ , notificationChannel :: {-# UNPACK #-} !B.ByteString
58+ , notificationData :: {-# UNPACK #-} !B.ByteString
59+ } deriving (Show, Eq)
5160
5261convertNotice :: PQ.Notify -> Notification
5362convertNotice PQ.Notify{..}
@@ -57,35 +66,56 @@ convertNotice PQ.Notify{..}
5766
5867-- | Returns a single notification. If no notifications are available,
5968-- '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.
6073
6174getNotification :: Connection -> IO Notification
62−getNotification conn = loop False
75+getNotification conn = join $ withConnection conn fetch
6376 where
6477 funcName = "Database.PostgreSQL.Simple.Notification.getNotification"
65− loop doConsume = do
66− res <- withConnection conn $ \c -> do
67− when doConsume (PQ.consumeInput c >> return ())
68− mmsg <- PQ.notifies c
69− case mmsg of
70− Nothing -> do
71− mfd <- PQ.socket c
72− case mfd of
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
78+
79+ fetch c = do
80+ mmsg <- PQ.notifies c
81+ case mmsg of
82+ Just msg -> return (return $! convertNotice msg)
83+ Nothing -> do
84+ mfd <- PQ.socket c
85+ case mfd of
86+ Nothing -> return (throwIO $! fdError funcName)
7887#if defined(mingw32_HOST_OS)
79− -- threadWaitRead doesn't work for sockets on Windows, so just poll
80− -- for input every second (PQconsumeInput is non-blocking).
81− --
82− -- We could call select(), but FFI calls can't be interrupted with
83− -- async exceptions, whereas threadDelay can.
84− Left _fd -> threadDelay 1000000 >> loop True
88+ -- threadWaitRead doesn't work for sockets on Windows, so just
89+ -- poll for input every second (PQconsumeInput is non-blocking).
90+ --
91+ -- We could call select(), but FFI calls can't be interrupted
92+ -- with async exceptions, whereas threadDelay can.
93+ Just _fd -> do
94+ return (threadDelay 1000000 >> loop)
8595#else
86− Left fd -> threadWaitRead fd >> loop True
96+ -- This case fixes the race condition above. By registering
97+ -- our interest in the descriptor before we drop the lock,
98+ -- there is no opportunity for the descriptor index to be
99+ -- reallocated on us.
100+ --
101+ -- (That is, assuming there isn't concurrently executing
102+ -- code that manipulates the descriptor without holding
103+ -- the lock... but such a major bug is likely to exhibit
104+ -- itself in an at least somewhat more dramatic fashion.)
105+ Just fd -> do
106+ (waitRead, _) <- threadWaitReadSTM fd
107+ return $ do
108+ atomically waitRead `catch` (throwIO . setIOErrorLocation)
109+ loop
87110#endif
88− Right msg -> return $! convertNotice msg
111+
112+ loop = join $ withConnection conn $ \c -> do
113+ void $ PQ.consumeInput c
114+ fetch c
115+
116+ setIOErrorLocation :: IOError -> IOError
117+ setIOErrorLocation err = err { ioe_location = B8.unpack funcName }
118+
89119
90120-- | Non-blocking variant of 'getNotification'. Returns a single notification,
91121-- if available. If no notifications are available, returns 'Nothing'.
src/Database/PostgreSQL/Simple/Ok.hs+10−4
@@ -1,10 +1,11 @@
11{-# LANGUAGE DeriveDataTypeable #-}
22{-# LANGUAGE DeriveFunctor #-}
3+{-# LANGUAGE CPP #-}
34
45------------------------------------------------------------------------------
56-- |
67-- Module : Database.PostgreSQL.Simple.Ok
7−-- Copyright : (c) 2012 Leon P Smith
8+-- Copyright : (c) 2012-2015 Leon P Smith
89-- License : BSD3
910--
1011-- Maintainer : leon@melding-monads.com
@@ -20,7 +21,7 @@
2021-- commonly-used type and typeclass included in @base@.
2122--
2223-- Extending the failure case to a list of 'SomeException's enables a
23−-- more sensible 'Alternative' instance definitions: '<|>' concatinates
24+-- more sensible 'Alternative' instance definitions: '<|>' concatenates
2425-- the list of exceptions when both cases fail, and 'empty' is defined as
2526-- 'Errors []'. Though '<|>' one could pick one of two exceptions, and
2627-- throw away the other, and have 'empty' provide a generic exception,
@@ -36,6 +37,8 @@ import Control.Exception
3637import Control.Monad(MonadPlus(..))
3738import Data.Typeable
3839
40+import qualified Control.Monad.Fail as Fail
41+
3942-- FIXME: [SomeException] should probably be something else, maybe
4043-- a difference list (or a tree?)
4144
@@ -69,11 +72,14 @@ instance MonadPlus Ok where
6972 mplus = (<|>)
7073
7174instance Monad Ok where
72− return = Ok
73−
7475 Errors es >>= _ = Errors es
7576 Ok a >>= f = f a
7677
78+#if !(MIN_VERSION_base(4,13,0))
79+ fail = Fail.fail
80+#endif
81+
82+instance Fail.MonadFail Ok where
7783 fail str = Errors [SomeException (ErrorCall str)]
7884
7985-- | a way to reify a list of exceptions into a single exception
src/Database/PostgreSQL/Simple/Range.hs+14−10
@@ -19,6 +19,7 @@ module Database.PostgreSQL.Simple.Range
1919 , empty
2020 , isEmpty, isEmptyBy
2121 , contains, containsBy
22+ , fromFieldRange
2223 ) where
2324
2425import Control.Applicative hiding (empty)
@@ -37,7 +38,7 @@ import Data.Monoid (mempty)
3738import Data.Scientific (Scientific)
3839import qualified Data.Text.Lazy.Builder as LT
3940import qualified Data.Text.Lazy.Encoding as LT
40−import Data.Time (Day, LocalTime,
41+import Data.Time.Compat (Day, LocalTime,
4142 NominalDiffTime,
4243 TimeOfDay, UTCTime,
4344 ZonedTime,
@@ -109,19 +110,19 @@ containsBy cmp rng x =
109110 PGRange _lb NegInfinity -> False
110111 PGRange lb ub -> checkLB lb x && checkUB ub x
111112 where
112− checkLB lb x =
113+ checkLB lb y =
113114 case lb of
114115 NegInfinity -> True
115116 PosInfinity -> False
116− Inclusive a -> cmp a x /= GT
117− Exclusive a -> cmp a x == LT
117+ Inclusive a -> cmp a y /= GT
118+ Exclusive a -> cmp a y == LT
118119
119− checkUB ub x =
120+ checkUB ub y =
120121 case ub of
121122 NegInfinity -> False
122123 PosInfinity -> True
123− Inclusive z -> cmp x z /= GT
124− Exclusive z -> cmp x z == LT
124+ Inclusive z -> cmp y z /= GT
125+ Exclusive z -> cmp y z == LT
125126
126127lowerBound :: Parser (a -> RangeBound a)
127128lowerBound = (A.char '(' *> pure Exclusive) <|> (A.char '[' *> pure Inclusive)
@@ -189,7 +190,10 @@ rangeToBuilderBy cmp f x =
189190
190191
191192instance (FromField a, Typeable a) => FromField (PGRange a) where
192− fromField f mdat = do
193+ fromField = fromFieldRange fromField
194+
195+fromFieldRange :: Typeable a => FieldParser a -> FieldParser (PGRange a)
196+fromFieldRange fromField' f mdat = do
193197 info <- typeInfo f
194198 case info of
195199 Range{} ->
@@ -199,8 +203,8 @@ instance (FromField a, Typeable a) => FromField (PGRange a) where
199203 Just "empty" -> pure $ empty
200204 Just bs ->
201205 let parseIt NegInfinity = pure NegInfinity
202− parseIt (Inclusive v) = Inclusive <$> fromField f' (Just v)
203− parseIt (Exclusive v) = Exclusive <$> fromField f' (Just v)
206+ parseIt (Inclusive v) = Inclusive <$> fromField' f' (Just v)
207+ parseIt (Exclusive v) = Exclusive <$> fromField' f' (Just v)
204208 parseIt PosInfinity = pure PosInfinity
205209 in case parseOnly pgrange bs of
206210 Left e -> returnError ConversionFailed f e
src/Database/PostgreSQL/Simple/SqlQQ.hs+10−9
@@ -1,4 +1,9 @@
1+{-# LANGUAGE CPP #-}
2+#if __GLASGOW_HASKELL__ >= 800
3+{-# LANGUAGE TemplateHaskellQuotes #-}
4+#else
15{-# LANGUAGE TemplateHaskell #-}
6+#endif
27------------------------------------------------------------------------------
38-- |
49-- Module: Database.PostgreSQL.Simple.SqlQQ
@@ -30,7 +35,7 @@ import Data.String
3035-- > (beginTime,endTime,string)
3136--
3237-- This quasiquoter returns a literal string expression of type 'Query',
33−-- and attempts to mimimize whitespace; otherwise the above query would
38+-- and attempts to minimize whitespace; otherwise the above query would
3439-- consist of approximately half whitespace when sent to the database
3540-- backend. It also recognizes and strips out standard sql comments "--".
3641--
@@ -52,13 +57,10 @@ import Data.String
5257
5358sql :: QuasiQuoter
5459sql = QuasiQuoter
55− { quotePat = error "Database.PostgreSQL.Simple.SqlQQ.sql:\
56− \ quasiquoter used in pattern context"
57− , quoteType = error "Database.PostgreSQL.Simple.SqlQQ.sql:\
58− \ quasiquoter used in type context"
60+ { quotePat = error "Database.PostgreSQL.Simple.SqlQQ.sql: quasiquoter used in pattern context"
61+ , quoteType = error "Database.PostgreSQL.Simple.SqlQQ.sql: quasiquoter used in type context"
5962 , quoteExp = sqlExp
60− , quoteDec = error "Database.PostgreSQL.Simple.SqlQQ.sql:\
61− \ quasiquoter used in declaration context"
63+ , quoteDec = error "Database.PostgreSQL.Simple.SqlQQ.sql: quasiquoter used in declaration context"
6264 }
6365
6466sqlExp :: String -> Q Exp
@@ -85,5 +87,4 @@ minimizeSpace = drop 1 . reduceSpace
8587 instring ('\'':'\'':xs) = '\'':'\'': instring xs
8688 instring ('\'':xs) = '\'': insql xs
8789 instring (x:xs) = x : instring xs
88− instring [] = error "Database.PostgreSQL.Simple.SqlQQ.sql:\
89− \ string literal not terminated"
90+ instring [] = error "Database.PostgreSQL.Simple.SqlQQ.sql: string literal not terminated"
src/Database/PostgreSQL/Simple/Time.hs+215−50
@@ -1,53 +1,216 @@
1−------------------------------------------------------------------------------
2−-- |
3−-- Module: Database.PostgreSQL.Simple.Time
4−-- Copyright: (c) 2012 Leon P Smith
5−-- License: BSD3
6−-- Maintainer: Leon P Smith <leon@melding-monads.com>
7−-- Stability: experimental
8−--
9−-- Time types that supports positive and negative infinity. Also includes
10−-- new time parsers and printers with better performance than GHC's time
11−-- package.
12−--
13−-- The parsers only understand the specific variant of ISO 8601 that
14−-- PostgreSQL emits, and the printers attempt to duplicate this syntax.
15−-- Thus the @datestyle@ parameter for the connection must be set to @ISO@.
16−--
17−-- These parsers and printers likely have problems and shortcomings. Some
18−-- that I know of:
19−--
20−-- 1 @TimestampTZ@s before a timezone-dependent point in time cannot be
21−-- parsed, because the parsers can only handle timezone offsets of a
22−-- integer number of minutes. However, PostgreSQL will include seconds
23−-- in the offset, depending on the historical time standards for the city
24−-- identifying the time zone.
25−--
26−-- This boundary point often marks an event of some interest. In the US
27−-- for example, @timestamptz@s before @1883-Nov-18 12:00:00@ local time
28−-- cannot be parsed. This is the moment Standard Railway Time went live.
29−-- Concretely, PostgreSQL will emit @1883-11-18 12:03:57-04:56:02@
30−-- instead of @1883-11-18 11:59:59-05@ when the @timezone@ parameter
31−-- for the connection is set to @America/New_York@.
32−--
33−-- 2. Dates and times surrounding @1582-Feb-24@, the date the Gregorian
34−-- Calendar was introduced, should be investigated for conversion errors.
35−--
36−-- 3. Points in time Before Christ are not also not supported. For example,
37−-- PostgreSQL will emit @0045-01-01 BC@ for a value of a @date@ type.
38−-- This is the year that the Julian Calendar was adopted.
39−--
40−-- However, it should be noted that the old parsers also had issues 1 and 3.
41−-- Also, the new parsers now correctly handle time zones that include minutes
42−-- in their offset. Most notably, this includes all of India and parts of
43−-- Canada and Australia.
44−--
45−-- PostgreSQL uses the zoneinfo database for its time zone information.
46−-- You can read more about PostgreSQL's date and time types at
47−-- <http://www.postgresql.org/docs/9.1/static/datatype-datetime.html>,
48−-- and zoneinfo at <http://en.wikipedia.org/wiki/Tz_database>.
49−--
50−------------------------------------------------------------------------------
1+{- |
2+Module: Database.PostgreSQL.Simple.Time
3+Copyright: (c) 2012-2015 Leon P Smith
4+License: BSD3
5+Maintainer: Leon P Smith <leon@melding-monads.com>
6+Stability: experimental
7+
8+This module provides time types that supports positive and negative
9+infinity, as well as some functions for converting to and from strings.
10+
11+Also, this module also contains commentary regarding postgresql's timestamp
12+types, civil timekeeping in general, and how it relates to
13+postgresql-simple. You can read more about PostgreSQL's date and time types
14+at <https://www.postgresql.org/docs/9.5/static/datatype-datetime.html>,
15+and the IANA time zone database at <https://en.wikipedia.org/wiki/Tz_database>.
16+
17+Stack Overflow also has some excellent commentary on time, if it is a
18+wiki page or a highly upvoted question and answer. If the answer regarding
19+time has not received about a hundred upvotes at least, then the answer is
20+almost invariably completely and painfully wrong, even if it's the chosen
21+answer or the most highly upvoted answer to a question.
22+
23+PostgreSQL's @timestamp with time zone@ (hereafter, @timestamptz@) can be
24+converted to Haskell's 'Data.Time.UTCTime' and 'Data.Time.ZonedTime' types,
25+because values of these types represent a self-contained, unambiguous point
26+in time. PostgreSQL's @timestamp without time zone@ (hereafter, @timestamp@)
27+can be converted to Haskell's 'Data.Time.LocalTime', because values of these
28+types are ambiguous by themselves, and require context to disambiguate.
29+
30+While this behavior may be superficially counterintuitive because the
31+names might suggest otherwise, this behavior is correct. In fact,
32+the \"timezone\" language in both the postgresql and haskell types would
33+be better read as \"offset (from UTC)\", thus we have postgresql's
34+\"timestamp with offset\" corresponding to Haskell's \"time with the
35+offset \'zero\'\" and Haskell's \"time with an offset (that might be
36+nonzero)\". Similarly, postgresql's \"timestamp without an offset\"
37+corresponds to Haskell's \"local time (without an offset)\".
38+
39+It's important to distinguish between an offset, a standard time, and
40+a time zone. An offset is simply a difference of a local time from UTC,
41+such as @+00@, @-05@, or @+05:30@. A standard time specifies an offset
42+(which may vary throughout the year, due to daylight savings) that a
43+region follows, such as Universal Coordinated Time (UTC), Eastern Standard
44+Time\/Eastern Daylight Time (EST\/EDT), or India Standard Time (IST).
45+And a time zone, much like a standard time, is a function from
46+timestamps to offsets.
47+
48+A time zone is different from a standard time because different regions
49+inside a standard time can be governed by different civil authorities with
50+different laws and thus have different histories of civil time. An IANA
51+time zone is any region of the world that has had the same history of
52+civil time since @1970-01-01 00:00+00@.
53+
54+For example, as of today, both @America\/New_York@ and
55+@America\/Indiana\/Indianapolis@ are on the EST\/EDT time standard, but
56+Indiana used to be on Central Standard Time until 1942, and did not observe
57+daylight savings time (EST only) until 2006. Thus, the choice between
58+these two time zones still matters if you are dealing with timestamps
59+prior to 2006, and could become relevant again if (most of) Indiana
60+moves back to Central Time. (Of course, if the Central to Eastern switch
61+was the only difference, then these two time zones would be the same in
62+IANA's eyes, due to their cutoff date of 1970-01-01.)
63+
64+Getting back to practicalities, PostgreSQL's @timestamptz@ type does not
65+actually store an offset; rather, it uses the offset provided to calculate
66+UTC, and stores the timestamp as UTC. If an offset is not provided, the
67+given timestamp is assumed to be a local time for whatever the @timezone@
68+variable is set to, and the IANA TZ database is consulted to calculate an
69+offset from UTC for the time in question.
70+
71+Note that while most (local timestamp, time zone) pairs correspond to exactly
72+one UTC timestamp, some correspond to two UTC timestamps, while others
73+correspond to none at all. The ambiguous case occurs when the civil time
74+is rolled back, making a calendar day longer than 24 hours. In this case,
75+PostgreSQL silently chooses the second, later possibility. The inconsistent
76+case occurs when the civil time is moved forward, making a calendar day less
77+than 24 hours. In this case, PostgreSQL silently assumes the local time
78+was read off a clock that had not been moved forward at the prescribed time,
79+and moves the clock forward for you. Thus, converting from local time
80+to UTC need not be monotonic, if these inconsistent cases are allowed.
81+
82+When retrieving a @timestamptz@, the backend looks at the @time zone@
83+connection variable and then consults the IANA TZ database to calculate
84+an offset for the timestamp in the given time zone.
85+
86+Note that while some of the information contained in the IANA TZ database
87+is a bit of a standardized fiction, the conversion from UTC time to a
88+(local time, offset) pair in a particular time zone is always unambiguous,
89+and the result can always be unambiguously converted back to UTC. Thus,
90+postgresql-simple can interpret such a result as a 'Data.Time.ZonedTime',
91+or use the offset to convert back to 'Data.Time.UTCTime'.
92+
93+By contrast, the @timestamp@ type ignores any offsets provided to it,
94+and never sends back an offset. Thus, postgresql-simple equates this
95+with 'Data.Time.LocalTime', which has no concept of an offset. One can
96+convert between @timestamptz@ and @timestamp@ using the @AT TIME ZONE@
97+operator, whose semantics also demonstrates that @timestamptz@ is
98+'Data.Time.UTCTime' whereas @timestamp@ is 'Data.Time.LocalTime'.
99+
100+PostgreSQL's @timezone@ is a per-connection variable that by default is
101+initialized to @\'localtime\'@, which normally corresponds to the server's
102+time zone. However, this default can be modified on the server side for an
103+entire cluster, or on a per-user or per-database basis. Moreover, a client
104+can modify their instance of the variable at any time, and can apply that
105+change to the remaining duration of the connection, the current transaction,
106+or the execution context of a server-side function. In addition, upon
107+connection initialization, the libpq client checks for the existence of
108+the @PGTZ@ environment variable, and if it exists, modifies @timezone@
109+accordingly.
110+
111+With a few caveats, postgresql-simple is designed so that you can both send
112+and receive timestamps with the server and get a correct result, no matter
113+what the @timezone@ setting is. But it is important to understand the caveats:
114+
115+1. The correctness of server-side computations can depend on the @timezone@
116+ setting. Examples include adding an @interval@ to a @timestamptz@, or
117+ type casting between @timestamp@ and @timestamptz@, or applying
118+ the @DATE@ function to a @timestamptz@.
119+
120+2. The (localtime, offset) pair contained in a 'Data.Time.ZonedTime' result
121+ will depend on the @timezone@ setting, although the result will always
122+ represent the same instant in time regardless of the time zone.
123+
124+3. Sending a 'Data.Time.LocalTime' and interpreting it as a @timestamptz@
125+ can be useful, as it will be converted to UTC via the tz database,
126+ but correctness will depend on the @timezone@ setting. You may prefer
127+ to use an explicit @AT TIME ZONE@ conversion instead, which would avoid
128+ this contextual dependence.
129+
130+Furthermore, although these following points don't involve the @timezone@
131+setting, they are related to the last point above:
132+
133+1. Sending a 'Data.Time.UTCTime' and interpreting it as a @timestamp@ can
134+ be useful. In practice, the most common context used to disambiguate
135+ @timestamp@ is that it represents UTC, and this coding technique will
136+ work as expected in this situation.
137+
138+2. Sending a 'Data.Time.ZonedTime' and interpreting it as a @timestamp@ is
139+ almost always the wrong thing to do, as the offset will be ignored and
140+ discarded. This is likely to lead to inconsistencies in the database,
141+ and may lead to partial data loss.
142+
143+When dealing with local timestamps that refer to the future, it is often
144+useful to store it as a local time in a @timestamp@ column and store the
145+time zone in a second column. One reason to do this is so that you can
146+convert to UTC on the fly as needed, and be protected against future changes
147+to the TZ database due to changes in local time standards. In any case,
148+'Data.Time.ZonedTime' is not suitable for this application, because despite
149+its name, it represents an offset and not a time zone. Time zones can change;
150+offsets do not. In reality, we can't convert a local timestamp that occurs
151+sufficiently far in the future to UTC, because we don't know how to do it yet.
152+
153+There are a few limitations and caveats that one might need to be aware
154+of with the current implementation when dealing with older timestamps:
155+
156+For sufficiently old timestamps in almost all time zones, the IANA TZ
157+database specifies offsets from UTC that is not an integral number of
158+minutes. This corresponds to local mean time; that is, astronomical
159+time in the city that defines the time zone. Different time zones moved
160+away from local mean time to a standard time at different points in
161+history, so \"sufficiently old\" depends on the time zone in question.
162+
163+Thus, when retrieving a @timestamptz@ postgresql will in some cases
164+provide seconds in the offset. For example:
165+
166+@
167+$ psql
168+psql (9.4.5)
169+Type \"help\" for help.
170+
171+lpsmith=> SET timezone TO \'America/New_York\';
172+SET
173+lpsmith=> VALUES (\'1883-11-18 16:59:59+00\'::timestamptz),
174+ (\'1883-11-18 17:00:00+00\'::timestamptz);
175+ column1
176+------------------------------
177+ 1883-11-18 12:03:57-04:56:02
178+ 1883-11-18 12:00:00-05
179+(2 rows)
180+@
181+
182+Both of these timestamps can be parsed as a 'Data.Time.UTCTime' type,
183+however 'Data.Time.ZonedTime' will fail on the former timestamp.
184+Because 'Data.Time.ZonedTime' assumes that offsets are an integer number
185+of minutes, there isn't an particularly good solution here.
186+
187+PostgreSQL, like most software, uses the proleptic Gregorian calendar
188+for its date calculations, extending the Gregorian calendar backwards
189+in time before its introduction and pretending that the Julian calendar
190+does not exist. For most purposes, the adoption of the Gregorian calendar
191+ranges from @1582-10-15@ to @1923-03-01@, depending on location and
192+sometimes even political allegiances within a single location.
193+
194+Timestamps BCE are not supported. For example, PostgreSQL
195+will emit \"@0045-01-01 BC@\" for the first proleptic Gregorian day of
196+the year the Roman Empire adopted the Julian Calendar, but
197+postgresql-simple does not (yet?) have the ability to either parse or
198+generate this syntax. Unfortunately this syntax isn't convenient to
199+print or especially parse.
200+
201+Also, postgresql itself cannot parse or print dates before @4714-11-24 BC@,
202+which is the Julian date on the proleptic Gregorian Calendar. Although
203+postgresql's timestamp types are perfectly capable of representing timestamps
204+nearly 300,000 years in the past, using this would require postgresql-simple
205+and other client programs to support binary parameters and results.
206+
207+Dealing with years BCE is also complicated slightly by the fact that
208+Haskell's time library has a year \"0000\", which is a convention often
209+used by astronomers, while postgresql adopts the more historically
210+accurate convention that there is no year zero, but rather \"1 BCE\"
211+was immediately followed by \"1 CE\".
212+
213+-}
51214
52215module Database.PostgreSQL.Simple.Time
53216 ( Unbounded(..)
@@ -64,6 +227,7 @@ module Database.PostgreSQL.Simple.Time
64227 , parseUTCTimestamp
65228 , parseZonedTimestamp
66229 , parseLocalTimestamp
230+ , parseCalendarDiffTime
67231 , dayToBuilder
68232 , utcTimeToBuilder
69233 , zonedTimeToBuilder
@@ -76,6 +240,7 @@ module Database.PostgreSQL.Simple.Time
76240 , localTimestampToBuilder
77241 , unboundedToBuilder
78242 , nominalDiffTimeToBuilder
243+ , calendarDiffTimeToBuilder
79244 ) where
80245
81246import Database.PostgreSQL.Simple.Time.Implementation
src/Database/PostgreSQL/Simple/Time/Implementation.hs+11−1
@@ -18,7 +18,8 @@ import Data.ByteString.Builder.Prim(primBounded)
1818import Control.Arrow((***))
1919import Control.Applicative
2020import qualified Data.ByteString as B
21−import Data.Time hiding (getTimeZone, getZonedTime)
21+import Data.Time.Compat (LocalTime, UTCTime, ZonedTime, Day, TimeOfDay, TimeZone, NominalDiffTime, utc)
22+import Data.Time.LocalTime.Compat (CalendarDiffTime)
2223import Data.Typeable
2324import Data.Maybe (fromMaybe)
2425import qualified Data.Attoparsec.ByteString.Char8 as A
@@ -77,6 +78,9 @@ parseLocalTimestamp = A.parseOnly (getLocalTimestamp <* A.endOfInput)
7778parseDate :: B.ByteString -> Either String Date
7879parseDate = A.parseOnly (getDate <* A.endOfInput)
7980
81+parseCalendarDiffTime :: B.ByteString -> Either String CalendarDiffTime
82+parseCalendarDiffTime = A.parseOnly (getCalendarDiffTime <* A.endOfInput)
83+
8084getUnbounded :: A.Parser a -> A.Parser (Unbounded a)
8185getUnbounded getFinite
8286 = (pure NegInfinity <* A.string "-infinity")
@@ -125,6 +129,9 @@ getUTCTime = TP.utcTime
125129getUTCTimestamp :: A.Parser UTCTimestamp
126130getUTCTimestamp = getUnbounded getUTCTime
127131
132+getCalendarDiffTime :: A.Parser CalendarDiffTime
133+getCalendarDiffTime = TP.calendarDiffTime
134+
128135dayToBuilder :: Day -> Builder
129136dayToBuilder = primBounded TPP.day
130137
@@ -164,3 +171,6 @@ dateToBuilder = unboundedToBuilder dayToBuilder
164171
165172nominalDiffTimeToBuilder :: NominalDiffTime -> Builder
166173nominalDiffTimeToBuilder = TPP.nominalDiffTime
174+
175+calendarDiffTimeToBuilder :: CalendarDiffTime -> Builder
176+calendarDiffTimeToBuilder = TPP.calendarDiffTime
src/Database/PostgreSQL/Simple/Time/Internal/Parser.hs+18−6
@@ -21,20 +21,24 @@ module Database.PostgreSQL.Simple.Time.Internal.Parser
2121 , localToUTCTimeOfDayHMS
2222 , utcTime
2323 , zonedTime
24+ , calendarDiffTime
2425 ) where
2526
2627import Control.Applicative ((<$>), (<*>), (<*), (*>))
2728import Database.PostgreSQL.Simple.Compat (toPico)
2829import Data.Attoparsec.ByteString.Char8 as A
2930import Data.Bits ((.&.))
31+import Data.ByteString (ByteString)
3032import Data.Char (ord)
3133import Data.Fixed (Pico)
3234import Data.Int (Int64)
3335import Data.Maybe (fromMaybe)
34−import Data.Time.Calendar (Day, fromGregorianValid, addDays)
35−import Data.Time.Clock (UTCTime(..))
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)
3640import qualified Data.ByteString.Char8 as B8
37−import qualified Data.Time.LocalTime as Local
41+import qualified Data.Time.LocalTime.Compat as Local
3842
3943-- | Parse a date of the form @YYYY-MM-DD@.
4044day :: Parser Day
@@ -52,12 +56,15 @@ twoDigits = do
5256 let c2d c = ord c .&. 15
5357 return $! c2d a * 10 + c2d b
5458
55−-- | Parse a time of the form @HH:MM:SS[.SSS]@.
59+-- | Parse a time of the form @HH:MM[:SS[.SSS]]@.
5660timeOfDay :: Parser Local.TimeOfDay
5761timeOfDay = do
5862 h <- twoDigits <* char ':'
59− m <- twoDigits <* char ':'
60− s <- seconds
63+ m <- twoDigits
64+ mc <- peekChar
65+ s <- case mc of
66+ Just ':' -> anyChar *> seconds
67+ _ -> return 0
6168 if h < 24 && m < 60 && s <= 60
6269 then return (Local.TimeOfDay h m s)
6370 else fail "invalid time"
@@ -190,3 +197,8 @@ zonedTime = Local.ZonedTime <$> localTime <*> (fromMaybe utc <$> timeZone)
190197
191198utc :: Local.TimeZone
192199utc = 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.hs+19−7
@@ -17,19 +17,23 @@ module Database.PostgreSQL.Simple.Time.Internal.Printer
1717 , localTime
1818 , zonedTime
1919 , nominalDiffTime
20+ , calendarDiffTime
2021 ) where
2122
2223import Control.Arrow ((>>>))
23−import Data.ByteString.Builder (Builder, integerDec)
24+import Data.ByteString.Builder (Builder, byteString, integerDec)
2425import Data.ByteString.Builder.Prim
2526 ( liftFixedToBounded, (>$<), (>*<)
2627 , BoundedPrim, primBounded, condB, emptyB, FixedPrim, char8, int32Dec)
2728import Data.Char ( chr )
2829import Data.Int ( Int32, Int64 )
29−import Data.Time
30+import Data.String (fromString)
31+import Data.Time.Compat
3032 ( UTCTime(..), ZonedTime(..), LocalTime(..), NominalDiffTime
3133 , Day, toGregorian, TimeOfDay(..), timeToTimeOfDay
3234 , TimeZone, timeZoneMinutes )
35+import Data.Time.Format.ISO8601.Compat (iso8601Show)
36+import Data.Time.LocalTime.Compat (CalendarDiffTime)
3337import Database.PostgreSQL.Simple.Compat ((<>), fromPico)
3438import Unsafe.Coerce (unsafeCoerce)
3539
@@ -71,7 +75,7 @@ frac = condB (== 0) emptyB ((,) '.' >$< (liftB char8 >*< trunc12))
7175
7276
7377year :: BoundedPrim Int32
74−year = condB (> 10000) int32Dec (checkBCE >$< liftB digits4)
78+year = condB (>= 10000) int32Dec (checkBCE >$< liftB digits4)
7579 where
7680 checkBCE :: Int32 -> Int
7781 checkBCE y
@@ -96,13 +100,13 @@ timeOfDay = f >$< (hh_mm_ >*< ss)
96100 (liftB (fromIntegral >$< digits2) >*< frac)
97101
98102timeZone :: BoundedPrim TimeZone
99−timeZone = ((`quotRem` 60) . timeZoneMinutes) >$< (liftB tzh >*< tzm)
103+timeZone = timeZoneMinutes >$< tz
100104 where
101− f h = if h >= 0 then ('+', h) else (,) '-' $! (-h)
105+ tz = condB (>= 0) ((,) '+' >$< tzh) ((,) '-' . negate >$< tzh)
102106
103− tzh = f >$< (char8 >*< digits2)
107+ tzh = liftB char8 >*< ((`quotRem` 60) >$< (liftB digits2 >*< tzm))
104108
105− tzm = condB (==0) emptyB ((,) ':' . abs >$< liftB (char8 >*< digits2))
109+ tzm = condB (==0) emptyB ((,) ':' >$< liftB (char8 >*< digits2))
106110
107111utcTime :: BoundedPrim UTCTime
108112utcTime = f >$< (day >*< liftB char8 >*< timeOfDay >*< liftB char8)
@@ -121,3 +125,11 @@ nominalDiffTime :: NominalDiffTime -> Builder
121125nominalDiffTime xy = integerDec x <> primBounded frac (abs (fromIntegral y))
122126 where
123127 (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+42−17
@@ -1,5 +1,6 @@
11{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-}
22{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
3+{-# LANGUAGE PolyKinds #-}
34
45------------------------------------------------------------------------------
56-- |
@@ -22,6 +23,7 @@ module Database.PostgreSQL.Simple.ToField
2223 , inQuotes
2324 ) where
2425
26+import Control.Applicative (Const(Const))
2527import qualified Data.Aeson as JSON
2628import Data.ByteString (ByteString)
2729import Data.ByteString.Builder
@@ -30,10 +32,12 @@ import Data.ByteString.Builder
3032 , wordDec, word8Dec, word16Dec, word32Dec, word64Dec
3133 , floatDec, doubleDec
3234 )
35+import Data.Functor.Identity (Identity(Identity))
3336import Data.Int (Int8, Int16, Int32, Int64)
3437import Data.List (intersperse)
3538import Data.Monoid (mappend)
36−import Data.Time (Day, TimeOfDay, LocalTime, UTCTime, ZonedTime, NominalDiffTime)
39+import Data.Time.Compat (Day, TimeOfDay, LocalTime, UTCTime, ZonedTime, NominalDiffTime)
40+import Data.Time.LocalTime.Compat (CalendarDiffTime)
3741import Data.Typeable (Typeable)
3842import Data.Word (Word, Word8, Word16, Word32, Word64)
3943import {-# SOURCE #-} Database.PostgreSQL.Simple.ToRow
@@ -42,6 +46,8 @@ import Database.PostgreSQL.Simple.Compat (toByteString)
4246
4347import qualified Data.ByteString as SB
4448import qualified Data.ByteString.Lazy as LB
49+import Data.CaseInsensitive (CI)
50+import qualified Data.CaseInsensitive as CI
4551import qualified Data.Text as ST
4652import qualified Data.Text.Encoding as ST
4753import qualified Data.Text.Lazy as LT
@@ -53,11 +59,7 @@ import qualified Data.Vector as V
5359import qualified Database.PostgreSQL.LibPQ as PQ
5460import Database.PostgreSQL.Simple.Time
5561import Data.Scientific (Scientific)
56−#if MIN_VERSION_scientific(0,3,0)
5762import Data.Text.Lazy.Builder.Scientific (scientificBuilder)
58−#else
59−import Data.Scientific (scientificBuilder)
60−#endif
6163import Foreign.C.Types (CUInt(..))
6264
6365-- | How to render an element when substituting it into a query.
@@ -98,6 +100,14 @@ instance ToField Action where
98100 toField a = a
99101 {-# INLINE toField #-}
100102
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+
101111instance (ToField a) => ToField (Maybe a) where
102112 toField Nothing = renderNull
103113 toField (Just a) = toField a
@@ -230,6 +240,15 @@ instance ToField LT.Text where
230240 toField = toField . LT.toStrict
231241 {-# INLINE toField #-}
232242
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 #-}
233252
234253instance ToField UTCTime where
235254 toField = Plain . inQuotes . utcTimeToBuilder
@@ -271,13 +290,20 @@ instance ToField NominalDiffTime where
271290 toField = Plain . inQuotes . nominalDiffTimeToBuilder
272291 {-# INLINE toField #-}
273292
293+instance ToField CalendarDiffTime where
294+ toField = Plain . inQuotes . calendarDiffTimeToBuilder
295+ {-# INLINE toField #-}
296+
274297instance (ToField a) => ToField (PGArray a) where
275− toField xs = Many $
276− Plain (byteString "ARRAY[") :
277− (intersperse (Plain (char8 ',')) . map toField $ fromPGArray xs) ++
278− [Plain (char8 ']')]
279− -- Because the ARRAY[...] input syntax is being used, it is possible
280− -- that the use of type-specific separator characters is unnecessary.
298+ toField pgArray =
299+ case fromPGArray pgArray of
300+ [] -> Plain (byteString "'{}'")
301+ xs -> Many $
302+ Plain (byteString "ARRAY[") :
303+ (intersperse (Plain (char8 ',')) . map toField $ xs) ++
304+ [Plain (char8 ']')]
305+ -- Because the ARRAY[...] input syntax is being used, it is possible
306+ -- that the use of type-specific separator characters is unnecessary.
281307
282308instance (ToField a) => ToField (Vector a) where
283309 toField = toField . PGArray . V.toList
@@ -288,14 +314,13 @@ instance ToField UUID where
288314instance ToField JSON.Value where
289315 toField = toField . JSON.encode
290316
291−-- | Convert a Haskell value to a JSON 'JSON.Value' using
292−-- 'JSON.toJSON' and convert that to a field using 'toField'.
317+-- | Convert a Haskell value to JSON using 'JSON.toEncoding'.
293318--
294319-- This can be used as the default implementation for the 'toField'
295320-- method for Haskell types that have a JSON representation in
296321-- PostgreSQL.
297322toJSONField :: JSON.ToJSON a => a -> Action
298−toJSONField = toField . JSON.toJSON
323+toJSONField = toField . JSON.encode
299324
300325-- | Surround a string with single-quote characters: \"@'@\"
301326--
@@ -305,7 +330,7 @@ inQuotes b = quote `mappend` b `mappend` quote
305330 where quote = char8 '\''
306331
307332interleaveFoldr :: (a -> [b] -> [b]) -> b -> [b] -> [a] -> [b]
308−interleaveFoldr f b bs as = foldr (\a bs -> b : f a bs) bs as
333+interleaveFoldr f b bs' as = foldr (\a bs -> b : f a bs) bs' as
309334{-# INLINE interleaveFoldr #-}
310335
311336instance ToRow a => ToField (Values a) where
@@ -352,8 +377,8 @@ instance ToRow a => ToField (Values a) where
352377
353378 typedRows :: ToRow a => [a] -> [QualifiedIdentifier] -> [Action] -> [Action]
354379 typedRows [] _ _ = error funcname
355− typedRows (val:vals) types rest =
356− typedRow (toRow val) types (multiRows vals rest)
380+ typedRows (val:vals) typs rest =
381+ typedRow (toRow val) typs (multiRows vals rest)
357382
358383 untypedRows :: ToRow a => [a] -> [Action] -> [Action]
359384 untypedRows [] _ = error funcname
src/Database/PostgreSQL/Simple/ToRow.hs+127
@@ -1,3 +1,4 @@
1+{-# LANGUAGE DefaultSignatures, FlexibleInstances, FlexibleContexts #-}
12------------------------------------------------------------------------------
23-- |
34-- Module: Database.PostgreSQL.Simple.ToRow
@@ -22,14 +23,33 @@ module Database.PostgreSQL.Simple.ToRow
2223
2324import Database.PostgreSQL.Simple.ToField (Action(..), ToField(..))
2425import Database.PostgreSQL.Simple.Types (Only(..), (:.)(..))
26+import GHC.Generics
2527
2628-- | A collection type that can be turned into a list of rendering
2729-- 'Action's.
2830--
2931-- Instances should use the 'toField' method of the 'ToField' class
3032-- 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.
3149class ToRow a where
3250 toRow :: a -> [Action]
51+ default toRow :: (Generic a, GToRow (Rep a)) => a -> [Action]
52+ toRow = gtoRow . from
3353 -- ^ ToField a collection of values.
3454
3555instance ToRow () where
@@ -85,8 +105,115 @@ instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,
85105 [toField a, toField b, toField c, toField d, toField e, toField f,
86106 toField g, toField h, toField i, toField j]
87107
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+
88198instance (ToField a) => ToRow [a] where
89199 toRow = map toField
90200
91201instance (ToRow a, ToRow b) => ToRow (a :. b) where
92202 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+10−1
@@ -1,9 +1,18 @@
1−module Database.PostgreSQL.Simple.ToRow where
1+{-# LANGUAGE DefaultSignatures, FlexibleInstances, FlexibleContexts #-}
2+module Database.PostgreSQL.Simple.ToRow (
3+ ToRow(..)
4+ ) where
25
36import Database.PostgreSQL.Simple.Types
47import {-# SOURCE #-} Database.PostgreSQL.Simple.ToField
8+import GHC.Generics
59
610class ToRow a where
711 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]
817
918instance ToField a => ToRow (Only a)
src/Database/PostgreSQL/Simple/Transaction.hs+35−17
@@ -1,4 +1,14 @@
1−{-# LANGUAGE RecordWildCards #-}
1+{-# LANGUAGE RecordWildCards, ScopedTypeVariables #-}
2+
3+------------------------------------------------------------------------------
4+-- |
5+-- Module: Database.PostgreSQL.Simple.Transaction
6+-- Copyright: (c) 2011-2013 Leon P Smith
7+-- (c) 2013 Joey Adams
8+-- License: BSD3
9+-- Maintainer: Leon P Smith <leon@melding-monads.com>
10+--
11+------------------------------------------------------------------------------
212
313module Database.PostgreSQL.Simple.Transaction
414 (
@@ -7,6 +17,7 @@ module Database.PostgreSQL.Simple.Transaction
717 , withTransactionLevel
818 , withTransactionMode
919 , withTransactionModeRetry
20+ , withTransactionModeRetry'
1021 , withTransactionSerializable
1122 , TransactionMode(..)
1223 , IsolationLevel(..)
@@ -45,7 +56,7 @@ import Database.PostgreSQL.Simple.Compat (mask, (<>))
4556
4657-- | Of the four isolation levels defined by the SQL standard,
4758-- these are the three levels distinguished by PostgreSQL as of version 9.0.
48−-- See <http://www.postgresql.org/docs/9.1/static/transaction-iso.html>
59+-- See <https://www.postgresql.org/docs/9.5/static/transaction-iso.html>
4960-- for more information. Note that prior to PostgreSQL 9.0, 'RepeatableRead'
5061-- was equivalent to 'Serializable'.
5162
@@ -132,41 +143,48 @@ withTransactionMode :: TransactionMode -> Connection -> IO a -> IO a
132143withTransactionMode mode conn act =
133144 mask $ \restore -> do
134145 beginMode mode conn
135− r <- restore act `E.onException` rollback conn
146+ r <- restore act `E.onException` rollback_ conn
136147 commit conn
137148 return r
138149
150+-- | 'withTransactionModeRetry'' but with the exception type pinned to 'SqlError'.
151+withTransactionModeRetry :: TransactionMode -> (SqlError -> Bool) -> Connection -> IO a -> IO a
152+withTransactionModeRetry = withTransactionModeRetry'
153+
139154-- | Like 'withTransactionMode', but also takes a custom callback to
140−-- determine if a transaction should be retried if an 'SqlError' occurs.
141−-- If the callback returns True, then the transaction will be retried.
142−-- If the callback returns False, or an exception other than an 'SqlError'
155+-- determine if a transaction should be retried if an exception occurs.
156+-- If the callback returns 'True', then the transaction will be retried.
157+-- If the callback returns 'False', or an exception other than an @e@
143158-- occurs then the transaction will be rolled back and the exception rethrown.
144159--
145160-- This is used to implement 'withTransactionSerializable'.
146−withTransactionModeRetry :: TransactionMode -> (SqlError -> Bool) -> Connection -> IO a -> IO a
147−withTransactionModeRetry mode shouldRetry conn act =
161+withTransactionModeRetry' :: forall a e. E.Exception e => TransactionMode -> (e -> Bool) -> Connection -> IO a -> IO a
162+withTransactionModeRetry' mode shouldRetry conn act =
148163 mask $ \restore ->
149164 retryLoop $ E.try $ do
150− a <- restore act
165+ a <- restore act `E.onException` rollback_ conn
151166 commit conn
152167 return a
153168 where
154− retryLoop :: IO (Either E.SomeException a) -> IO a
169+ retryLoop :: IO (Either e a) -> IO a
155170 retryLoop act' = do
156171 beginMode mode conn
157172 r <- act'
158173 case r of
159− Left e -> do
160− rollback conn
161− case fmap shouldRetry (E.fromException e) of
162− Just True -> retryLoop act'
163− _ -> E.throwIO e
174+ Left e ->
175+ case shouldRetry e of
176+ True -> retryLoop act'
177+ False -> E.throwIO e
164178 Right a ->
165179 return a
166180
167181-- | Rollback a transaction.
168182rollback :: Connection -> IO ()
169−rollback conn = execute_ conn "ABORT" >> return ()
183+rollback conn = execute_ conn "ROLLBACK" >> return ()
184+
185+-- | Rollback a transaction, ignoring any @IOErrors@
186+rollback_ :: Connection -> IO ()
187+rollback_ conn = rollback conn `E.catch` \(_ :: IOError) -> return ()
170188
171189-- | Commit a transaction.
172190commit :: Connection -> IO ()
@@ -203,7 +221,7 @@ beginMode mode conn = do
203221-- be used inside of a transaction, and provides a sort of
204222-- \"nested transaction\".
205223--
206−-- See <http://www.postgresql.org/docs/current/static/sql-savepoint.html>
224+-- See <https://www.postgresql.org/docs/9.5/static/sql-savepoint.html>
207225withSavepoint :: Connection -> IO a -> IO a
208226withSavepoint conn body =
209227 mask $ \restore -> do
src/Database/PostgreSQL/Simple/TypeInfo.hs+9−9
@@ -50,21 +50,21 @@ import Database.PostgreSQL.Simple.TypeInfo.Static
5050-- in the connections's cache.
5151
5252getTypeInfo :: Connection -> PQ.Oid -> IO TypeInfo
53−getTypeInfo conn@Connection{..} oid =
54− case staticTypeInfo oid of
55− Just name -> return name
56− Nothing -> modifyMVar connectionObjects $ getTypeInfo' conn oid
53+getTypeInfo conn@Connection{..} oid' =
54+ case staticTypeInfo oid' of
55+ Just name' -> return name'
56+ Nothing -> modifyMVar connectionObjects $ getTypeInfo' conn oid'
5757
5858getTypeInfo' :: Connection -> PQ.Oid -> TypeInfoCache
5959 -> IO (TypeInfoCache, TypeInfo)
60−getTypeInfo' conn oid oidmap =
61− case IntMap.lookup (oid2int oid) oidmap of
60+getTypeInfo' conn oid' oidmap =
61+ case IntMap.lookup (oid2int oid') oidmap of
6262 Just typeinfo -> return (oidmap, typeinfo)
6363 Nothing -> do
6464 names <- query conn "SELECT oid, typcategory, typdelim, typname,\
6565 \ typelem, typrelid\
6666 \ FROM pg_type WHERE oid = ?"
67− (Only oid)
67+ (Only oid')
6868 (oidmap', typeInfo) <-
6969 case names of
7070 [] -> return $ throw (fatalError "invalid type oid")
@@ -78,7 +78,7 @@ getTypeInfo' conn oid oidmap =
7878 rngsubtypeOids <- query conn "SELECT rngsubtype\
7979 \ FROM pg_range\
8080 \ WHERE rngtypid = ?"
81− (Only oid)
81+ (Only oid')
8282 case rngsubtypeOids of
8383 [Only rngsubtype_] -> do
8484 (oidmap', rngsubtype) <-
@@ -104,7 +104,7 @@ getTypeInfo' conn oid oidmap =
104104 _ -> fail "typename query returned more than one result"
105105 -- oid is a primary key, so the query should
106106 -- never return more than one result
107− let !oidmap'' = IntMap.insert (oid2int oid) typeInfo oidmap'
107+ let !oidmap'' = IntMap.insert (oid2int oid') typeInfo oidmap'
108108 return $! (oidmap'', typeInfo)
109109
110110getAttInfos :: Connection -> [(B.ByteString, PQ.Oid)] -> TypeInfoCache
src/Database/PostgreSQL/Simple/TypeInfo/Macro.hs+9−3
@@ -1,4 +1,9 @@
1+{-# LANGUAGE CPP #-}
2+#if __GLASGOW_HASKELL__ >= 800
3+{-# LANGUAGE TemplateHaskellQuotes #-}
4+#else
15{-# LANGUAGE TemplateHaskell #-}
6+#endif
27
38------------------------------------------------------------------------------
49-- |
@@ -22,11 +27,12 @@ import Database.PostgreSQL.Simple.TypeInfo.Static
2227import Database.PostgreSQL.Simple.Types (Oid(..))
2328import Language.Haskell.TH
2429
25−
2630-- | Returns an expression that has type @'Oid' -> 'Bool'@, true if the
2731-- oid is equal to any one of the 'typoid's of the given 'TypeInfo's.
2832mkCompats :: [TypeInfo] -> ExpQ
29−mkCompats tys = [| \(Oid x) -> $(caseE [| x |] (map alt tys ++ [catchAll])) |]
33+mkCompats tys = do
34+ x <- newName "x"
35+ lamE [conP 'Oid [varP x]] $ caseE (varE x) (map alt tys ++ [catchAll])
3036 where
3137 alt :: TypeInfo -> MatchQ
3238 alt ty = match (inlineTypoidP ty) (normalB [| True |]) []
@@ -38,7 +44,7 @@ mkCompats tys = [| \(Oid x) -> $(caseE [| x |] (map alt tys ++ [catchAll])) |]
3844-- Returns an expression of type 'Oid'. Useful because GHC tends
3945-- not to fold constants.
4046inlineTypoid :: TypeInfo -> ExpQ
41−inlineTypoid ty = [| Oid $(litE (getTypoid ty)) |]
47+inlineTypoid ty = conE 'Oid `appE` litE (getTypoid ty)
4248
4349inlineTypoidP :: TypeInfo -> PatQ
4450inlineTypoidP ty = litP (getTypoid ty)
src/Database/PostgreSQL/Simple/TypeInfo/Static.hs+684−114
@@ -19,119 +19,233 @@ module Database.PostgreSQL.Simple.TypeInfo.Static
1919 ( TypeInfo(..)
2020 , staticTypeInfo
2121 , bool
22+ , boolOid
2223 , bytea
24+ , byteaOid
2325 , char
26+ , charOid
2427 , name
28+ , nameOid
2529 , int8
30+ , int8Oid
2631 , int2
32+ , int2Oid
2733 , int4
34+ , int4Oid
2835 , regproc
36+ , regprocOid
2937 , text
38+ , textOid
3039 , oid
40+ , oidOid
3141 , tid
42+ , tidOid
3243 , xid
44+ , xidOid
3345 , cid
46+ , cidOid
3447 , xml
48+ , xmlOid
3549 , point
50+ , pointOid
3651 , lseg
52+ , lsegOid
3753 , path
54+ , pathOid
3855 , box
56+ , boxOid
3957 , polygon
58+ , polygonOid
4059 , line
60+ , lineOid
4161 , cidr
62+ , cidrOid
4263 , float4
64+ , float4Oid
4365 , float8
66+ , float8Oid
4467 , unknown
68+ , unknownOid
4569 , circle
70+ , circleOid
4671 , money
72+ , moneyOid
4773 , macaddr
74+ , macaddrOid
4875 , inet
76+ , inetOid
4977 , bpchar
78+ , bpcharOid
5079 , varchar
80+ , varcharOid
5181 , date
82+ , dateOid
5283 , time
84+ , timeOid
5385 , timestamp
86+ , timestampOid
5487 , timestamptz
88+ , timestamptzOid
5589 , interval
90+ , intervalOid
5691 , timetz
92+ , timetzOid
5793 , bit
94+ , bitOid
5895 , varbit
96+ , varbitOid
5997 , numeric
98+ , numericOid
6099 , refcursor
100+ , refcursorOid
61101 , record
102+ , recordOid
62103 , void
104+ , voidOid
63105 , array_record
106+ , array_recordOid
64107 , regprocedure
108+ , regprocedureOid
65109 , regoper
110+ , regoperOid
66111 , regoperator
112+ , regoperatorOid
67113 , regclass
114+ , regclassOid
68115 , regtype
116+ , regtypeOid
69117 , uuid
118+ , uuidOid
70119 , json
120+ , jsonOid
71121 , jsonb
122+ , jsonbOid
72123 , int2vector
124+ , int2vectorOid
73125 , oidvector
126+ , oidvectorOid
74127 , array_xml
128+ , array_xmlOid
75129 , array_json
130+ , array_jsonOid
76131 , array_line
132+ , array_lineOid
77133 , array_cidr
134+ , array_cidrOid
78135 , array_circle
136+ , array_circleOid
79137 , array_money
138+ , array_moneyOid
80139 , array_bool
140+ , array_boolOid
81141 , array_bytea
142+ , array_byteaOid
82143 , array_char
144+ , array_charOid
83145 , array_name
146+ , array_nameOid
84147 , array_int2
148+ , array_int2Oid
85149 , array_int2vector
150+ , array_int2vectorOid
86151 , array_int4
152+ , array_int4Oid
87153 , array_regproc
154+ , array_regprocOid
88155 , array_text
156+ , array_textOid
89157 , array_tid
158+ , array_tidOid
90159 , array_xid
160+ , array_xidOid
91161 , array_cid
162+ , array_cidOid
92163 , array_oidvector
164+ , array_oidvectorOid
93165 , array_bpchar
166+ , array_bpcharOid
94167 , array_varchar
168+ , array_varcharOid
95169 , array_int8
170+ , array_int8Oid
96171 , array_point
172+ , array_pointOid
97173 , array_lseg
174+ , array_lsegOid
98175 , array_path
176+ , array_pathOid
99177 , array_box
178+ , array_boxOid
100179 , array_float4
180+ , array_float4Oid
101181 , array_float8
182+ , array_float8Oid
102183 , array_polygon
184+ , array_polygonOid
103185 , array_oid
186+ , array_oidOid
104187 , array_macaddr
188+ , array_macaddrOid
105189 , array_inet
190+ , array_inetOid
106191 , array_timestamp
192+ , array_timestampOid
107193 , array_date
194+ , array_dateOid
108195 , array_time
196+ , array_timeOid
109197 , array_timestamptz
198+ , array_timestamptzOid
110199 , array_interval
200+ , array_intervalOid
111201 , array_numeric
202+ , array_numericOid
112203 , array_timetz
204+ , array_timetzOid
113205 , array_bit
206+ , array_bitOid
114207 , array_varbit
208+ , array_varbitOid
115209 , array_refcursor
210+ , array_refcursorOid
116211 , array_regprocedure
212+ , array_regprocedureOid
117213 , array_regoper
214+ , array_regoperOid
118215 , array_regoperator
216+ , array_regoperatorOid
119217 , array_regclass
218+ , array_regclassOid
120219 , array_regtype
220+ , array_regtypeOid
121221 , array_uuid
222+ , array_uuidOid
122223 , array_jsonb
224+ , array_jsonbOid
123225 , int4range
226+ , int4rangeOid
124227 , _int4range
228+ , _int4rangeOid
125229 , numrange
230+ , numrangeOid
126231 , _numrange
232+ , _numrangeOid
127233 , tsrange
234+ , tsrangeOid
128235 , _tsrange
236+ , _tsrangeOid
129237 , tstzrange
238+ , tstzrangeOid
130239 , _tstzrange
240+ , _tstzrangeOid
131241 , daterange
242+ , daterangeOid
132243 , _daterange
244+ , _daterangeOid
133245 , int8range
246+ , int8rangeOid
134247 , _int8range
248+ , _int8rangeOid
135249 ) where
136250
137251import Database.PostgreSQL.LibPQ (Oid(..))
@@ -257,976 +371,1432 @@ staticTypeInfo (Oid x) = case x of
257371
258372bool :: TypeInfo
259373bool = Basic {
260− typoid = Oid 16,
374+ typoid = boolOid,
261375 typcategory = 'B',
262376 typdelim = ',',
263377 typname = "bool"
264378 }
265379
380+boolOid :: Oid
381+boolOid = Oid 16
382+{-# INLINE boolOid #-}
383+
266384bytea :: TypeInfo
267385bytea = Basic {
268− typoid = Oid 17,
386+ typoid = byteaOid,
269387 typcategory = 'U',
270388 typdelim = ',',
271389 typname = "bytea"
272390 }
273391
392+byteaOid :: Oid
393+byteaOid = Oid 17
394+{-# INLINE byteaOid #-}
395+
274396char :: TypeInfo
275397char = Basic {
276− typoid = Oid 18,
398+ typoid = charOid,
277399 typcategory = 'S',
278400 typdelim = ',',
279401 typname = "char"
280402 }
281403
404+charOid :: Oid
405+charOid = Oid 18
406+{-# INLINE charOid #-}
407+
282408name :: TypeInfo
283409name = Basic {
284− typoid = Oid 19,
410+ typoid = nameOid,
285411 typcategory = 'S',
286412 typdelim = ',',
287413 typname = "name"
288414 }
289415
416+nameOid :: Oid
417+nameOid = Oid 19
418+{-# INLINE nameOid #-}
419+
290420int8 :: TypeInfo
291421int8 = Basic {
292− typoid = Oid 20,
422+ typoid = int8Oid,
293423 typcategory = 'N',
294424 typdelim = ',',
295425 typname = "int8"
296426 }
297427
428+int8Oid :: Oid
429+int8Oid = Oid 20
430+{-# INLINE int8Oid #-}
431+
298432int2 :: TypeInfo
299433int2 = Basic {
300− typoid = Oid 21,
434+ typoid = int2Oid,
301435 typcategory = 'N',
302436 typdelim = ',',
303437 typname = "int2"
304438 }
305439
440+int2Oid :: Oid
441+int2Oid = Oid 21
442+{-# INLINE int2Oid #-}
443+
306444int4 :: TypeInfo
307445int4 = Basic {
308− typoid = Oid 23,
446+ typoid = int4Oid,
309447 typcategory = 'N',
310448 typdelim = ',',
311449 typname = "int4"
312450 }
313451
452+int4Oid :: Oid
453+int4Oid = Oid 23
454+{-# INLINE int4Oid #-}
455+
314456regproc :: TypeInfo
315457regproc = Basic {
316− typoid = Oid 24,
458+ typoid = regprocOid,
317459 typcategory = 'N',
318460 typdelim = ',',
319461 typname = "regproc"
320462 }
321463
464+regprocOid :: Oid
465+regprocOid = Oid 24
466+{-# INLINE regprocOid #-}
467+
322468text :: TypeInfo
323469text = Basic {
324− typoid = Oid 25,
470+ typoid = textOid,
325471 typcategory = 'S',
326472 typdelim = ',',
327473 typname = "text"
328474 }
329475
476+textOid :: Oid
477+textOid = Oid 25
478+{-# INLINE textOid #-}
479+
330480oid :: TypeInfo
331481oid = Basic {
332− typoid = Oid 26,
482+ typoid = oidOid,
333483 typcategory = 'N',
334484 typdelim = ',',
335485 typname = "oid"
336486 }
337487
488+oidOid :: Oid
489+oidOid = Oid 26
490+{-# INLINE oidOid #-}
491+
338492tid :: TypeInfo
339493tid = Basic {
340− typoid = Oid 27,
494+ typoid = tidOid,
341495 typcategory = 'U',
342496 typdelim = ',',
343497 typname = "tid"
344498 }
345499
500+tidOid :: Oid
501+tidOid = Oid 27
502+{-# INLINE tidOid #-}
503+
346504xid :: TypeInfo
347505xid = Basic {
348− typoid = Oid 28,
506+ typoid = xidOid,
349507 typcategory = 'U',
350508 typdelim = ',',
351509 typname = "xid"
352510 }
353511
512+xidOid :: Oid
513+xidOid = Oid 28
514+{-# INLINE xidOid #-}
515+
354516cid :: TypeInfo
355517cid = Basic {
356− typoid = Oid 29,
518+ typoid = cidOid,
357519 typcategory = 'U',
358520 typdelim = ',',
359521 typname = "cid"
360522 }
361523
524+cidOid :: Oid
525+cidOid = Oid 29
526+{-# INLINE cidOid #-}
527+
362528xml :: TypeInfo
363529xml = Basic {
364− typoid = Oid 142,
530+ typoid = xmlOid,
365531 typcategory = 'U',
366532 typdelim = ',',
367533 typname = "xml"
368534 }
369535
536+xmlOid :: Oid
537+xmlOid = Oid 142
538+{-# INLINE xmlOid #-}
539+
370540point :: TypeInfo
371541point = Basic {
372− typoid = Oid 600,
542+ typoid = pointOid,
373543 typcategory = 'G',
374544 typdelim = ',',
375545 typname = "point"
376546 }
377547
548+pointOid :: Oid
549+pointOid = Oid 600
550+{-# INLINE pointOid #-}
551+
378552lseg :: TypeInfo
379553lseg = Basic {
380− typoid = Oid 601,
554+ typoid = lsegOid,
381555 typcategory = 'G',
382556 typdelim = ',',
383557 typname = "lseg"
384558 }
385559
560+lsegOid :: Oid
561+lsegOid = Oid 601
562+{-# INLINE lsegOid #-}
563+
386564path :: TypeInfo
387565path = Basic {
388− typoid = Oid 602,
566+ typoid = pathOid,
389567 typcategory = 'G',
390568 typdelim = ',',
391569 typname = "path"
392570 }
393571
572+pathOid :: Oid
573+pathOid = Oid 602
574+{-# INLINE pathOid #-}
575+
394576box :: TypeInfo
395577box = Basic {
396− typoid = Oid 603,
578+ typoid = boxOid,
397579 typcategory = 'G',
398580 typdelim = ';',
399581 typname = "box"
400582 }
401583
584+boxOid :: Oid
585+boxOid = Oid 603
586+{-# INLINE boxOid #-}
587+
402588polygon :: TypeInfo
403589polygon = Basic {
404− typoid = Oid 604,
590+ typoid = polygonOid,
405591 typcategory = 'G',
406592 typdelim = ',',
407593 typname = "polygon"
408594 }
409595
596+polygonOid :: Oid
597+polygonOid = Oid 604
598+{-# INLINE polygonOid #-}
599+
410600line :: TypeInfo
411601line = Basic {
412− typoid = Oid 628,
602+ typoid = lineOid,
413603 typcategory = 'G',
414604 typdelim = ',',
415605 typname = "line"
416606 }
417607
608+lineOid :: Oid
609+lineOid = Oid 628
610+{-# INLINE lineOid #-}
611+
418612cidr :: TypeInfo
419613cidr = Basic {
420− typoid = Oid 650,
614+ typoid = cidrOid,
421615 typcategory = 'I',
422616 typdelim = ',',
423617 typname = "cidr"
424618 }
425619
620+cidrOid :: Oid
621+cidrOid = Oid 650
622+{-# INLINE cidrOid #-}
623+
426624float4 :: TypeInfo
427625float4 = Basic {
428− typoid = Oid 700,
626+ typoid = float4Oid,
429627 typcategory = 'N',
430628 typdelim = ',',
431629 typname = "float4"
432630 }
433631
632+float4Oid :: Oid
633+float4Oid = Oid 700
634+{-# INLINE float4Oid #-}
635+
434636float8 :: TypeInfo
435637float8 = Basic {
436− typoid = Oid 701,
638+ typoid = float8Oid,
437639 typcategory = 'N',
438640 typdelim = ',',
439641 typname = "float8"
440642 }
441643
644+float8Oid :: Oid
645+float8Oid = Oid 701
646+{-# INLINE float8Oid #-}
647+
442648unknown :: TypeInfo
443649unknown = Basic {
444− typoid = Oid 705,
650+ typoid = unknownOid,
445651 typcategory = 'X',
446652 typdelim = ',',
447653 typname = "unknown"
448654 }
449655
656+unknownOid :: Oid
657+unknownOid = Oid 705
658+{-# INLINE unknownOid #-}
659+
450660circle :: TypeInfo
451661circle = Basic {
452− typoid = Oid 718,
662+ typoid = circleOid,
453663 typcategory = 'G',
454664 typdelim = ',',
455665 typname = "circle"
456666 }
457667
668+circleOid :: Oid
669+circleOid = Oid 718
670+{-# INLINE circleOid #-}
671+
458672money :: TypeInfo
459673money = Basic {
460− typoid = Oid 790,
674+ typoid = moneyOid,
461675 typcategory = 'N',
462676 typdelim = ',',
463677 typname = "money"
464678 }
465679
680+moneyOid :: Oid
681+moneyOid = Oid 790
682+{-# INLINE moneyOid #-}
683+
466684macaddr :: TypeInfo
467685macaddr = Basic {
468− typoid = Oid 829,
686+ typoid = macaddrOid,
469687 typcategory = 'U',
470688 typdelim = ',',
471689 typname = "macaddr"
472690 }
473691
692+macaddrOid :: Oid
693+macaddrOid = Oid 829
694+{-# INLINE macaddrOid #-}
695+
474696inet :: TypeInfo
475697inet = Basic {
476− typoid = Oid 869,
698+ typoid = inetOid,
477699 typcategory = 'I',
478700 typdelim = ',',
479701 typname = "inet"
480702 }
481703
704+inetOid :: Oid
705+inetOid = Oid 869
706+{-# INLINE inetOid #-}
707+
482708bpchar :: TypeInfo
483709bpchar = Basic {
484− typoid = Oid 1042,
710+ typoid = bpcharOid,
485711 typcategory = 'S',
486712 typdelim = ',',
487713 typname = "bpchar"
488714 }
489715
716+bpcharOid :: Oid
717+bpcharOid = Oid 1042
718+{-# INLINE bpcharOid #-}
719+
490720varchar :: TypeInfo
491721varchar = Basic {
492− typoid = Oid 1043,
722+ typoid = varcharOid,
493723 typcategory = 'S',
494724 typdelim = ',',
495725 typname = "varchar"
496726 }
497727
728+varcharOid :: Oid
729+varcharOid = Oid 1043
730+{-# INLINE varcharOid #-}
731+
498732date :: TypeInfo
499733date = Basic {
500− typoid = Oid 1082,
734+ typoid = dateOid,
501735 typcategory = 'D',
502736 typdelim = ',',
503737 typname = "date"
504738 }
505739
740+dateOid :: Oid
741+dateOid = Oid 1082
742+{-# INLINE dateOid #-}
743+
506744time :: TypeInfo
507745time = Basic {
508− typoid = Oid 1083,
746+ typoid = timeOid,
509747 typcategory = 'D',
510748 typdelim = ',',
511749 typname = "time"
512750 }
513751
752+timeOid :: Oid
753+timeOid = Oid 1083
754+{-# INLINE timeOid #-}
755+
514756timestamp :: TypeInfo
515757timestamp = Basic {
516− typoid = Oid 1114,
758+ typoid = timestampOid,
517759 typcategory = 'D',
518760 typdelim = ',',
519761 typname = "timestamp"
520762 }
521763
764+timestampOid :: Oid
765+timestampOid = Oid 1114
766+{-# INLINE timestampOid #-}
767+
522768timestamptz :: TypeInfo
523769timestamptz = Basic {
524− typoid = Oid 1184,
770+ typoid = timestamptzOid,
525771 typcategory = 'D',
526772 typdelim = ',',
527773 typname = "timestamptz"
528774 }
529775
776+timestamptzOid :: Oid
777+timestamptzOid = Oid 1184
778+{-# INLINE timestamptzOid #-}
779+
530780interval :: TypeInfo
531781interval = Basic {
532− typoid = Oid 1186,
782+ typoid = intervalOid,
533783 typcategory = 'T',
534784 typdelim = ',',
535785 typname = "interval"
536786 }
537787
788+intervalOid :: Oid
789+intervalOid = Oid 1186
790+{-# INLINE intervalOid #-}
791+
538792timetz :: TypeInfo
539793timetz = Basic {
540− typoid = Oid 1266,
794+ typoid = timetzOid,
541795 typcategory = 'D',
542796 typdelim = ',',
543797 typname = "timetz"
544798 }
545799
800+timetzOid :: Oid
801+timetzOid = Oid 1266
802+{-# INLINE timetzOid #-}
803+
546804bit :: TypeInfo
547805bit = Basic {
548− typoid = Oid 1560,
806+ typoid = bitOid,
549807 typcategory = 'V',
550808 typdelim = ',',
551809 typname = "bit"
552810 }
553811
812+bitOid :: Oid
813+bitOid = Oid 1560
814+{-# INLINE bitOid #-}
815+
554816varbit :: TypeInfo
555817varbit = Basic {
556− typoid = Oid 1562,
818+ typoid = varbitOid,
557819 typcategory = 'V',
558820 typdelim = ',',
559821 typname = "varbit"
560822 }
561823
824+varbitOid :: Oid
825+varbitOid = Oid 1562
826+{-# INLINE varbitOid #-}
827+
562828numeric :: TypeInfo
563829numeric = Basic {
564− typoid = Oid 1700,
830+ typoid = numericOid,
565831 typcategory = 'N',
566832 typdelim = ',',
567833 typname = "numeric"
568834 }
569835
836+numericOid :: Oid
837+numericOid = Oid 1700
838+{-# INLINE numericOid #-}
839+
570840refcursor :: TypeInfo
571841refcursor = Basic {
572− typoid = Oid 1790,
842+ typoid = refcursorOid,
573843 typcategory = 'U',
574844 typdelim = ',',
575845 typname = "refcursor"
576846 }
577847
848+refcursorOid :: Oid
849+refcursorOid = Oid 1790
850+{-# INLINE refcursorOid #-}
851+
578852record :: TypeInfo
579853record = Basic {
580− typoid = Oid 2249,
854+ typoid = recordOid,
581855 typcategory = 'P',
582856 typdelim = ',',
583857 typname = "record"
584858 }
585859
860+recordOid :: Oid
861+recordOid = Oid 2249
862+{-# INLINE recordOid #-}
863+
586864void :: TypeInfo
587865void = Basic {
588− typoid = Oid 2278,
866+ typoid = voidOid,
589867 typcategory = 'P',
590868 typdelim = ',',
591869 typname = "void"
592870 }
593871
872+voidOid :: Oid
873+voidOid = Oid 2278
874+{-# INLINE voidOid #-}
875+
594876array_record :: TypeInfo
595877array_record = Array {
596− typoid = Oid 2287,
878+ typoid = array_recordOid,
597879 typcategory = 'P',
598880 typdelim = ',',
599881 typname = "_record",
600882 typelem = record
601883 }
602884
885+array_recordOid :: Oid
886+array_recordOid = Oid 2287
887+{-# INLINE array_recordOid #-}
888+
603889regprocedure :: TypeInfo
604890regprocedure = Basic {
605− typoid = Oid 2202,
891+ typoid = regprocedureOid,
606892 typcategory = 'N',
607893 typdelim = ',',
608894 typname = "regprocedure"
609895 }
610896
897+regprocedureOid :: Oid
898+regprocedureOid = Oid 2202
899+{-# INLINE regprocedureOid #-}
900+
611901regoper :: TypeInfo
612902regoper = Basic {
613− typoid = Oid 2203,
903+ typoid = regoperOid,
614904 typcategory = 'N',
615905 typdelim = ',',
616906 typname = "regoper"
617907 }
618908
909+regoperOid :: Oid
910+regoperOid = Oid 2203
911+{-# INLINE regoperOid #-}
912+
619913regoperator :: TypeInfo
620914regoperator = Basic {
621− typoid = Oid 2204,
915+ typoid = regoperatorOid,
622916 typcategory = 'N',
623917 typdelim = ',',
624918 typname = "regoperator"
625919 }
626920
921+regoperatorOid :: Oid
922+regoperatorOid = Oid 2204
923+{-# INLINE regoperatorOid #-}
924+
627925regclass :: TypeInfo
628926regclass = Basic {
629− typoid = Oid 2205,
927+ typoid = regclassOid,
630928 typcategory = 'N',
631929 typdelim = ',',
632930 typname = "regclass"
633931 }
634932
933+regclassOid :: Oid
934+regclassOid = Oid 2205
935+{-# INLINE regclassOid #-}
936+
635937regtype :: TypeInfo
636938regtype = Basic {
637− typoid = Oid 2206,
939+ typoid = regtypeOid,
638940 typcategory = 'N',
639941 typdelim = ',',
640942 typname = "regtype"
641943 }
642944
945+regtypeOid :: Oid
946+regtypeOid = Oid 2206
947+{-# INLINE regtypeOid #-}
948+
643949uuid :: TypeInfo
644950uuid = Basic {
645− typoid = Oid 2950,
951+ typoid = uuidOid,
646952 typcategory = 'U',
647953 typdelim = ',',
648954 typname = "uuid"
649955 }
650956
957+uuidOid :: Oid
958+uuidOid = Oid 2950
959+{-# INLINE uuidOid #-}
960+
651961json :: TypeInfo
652962json = Basic {
653− typoid = Oid 114,
963+ typoid = jsonOid,
654964 typcategory = 'U',
655965 typdelim = ',',
656966 typname = "json"
657967 }
658968
969+jsonOid :: Oid
970+jsonOid = Oid 114
971+{-# INLINE jsonOid #-}
972+
659973jsonb :: TypeInfo
660974jsonb = Basic {
661− typoid = Oid 3802,
975+ typoid = jsonbOid,
662976 typcategory = 'U',
663977 typdelim = ',',
664978 typname = "jsonb"
665979 }
666980
981+jsonbOid :: Oid
982+jsonbOid = Oid 3802
983+{-# INLINE jsonbOid #-}
984+
667985int2vector :: TypeInfo
668986int2vector = Array {
669− typoid = Oid 22,
987+ typoid = int2vectorOid,
670988 typcategory = 'A',
671989 typdelim = ',',
672990 typname = "int2vector",
673991 typelem = int2
674992 }
675993
994+int2vectorOid :: Oid
995+int2vectorOid = Oid 22
996+{-# INLINE int2vectorOid #-}
997+
676998oidvector :: TypeInfo
677999oidvector = Array {
678− typoid = Oid 30,
1000+ typoid = oidvectorOid,
6791001 typcategory = 'A',
6801002 typdelim = ',',
6811003 typname = "oidvector",
6821004 typelem = oid
6831005 }
6841006
1007+oidvectorOid :: Oid
1008+oidvectorOid = Oid 30
1009+{-# INLINE oidvectorOid #-}
1010+
6851011array_xml :: TypeInfo
6861012array_xml = Array {
687− typoid = Oid 143,
1013+ typoid = array_xmlOid,
6881014 typcategory = 'A',
6891015 typdelim = ',',
6901016 typname = "_xml",
6911017 typelem = xml
6921018 }
6931019
1020+array_xmlOid :: Oid
1021+array_xmlOid = Oid 143
1022+{-# INLINE array_xmlOid #-}
1023+
6941024array_json :: TypeInfo
6951025array_json = Array {
696− typoid = Oid 199,
1026+ typoid = array_jsonOid,
6971027 typcategory = 'A',
6981028 typdelim = ',',
6991029 typname = "_json",
7001030 typelem = json
7011031 }
7021032
1033+array_jsonOid :: Oid
1034+array_jsonOid = Oid 199
1035+{-# INLINE array_jsonOid #-}
1036+
7031037array_line :: TypeInfo
7041038array_line = Array {
705− typoid = Oid 629,
1039+ typoid = array_lineOid,
7061040 typcategory = 'A',
7071041 typdelim = ',',
7081042 typname = "_line",
7091043 typelem = line
7101044 }
7111045
1046+array_lineOid :: Oid
1047+array_lineOid = Oid 629
1048+{-# INLINE array_lineOid #-}
1049+
7121050array_cidr :: TypeInfo
7131051array_cidr = Array {
714− typoid = Oid 651,
1052+ typoid = array_cidrOid,
7151053 typcategory = 'A',
7161054 typdelim = ',',
7171055 typname = "_cidr",
7181056 typelem = cidr
7191057 }
7201058
1059+array_cidrOid :: Oid
1060+array_cidrOid = Oid 651
1061+{-# INLINE array_cidrOid #-}
1062+
7211063array_circle :: TypeInfo
7221064array_circle = Array {
723− typoid = Oid 719,
1065+ typoid = array_circleOid,
7241066 typcategory = 'A',
7251067 typdelim = ',',
7261068 typname = "_circle",
7271069 typelem = circle
7281070 }
7291071
1072+array_circleOid :: Oid
1073+array_circleOid = Oid 719
1074+{-# INLINE array_circleOid #-}
1075+
7301076array_money :: TypeInfo
7311077array_money = Array {
732− typoid = Oid 791,
1078+ typoid = array_moneyOid,
7331079 typcategory = 'A',
7341080 typdelim = ',',
7351081 typname = "_money",
7361082 typelem = money
7371083 }
7381084
1085+array_moneyOid :: Oid
1086+array_moneyOid = Oid 791
1087+{-# INLINE array_moneyOid #-}
1088+
7391089array_bool :: TypeInfo
7401090array_bool = Array {
741− typoid = Oid 1000,
1091+ typoid = array_boolOid,
7421092 typcategory = 'A',
7431093 typdelim = ',',
7441094 typname = "_bool",
7451095 typelem = bool
7461096 }
7471097
1098+array_boolOid :: Oid
1099+array_boolOid = Oid 1000
1100+{-# INLINE array_boolOid #-}
1101+
7481102array_bytea :: TypeInfo
7491103array_bytea = Array {
750− typoid = Oid 1001,
1104+ typoid = array_byteaOid,
7511105 typcategory = 'A',
7521106 typdelim = ',',
7531107 typname = "_bytea",
7541108 typelem = bytea
7551109 }
7561110
1111+array_byteaOid :: Oid
1112+array_byteaOid = Oid 1001
1113+{-# INLINE array_byteaOid #-}
1114+
7571115array_char :: TypeInfo
7581116array_char = Array {
759− typoid = Oid 1002,
1117+ typoid = array_charOid,
7601118 typcategory = 'A',
7611119 typdelim = ',',
7621120 typname = "_char",
7631121 typelem = char
7641122 }
7651123
1124+array_charOid :: Oid
1125+array_charOid = Oid 1002
1126+{-# INLINE array_charOid #-}
1127+
7661128array_name :: TypeInfo
7671129array_name = Array {
768− typoid = Oid 1003,
1130+ typoid = array_nameOid,
7691131 typcategory = 'A',
7701132 typdelim = ',',
7711133 typname = "_name",
7721134 typelem = name
7731135 }
7741136
1137+array_nameOid :: Oid
1138+array_nameOid = Oid 1003
1139+{-# INLINE array_nameOid #-}
1140+
7751141array_int2 :: TypeInfo
7761142array_int2 = Array {
777− typoid = Oid 1005,
1143+ typoid = array_int2Oid,
7781144 typcategory = 'A',
7791145 typdelim = ',',
7801146 typname = "_int2",
7811147 typelem = int2
7821148 }
7831149
1150+array_int2Oid :: Oid
1151+array_int2Oid = Oid 1005
1152+{-# INLINE array_int2Oid #-}
1153+
7841154array_int2vector :: TypeInfo
7851155array_int2vector = Array {
786− typoid = Oid 1006,
1156+ typoid = array_int2vectorOid,
7871157 typcategory = 'A',
7881158 typdelim = ',',
7891159 typname = "_int2vector",
7901160 typelem = int2vector
7911161 }
7921162
1163+array_int2vectorOid :: Oid
1164+array_int2vectorOid = Oid 1006
1165+{-# INLINE array_int2vectorOid #-}
1166+
7931167array_int4 :: TypeInfo
7941168array_int4 = Array {
795− typoid = Oid 1007,
1169+ typoid = array_int4Oid,
7961170 typcategory = 'A',
7971171 typdelim = ',',
7981172 typname = "_int4",
7991173 typelem = int4
8001174 }
8011175
1176+array_int4Oid :: Oid
1177+array_int4Oid = Oid 1007
1178+{-# INLINE array_int4Oid #-}
1179+
8021180array_regproc :: TypeInfo
8031181array_regproc = Array {
804− typoid = Oid 1008,
1182+ typoid = array_regprocOid,
8051183 typcategory = 'A',
8061184 typdelim = ',',
8071185 typname = "_regproc",
8081186 typelem = regproc
8091187 }
8101188
1189+array_regprocOid :: Oid
1190+array_regprocOid = Oid 1008
1191+{-# INLINE array_regprocOid #-}
1192+
8111193array_text :: TypeInfo
8121194array_text = Array {
813− typoid = Oid 1009,
1195+ typoid = array_textOid,
8141196 typcategory = 'A',
8151197 typdelim = ',',
8161198 typname = "_text",
8171199 typelem = text
8181200 }
8191201
1202+array_textOid :: Oid
1203+array_textOid = Oid 1009
1204+{-# INLINE array_textOid #-}
1205+
8201206array_tid :: TypeInfo
8211207array_tid = Array {
822− typoid = Oid 1010,
1208+ typoid = array_tidOid,
8231209 typcategory = 'A',
8241210 typdelim = ',',
8251211 typname = "_tid",
8261212 typelem = tid
8271213 }
8281214
1215+array_tidOid :: Oid
1216+array_tidOid = Oid 1010
1217+{-# INLINE array_tidOid #-}
1218+
8291219array_xid :: TypeInfo
8301220array_xid = Array {
831− typoid = Oid 1011,
1221+ typoid = array_xidOid,
8321222 typcategory = 'A',
8331223 typdelim = ',',
8341224 typname = "_xid",
8351225 typelem = xid
8361226 }
8371227
1228+array_xidOid :: Oid
1229+array_xidOid = Oid 1011
1230+{-# INLINE array_xidOid #-}
1231+
8381232array_cid :: TypeInfo
8391233array_cid = Array {
840− typoid = Oid 1012,
1234+ typoid = array_cidOid,
8411235 typcategory = 'A',
8421236 typdelim = ',',
8431237 typname = "_cid",
8441238 typelem = cid
8451239 }
8461240
1241+array_cidOid :: Oid
1242+array_cidOid = Oid 1012
1243+{-# INLINE array_cidOid #-}
1244+
8471245array_oidvector :: TypeInfo
8481246array_oidvector = Array {
849− typoid = Oid 1013,
1247+ typoid = array_oidvectorOid,
8501248 typcategory = 'A',
8511249 typdelim = ',',
8521250 typname = "_oidvector",
8531251 typelem = oidvector
8541252 }
8551253
1254+array_oidvectorOid :: Oid
1255+array_oidvectorOid = Oid 1013
1256+{-# INLINE array_oidvectorOid #-}
1257+
8561258array_bpchar :: TypeInfo
8571259array_bpchar = Array {
858− typoid = Oid 1014,
1260+ typoid = array_bpcharOid,
8591261 typcategory = 'A',
8601262 typdelim = ',',
8611263 typname = "_bpchar",
8621264 typelem = bpchar
8631265 }
8641266
1267+array_bpcharOid :: Oid
1268+array_bpcharOid = Oid 1014
1269+{-# INLINE array_bpcharOid #-}
1270+
8651271array_varchar :: TypeInfo
8661272array_varchar = Array {
867− typoid = Oid 1015,
1273+ typoid = array_varcharOid,
8681274 typcategory = 'A',
8691275 typdelim = ',',
8701276 typname = "_varchar",
8711277 typelem = varchar
8721278 }
8731279
1280+array_varcharOid :: Oid
1281+array_varcharOid = Oid 1015
1282+{-# INLINE array_varcharOid #-}
1283+
8741284array_int8 :: TypeInfo
8751285array_int8 = Array {
876− typoid = Oid 1016,
1286+ typoid = array_int8Oid,
8771287 typcategory = 'A',
8781288 typdelim = ',',
8791289 typname = "_int8",
8801290 typelem = int8
8811291 }
8821292
1293+array_int8Oid :: Oid
1294+array_int8Oid = Oid 1016
1295+{-# INLINE array_int8Oid #-}
1296+
8831297array_point :: TypeInfo
8841298array_point = Array {
885− typoid = Oid 1017,
1299+ typoid = array_pointOid,
8861300 typcategory = 'A',
8871301 typdelim = ',',
8881302 typname = "_point",
8891303 typelem = point
8901304 }
8911305
1306+array_pointOid :: Oid
1307+array_pointOid = Oid 1017
1308+{-# INLINE array_pointOid #-}
1309+
8921310array_lseg :: TypeInfo
8931311array_lseg = Array {
894− typoid = Oid 1018,
1312+ typoid = array_lsegOid,
8951313 typcategory = 'A',
8961314 typdelim = ',',
8971315 typname = "_lseg",
8981316 typelem = lseg
8991317 }
9001318
1319+array_lsegOid :: Oid
1320+array_lsegOid = Oid 1018
1321+{-# INLINE array_lsegOid #-}
1322+
9011323array_path :: TypeInfo
9021324array_path = Array {
903− typoid = Oid 1019,
1325+ typoid = array_pathOid,
9041326 typcategory = 'A',
9051327 typdelim = ',',
9061328 typname = "_path",
9071329 typelem = path
9081330 }
9091331
1332+array_pathOid :: Oid
1333+array_pathOid = Oid 1019
1334+{-# INLINE array_pathOid #-}
1335+
9101336array_box :: TypeInfo
9111337array_box = Array {
912− typoid = Oid 1020,
1338+ typoid = array_boxOid,
9131339 typcategory = 'A',
9141340 typdelim = ';',
9151341 typname = "_box",
9161342 typelem = box
9171343 }
9181344
1345+array_boxOid :: Oid
1346+array_boxOid = Oid 1020
1347+{-# INLINE array_boxOid #-}
1348+
9191349array_float4 :: TypeInfo
9201350array_float4 = Array {
921− typoid = Oid 1021,
1351+ typoid = array_float4Oid,
9221352 typcategory = 'A',
9231353 typdelim = ',',
9241354 typname = "_float4",
9251355 typelem = float4
9261356 }
9271357
1358+array_float4Oid :: Oid
1359+array_float4Oid = Oid 1021
1360+{-# INLINE array_float4Oid #-}
1361+
9281362array_float8 :: TypeInfo
9291363array_float8 = Array {
930− typoid = Oid 1022,
1364+ typoid = array_float8Oid,
9311365 typcategory = 'A',
9321366 typdelim = ',',
9331367 typname = "_float8",
9341368 typelem = float8
9351369 }
9361370
1371+array_float8Oid :: Oid
1372+array_float8Oid = Oid 1022
1373+{-# INLINE array_float8Oid #-}
1374+
9371375array_polygon :: TypeInfo
9381376array_polygon = Array {
939− typoid = Oid 1027,
1377+ typoid = array_polygonOid,
9401378 typcategory = 'A',
9411379 typdelim = ',',
9421380 typname = "_polygon",
9431381 typelem = polygon
9441382 }
9451383
1384+array_polygonOid :: Oid
1385+array_polygonOid = Oid 1027
1386+{-# INLINE array_polygonOid #-}
1387+
9461388array_oid :: TypeInfo
9471389array_oid = Array {
948− typoid = Oid 1028,
1390+ typoid = array_oidOid,
9491391 typcategory = 'A',
9501392 typdelim = ',',
9511393 typname = "_oid",
9521394 typelem = oid
9531395 }
9541396
1397+array_oidOid :: Oid
1398+array_oidOid = Oid 1028
1399+{-# INLINE array_oidOid #-}
1400+
9551401array_macaddr :: TypeInfo
9561402array_macaddr = Array {
957− typoid = Oid 1040,
1403+ typoid = array_macaddrOid,
9581404 typcategory = 'A',
9591405 typdelim = ',',
9601406 typname = "_macaddr",
9611407 typelem = macaddr
9621408 }
9631409
1410+array_macaddrOid :: Oid
1411+array_macaddrOid = Oid 1040
1412+{-# INLINE array_macaddrOid #-}
1413+
9641414array_inet :: TypeInfo
9651415array_inet = Array {
966− typoid = Oid 1041,
1416+ typoid = array_inetOid,
9671417 typcategory = 'A',
9681418 typdelim = ',',
9691419 typname = "_inet",
9701420 typelem = inet
9711421 }
9721422
1423+array_inetOid :: Oid
1424+array_inetOid = Oid 1041
1425+{-# INLINE array_inetOid #-}
1426+
9731427array_timestamp :: TypeInfo
9741428array_timestamp = Array {
975− typoid = Oid 1115,
1429+ typoid = array_timestampOid,
9761430 typcategory = 'A',
9771431 typdelim = ',',
9781432 typname = "_timestamp",
9791433 typelem = timestamp
9801434 }
9811435
1436+array_timestampOid :: Oid
1437+array_timestampOid = Oid 1115
1438+{-# INLINE array_timestampOid #-}
1439+
9821440array_date :: TypeInfo
9831441array_date = Array {
984− typoid = Oid 1182,
1442+ typoid = array_dateOid,
9851443 typcategory = 'A',
9861444 typdelim = ',',
9871445 typname = "_date",
9881446 typelem = date
9891447 }
9901448
1449+array_dateOid :: Oid
1450+array_dateOid = Oid 1182
1451+{-# INLINE array_dateOid #-}
1452+
9911453array_time :: TypeInfo
9921454array_time = Array {
993− typoid = Oid 1183,
1455+ typoid = array_timeOid,
9941456 typcategory = 'A',
9951457 typdelim = ',',
9961458 typname = "_time",
9971459 typelem = time
9981460 }
9991461
1462+array_timeOid :: Oid
1463+array_timeOid = Oid 1183
1464+{-# INLINE array_timeOid #-}
1465+
10001466array_timestamptz :: TypeInfo
10011467array_timestamptz = Array {
1002− typoid = Oid 1185,
1468+ typoid = array_timestamptzOid,
10031469 typcategory = 'A',
10041470 typdelim = ',',
10051471 typname = "_timestamptz",
10061472 typelem = timestamptz
10071473 }
10081474
1475+array_timestamptzOid :: Oid
1476+array_timestamptzOid = Oid 1185
1477+{-# INLINE array_timestamptzOid #-}
1478+
10091479array_interval :: TypeInfo
10101480array_interval = Array {
1011− typoid = Oid 1187,
1481+ typoid = array_intervalOid,
10121482 typcategory = 'A',
10131483 typdelim = ',',
10141484 typname = "_interval",
10151485 typelem = interval
10161486 }
10171487
1488+array_intervalOid :: Oid
1489+array_intervalOid = Oid 1187
1490+{-# INLINE array_intervalOid #-}
1491+
10181492array_numeric :: TypeInfo
10191493array_numeric = Array {
1020− typoid = Oid 1231,
1494+ typoid = array_numericOid,
10211495 typcategory = 'A',
10221496 typdelim = ',',
10231497 typname = "_numeric",
10241498 typelem = numeric
10251499 }
10261500
1501+array_numericOid :: Oid
1502+array_numericOid = Oid 1231
1503+{-# INLINE array_numericOid #-}
1504+
10271505array_timetz :: TypeInfo
10281506array_timetz = Array {
1029− typoid = Oid 1270,
1507+ typoid = array_timetzOid,
10301508 typcategory = 'A',
10311509 typdelim = ',',
10321510 typname = "_timetz",
10331511 typelem = timetz
10341512 }
10351513
1514+array_timetzOid :: Oid
1515+array_timetzOid = Oid 1270
1516+{-# INLINE array_timetzOid #-}
1517+
10361518array_bit :: TypeInfo
10371519array_bit = Array {
1038− typoid = Oid 1561,
1520+ typoid = array_bitOid,
10391521 typcategory = 'A',
10401522 typdelim = ',',
10411523 typname = "_bit",
10421524 typelem = bit
10431525 }
10441526
1527+array_bitOid :: Oid
1528+array_bitOid = Oid 1561
1529+{-# INLINE array_bitOid #-}
1530+
10451531array_varbit :: TypeInfo
10461532array_varbit = Array {
1047− typoid = Oid 1563,
1533+ typoid = array_varbitOid,
10481534 typcategory = 'A',
10491535 typdelim = ',',
10501536 typname = "_varbit",
10511537 typelem = varbit
10521538 }
10531539
1540+array_varbitOid :: Oid
1541+array_varbitOid = Oid 1563
1542+{-# INLINE array_varbitOid #-}
1543+
10541544array_refcursor :: TypeInfo
10551545array_refcursor = Array {
1056− typoid = Oid 2201,
1546+ typoid = array_refcursorOid,
10571547 typcategory = 'A',
10581548 typdelim = ',',
10591549 typname = "_refcursor",
10601550 typelem = refcursor
10611551 }
10621552
1553+array_refcursorOid :: Oid
1554+array_refcursorOid = Oid 2201
1555+{-# INLINE array_refcursorOid #-}
1556+
10631557array_regprocedure :: TypeInfo
10641558array_regprocedure = Array {
1065− typoid = Oid 2207,
1559+ typoid = array_regprocedureOid,
10661560 typcategory = 'A',
10671561 typdelim = ',',
10681562 typname = "_regprocedure",
10691563 typelem = regprocedure
10701564 }
10711565
1566+array_regprocedureOid :: Oid
1567+array_regprocedureOid = Oid 2207
1568+{-# INLINE array_regprocedureOid #-}
1569+
10721570array_regoper :: TypeInfo
10731571array_regoper = Array {
1074− typoid = Oid 2208,
1572+ typoid = array_regoperOid,
10751573 typcategory = 'A',
10761574 typdelim = ',',
10771575 typname = "_regoper",
10781576 typelem = regoper
10791577 }
10801578
1579+array_regoperOid :: Oid
1580+array_regoperOid = Oid 2208
1581+{-# INLINE array_regoperOid #-}
1582+
10811583array_regoperator :: TypeInfo
10821584array_regoperator = Array {
1083− typoid = Oid 2209,
1585+ typoid = array_regoperatorOid,
10841586 typcategory = 'A',
10851587 typdelim = ',',
10861588 typname = "_regoperator",
10871589 typelem = regoperator
10881590 }
10891591
1592+array_regoperatorOid :: Oid
1593+array_regoperatorOid = Oid 2209
1594+{-# INLINE array_regoperatorOid #-}
1595+
10901596array_regclass :: TypeInfo
10911597array_regclass = Array {
1092− typoid = Oid 2210,
1598+ typoid = array_regclassOid,
10931599 typcategory = 'A',
10941600 typdelim = ',',
10951601 typname = "_regclass",
10961602 typelem = regclass
10971603 }
10981604
1605+array_regclassOid :: Oid
1606+array_regclassOid = Oid 2210
1607+{-# INLINE array_regclassOid #-}
1608+
10991609array_regtype :: TypeInfo
11001610array_regtype = Array {
1101− typoid = Oid 2211,
1611+ typoid = array_regtypeOid,
11021612 typcategory = 'A',
11031613 typdelim = ',',
11041614 typname = "_regtype",
11051615 typelem = regtype
11061616 }
11071617
1618+array_regtypeOid :: Oid
1619+array_regtypeOid = Oid 2211
1620+{-# INLINE array_regtypeOid #-}
1621+
11081622array_uuid :: TypeInfo
11091623array_uuid = Array {
1110− typoid = Oid 2951,
1624+ typoid = array_uuidOid,
11111625 typcategory = 'A',
11121626 typdelim = ',',
11131627 typname = "_uuid",
11141628 typelem = uuid
11151629 }
11161630
1631+array_uuidOid :: Oid
1632+array_uuidOid = Oid 2951
1633+{-# INLINE array_uuidOid #-}
1634+
11171635array_jsonb :: TypeInfo
11181636array_jsonb = Array {
1119− typoid = Oid 3807,
1637+ typoid = array_jsonbOid,
11201638 typcategory = 'A',
11211639 typdelim = ',',
11221640 typname = "_jsonb",
11231641 typelem = jsonb
11241642 }
11251643
1644+array_jsonbOid :: Oid
1645+array_jsonbOid = Oid 3807
1646+{-# INLINE array_jsonbOid #-}
1647+
11261648int4range :: TypeInfo
11271649int4range = Range {
1128− typoid = Oid 3904,
1650+ typoid = int4rangeOid,
11291651 typcategory = 'R',
11301652 typdelim = ',',
11311653 typname = "int4range",
11321654 rngsubtype = int4
11331655 }
11341656
1657+int4rangeOid :: Oid
1658+int4rangeOid = Oid 3904
1659+{-# INLINE int4rangeOid #-}
1660+
11351661_int4range :: TypeInfo
11361662_int4range = Array {
1137− typoid = Oid 3905,
1663+ typoid = _int4rangeOid,
11381664 typcategory = 'A',
11391665 typdelim = ',',
11401666 typname = "_int4range",
11411667 typelem = int4range
11421668 }
11431669
1670+_int4rangeOid :: Oid
1671+_int4rangeOid = Oid 3905
1672+{-# INLINE _int4rangeOid #-}
1673+
11441674numrange :: TypeInfo
11451675numrange = Range {
1146− typoid = Oid 3906,
1676+ typoid = numrangeOid,
11471677 typcategory = 'R',
11481678 typdelim = ',',
11491679 typname = "numrange",
11501680 rngsubtype = numeric
11511681 }
11521682
1683+numrangeOid :: Oid
1684+numrangeOid = Oid 3906
1685+{-# INLINE numrangeOid #-}
1686+
11531687_numrange :: TypeInfo
11541688_numrange = Array {
1155− typoid = Oid 3907,
1689+ typoid = _numrangeOid,
11561690 typcategory = 'A',
11571691 typdelim = ',',
11581692 typname = "_numrange",
11591693 typelem = numrange
11601694 }
11611695
1696+_numrangeOid :: Oid
1697+_numrangeOid = Oid 3907
1698+{-# INLINE _numrangeOid #-}
1699+
11621700tsrange :: TypeInfo
11631701tsrange = Range {
1164− typoid = Oid 3908,
1702+ typoid = tsrangeOid,
11651703 typcategory = 'R',
11661704 typdelim = ',',
11671705 typname = "tsrange",
11681706 rngsubtype = timestamp
11691707 }
11701708
1709+tsrangeOid :: Oid
1710+tsrangeOid = Oid 3908
1711+{-# INLINE tsrangeOid #-}
1712+
11711713_tsrange :: TypeInfo
11721714_tsrange = Array {
1173− typoid = Oid 3909,
1715+ typoid = _tsrangeOid,
11741716 typcategory = 'A',
11751717 typdelim = ',',
11761718 typname = "_tsrange",
11771719 typelem = tsrange
11781720 }
11791721
1722+_tsrangeOid :: Oid
1723+_tsrangeOid = Oid 3909
1724+{-# INLINE _tsrangeOid #-}
1725+
11801726tstzrange :: TypeInfo
11811727tstzrange = Range {
1182− typoid = Oid 3910,
1728+ typoid = tstzrangeOid,
11831729 typcategory = 'R',
11841730 typdelim = ',',
11851731 typname = "tstzrange",
11861732 rngsubtype = timestamptz
11871733 }
11881734
1735+tstzrangeOid :: Oid
1736+tstzrangeOid = Oid 3910
1737+{-# INLINE tstzrangeOid #-}
1738+
11891739_tstzrange :: TypeInfo
11901740_tstzrange = Array {
1191− typoid = Oid 3911,
1741+ typoid = _tstzrangeOid,
11921742 typcategory = 'A',
11931743 typdelim = ',',
11941744 typname = "_tstzrange",
11951745 typelem = tstzrange
11961746 }
11971747
1748+_tstzrangeOid :: Oid
1749+_tstzrangeOid = Oid 3911
1750+{-# INLINE _tstzrangeOid #-}
1751+
11981752daterange :: TypeInfo
11991753daterange = Range {
1200− typoid = Oid 3912,
1754+ typoid = daterangeOid,
12011755 typcategory = 'R',
12021756 typdelim = ',',
12031757 typname = "daterange",
12041758 rngsubtype = date
12051759 }
12061760
1761+daterangeOid :: Oid
1762+daterangeOid = Oid 3912
1763+{-# INLINE daterangeOid #-}
1764+
12071765_daterange :: TypeInfo
12081766_daterange = Array {
1209− typoid = Oid 3913,
1767+ typoid = _daterangeOid,
12101768 typcategory = 'A',
12111769 typdelim = ',',
12121770 typname = "_daterange",
12131771 typelem = daterange
12141772 }
12151773
1774+_daterangeOid :: Oid
1775+_daterangeOid = Oid 3913
1776+{-# INLINE _daterangeOid #-}
1777+
12161778int8range :: TypeInfo
12171779int8range = Range {
1218− typoid = Oid 3926,
1780+ typoid = int8rangeOid,
12191781 typcategory = 'R',
12201782 typdelim = ',',
12211783 typname = "int8range",
12221784 rngsubtype = int8
12231785 }
12241786
1787+int8rangeOid :: Oid
1788+int8rangeOid = Oid 3926
1789+{-# INLINE int8rangeOid #-}
1790+
12251791_int8range :: TypeInfo
12261792_int8range = Array {
1227− typoid = Oid 3927,
1793+ typoid = _int8rangeOid,
12281794 typcategory = 'A',
12291795 typdelim = ',',
12301796 typname = "_int8range",
12311797 typelem = int8range
12321798 }
1799+
1800+_int8rangeOid :: Oid
1801+_int8rangeOid = Oid 3927
1802+{-# INLINE _int8rangeOid #-}
src/Database/PostgreSQL/Simple/Types.hs+54−30
@@ -1,4 +1,4 @@
1−{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, GeneralizedNewtypeDeriving #-}
1+{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, GeneralizedNewtypeDeriving #-}
22
33------------------------------------------------------------------------------
44-- |
@@ -33,13 +33,16 @@ module Database.PostgreSQL.Simple.Types
3333import Control.Arrow (first)
3434import Data.ByteString (ByteString)
3535import Data.Hashable (Hashable(hashWithSalt))
36+import Data.Foldable (toList)
3637import Data.Monoid (Monoid(..))
38+import Data.Semigroup
3739import Data.String (IsString(..))
3840import Data.Typeable (Typeable)
3941import Data.ByteString.Builder ( stringUtf8 )
4042import qualified Data.ByteString as B
4143import Data.Text (Text)
4244import qualified Data.Text as T
45+import Data.Tuple.Only (Only(..))
4346import Database.PostgreSQL.LibPQ (Oid(..))
4447import Database.PostgreSQL.Simple.Compat (toByteString)
4548
@@ -47,10 +50,6 @@ import Database.PostgreSQL.Simple.Compat (toByteString)
4750data Null = Null
4851 deriving (Read, Show, Typeable)
4952
50−instance Eq Null where
51− _ == _ = False
52− _ /= _ = False
53−
5453-- | A placeholder for the PostgreSQL @DEFAULT@ value.
5554data Default = Default
5655 deriving (Read, Show, Typeable)
@@ -87,28 +86,13 @@ instance Read Query where
8786instance IsString Query where
8887 fromString = Query . toByteString . stringUtf8
8988
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+
9094instance Monoid Query where
9195 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))
95−
96−-- | A single-value \"collection\".
97−--
98−-- This is useful if you need to supply a single parameter to a SQL
99−-- query, or extract a single column from a SQL result.
100−--
101−-- Parameter example:
102−--
103−-- @query c \"select x from scores where x > ?\" ('Only' (42::Int))@
104−--
105−-- Result example:
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)
11296
11397-- | Wrap a list of values for use in an @IN@ clause. Replaces a
11498-- single \"@?@\" character with a parenthesized list of rendered
@@ -117,6 +101,44 @@ newtype Only a = Only {
117101-- Example:
118102--
119103-- > query c "select * from whatever where id in ?" (Only (In [3,4,5]))
104+--
105+-- Note that @In []@ expands to @(null)@, which works as expected in
106+-- the query above, but evaluates to the logical null value on every
107+-- row instead of @TRUE@. This means that changing the query above
108+-- to @... id NOT in ?@ and supplying the empty list as the parameter
109+-- returns zero rows, instead of all of them as one would expect.
110+--
111+-- Since postgresql doesn't seem to provide a syntax for actually specifying
112+-- an empty list, which could solve this completely, there are two
113+-- workarounds particularly worth mentioning, namely:
114+--
115+-- 1. Use postgresql-simple's 'Values' type instead, which can handle the
116+-- empty case correctly. Note however that while specifying the
117+-- postgresql type @"int4"@ is mandatory in the empty case, specifying
118+-- the haskell type @Values (Only Int)@ would not normally be needed in
119+-- realistic use cases.
120+--
121+-- > query c "select * from whatever where id not in ?"
122+-- > (Only (Values ["int4"] [] :: Values (Only Int)))
123+--
124+--
125+-- 2. Use sql's @COALESCE@ operator to turn a logical @null@ into the correct
126+-- boolean. Note however that the correct boolean depends on the use
127+-- case:
128+--
129+-- > query c "select * from whatever where coalesce(id NOT in ?, TRUE)"
130+-- > (Only (In [] :: In [Int]))
131+--
132+-- > query c "select * from whatever where coalesce(id IN ?, FALSE)"
133+-- > (Only (In [] :: In [Int]))
134+--
135+-- Note that at as of PostgreSQL 9.4, the query planner cannot see inside
136+-- the @COALESCE@ operator, so if you have an index on @id@ then you
137+-- probably don't want to write the last example with @COALESCE@, which
138+-- would result in a table scan. There are further caveats if @id@ can
139+-- be null or you want null treated sensibly as a component of @IN@ or
140+-- @NOT IN@.
141+
120142newtype In a = In a
121143 deriving (Eq, Ord, Read, Show, Typeable, Functor)
122144
@@ -179,8 +201,9 @@ infixr 3 :.
179201newtype Savepoint = Savepoint Query
180202 deriving (Eq, Ord, Show, Read, Typeable)
181203
182−-- | Represents a @VALUES@ table literal, usable as an alternative
183−-- to @executeMany@ and @returning@. The main advantage is that
204+-- | Represents a @VALUES@ table literal, usable as an alternative to
205+-- 'Database.PostgreSQL.Simple.executeMany' and
206+-- 'Database.PostgreSQL.Simple.returning'. The main advantage is that
184207-- you can parametrize more than just a single @VALUES@ expression.
185208-- For example, here's a query to insert a thing into one table
186209-- and some attributes of that thing into another, returning the
@@ -193,7 +216,7 @@ newtype Savepoint = Savepoint Query
193216-- > ), new_attributes AS (
194217-- > INSERT INTO thing_attributes
195218-- > SELECT new_thing.id, attrs.*
196−-- > FROM new_thing JOIN ? attrs
219+-- > FROM new_thing JOIN ? attrs ON TRUE
197220-- > ) SELECT * FROM new_thing
198221-- > |] ("foo", Values [ "int4", "text" ]
199222-- > [ ( 1 , "hello" )
@@ -219,7 +242,8 @@ newtype Savepoint = Savepoint Query
219242-- is turned into a properly quoted identifier, the type name is case
220243-- sensitive and must be as it appears in the @pg_type@ table. Thus,
221244-- you must write @timestamptz@ instead of @timestamp with time zone@,
222−-- @int4@ instead of @integer@, @_int8@ instead of @bigint[]@, etcetera.
245+-- @int4@ instead of @integer@ or @serial@, @_int8@ instead of @bigint[]@,
246+-- etcetera.
223247--
224248-- You may omit the type names, however, if you do so the list
225249-- of values must be non-empty, and postgresql must be able to infer
@@ -228,7 +252,7 @@ newtype Savepoint = Savepoint Query
228252-- without issuing the query. In the second case, the postgres server
229253-- will return an error which will be turned into a @SqlError@ exception.
230254--
231−-- See <http://www.postgresql.org/docs/9.3/static/sql-values.html> for
255+-- See <https://www.postgresql.org/docs/9.5/static/sql-values.html> for
232256-- more information.
233257data Values a = Values [QualifiedIdentifier] [a]
234258 deriving (Eq, Ord, Show, Read, Typeable)
src/Database/PostgreSQL/Simple/Vector.hsnew file+45
@@ -0,0 +1,45 @@
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.hsnew file+44
@@ -0,0 +1,44 @@
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 @@
11module Common (
22 module Database.PostgreSQL.Simple,
3− module Test.HUnit,
3+ module Test.Tasty.HUnit,
44 TestEnv(..),
55 md5,
66) where
@@ -8,7 +8,7 @@ module Common (
88import Data.ByteString (ByteString)
99import Data.Text (Text)
1010import Database.PostgreSQL.Simple
11−import Test.HUnit
11+import Test.Tasty.HUnit
1212
1313import qualified Crypto.Hash.MD5 as MD5
1414import qualified Data.ByteString.Base16 as Base16
test/Exception.hsnew file+70
@@ -0,0 +1,70 @@
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.hsnew file+79
@@ -0,0 +1,79 @@
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.hsnew file+176
@@ -0,0 +1,176 @@
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+343−59
@@ -1,53 +1,95 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DeriveGeneric #-}
13{-# LANGUAGE DeriveDataTypeable #-}
24{-# LANGUAGE DoAndIfThenElse #-}
35{-# LANGUAGE ScopedTypeVariables #-}
6+#if __GLASGOW_HASKELL__ >= 806
7+{-# LANGUAGE DerivingStrategies #-}
8+{-# LANGUAGE DerivingVia #-}
9+{-# LANGUAGE DeriveAnyClass #-}
10+#endif
11+module Main (main) where
12+
413import Common
14+import Database.PostgreSQL.Simple.Copy
15+import Database.PostgreSQL.Simple.ToField (ToField)
516import Database.PostgreSQL.Simple.FromField (FromField)
6−import Database.PostgreSQL.Simple.Types(Query(..),Values(..))
717import Database.PostgreSQL.Simple.HStore
8−import Database.PostgreSQL.Simple.Copy
18+import Database.PostgreSQL.Simple.Newtypes
19+import Database.PostgreSQL.Simple.Internal (breakOnSingleQuestionMark)
20+import Database.PostgreSQL.Simple.Types(Query(..),Values(..), PGArray(..))
921import qualified Database.PostgreSQL.Simple.Transaction as ST
22+
1023import Control.Applicative
1124import Control.Exception as E
1225import Control.Monad
13−import Data.ByteString (ByteString)
26+import Data.Char
27+import Data.Foldable (toList)
28+import Data.List (concat, sort)
1429import Data.IORef
30+import Data.Monoid ((<>))
31+import Data.String (fromString)
1532import Data.Typeable
33+import GHC.Generics (Generic)
34+
35+import Data.Aeson
36+import Data.ByteString (ByteString)
1637import 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
1742import Data.Map (Map)
18−import Data.List (sort)
1943import qualified Data.Map as Map
2044import Data.Text(Text)
2145import qualified Data.Text.Encoding as T
22−import System.Exit (exitFailure)
23−import System.IO
2446import qualified Data.Vector as V
25−import Data.Aeson
47+import System.FilePath
48+import System.Timeout(timeout)
49+import Data.Time.Compat (getCurrentTime, diffUTCTime)
50+import System.Environment (getEnvironment)
2651
52+import Test.Tasty
53+import Test.Tasty.Golden
2754import Notify
2855import Serializable
2956import Time
30−
31−tests :: [TestEnv -> Test]
32−tests =
33− [ TestLabel "Bytea" . testBytea
34− , TestLabel "ExecuteMany" . testExecuteMany
35− , TestLabel "Fold" . testFold
36− , TestLabel "Notify" . testNotify
37− , TestLabel "Serializable" . testSerializable
38− , TestLabel "Time" . testTime
39− , TestLabel "Array" . testArray
40− , TestLabel "HStore" . testHStore
41− , TestLabel "JSON" . testJSON
42− , TestLabel "Savepoint" . testSavepoint
43− , TestLabel "Unicode" . testUnicode
44− , TestLabel "Values" . testValues
45− , TestLabel "Copy" . testCopy
46− , TestLabel "Double" . testDouble
57+import Interval
58+import Exception (testExceptions)
59+
60+tests :: TestEnv -> TestTree
61+tests env = testGroup "tests"
62+ $ map ($ env)
63+ [ testBytea
64+ , testCase "ExecuteMany" . testExecuteMany
65+ , testCase "Fold" . testFold
66+ , testCase "Notify" . testNotify
67+ , testCase "Serializable" . testSerializable
68+ , testCase "Time" . testTime
69+ , testCase "Interval" . testInterval
70+ , testCase "Array" . testArray
71+ , testCase "Array of nullables" . testNullableArray
72+ , testCase "HStore" . testHStore
73+ , testCase "citext" . testCIText
74+ , testCase "JSON" . testJSON
75+ , testCase "Aeson newtype" . testAeson
76+ , testCase "DerivingVia" . testDerivingVia
77+ , testCase "Question mark escape" . testQM
78+ , testCase "Savepoint" . testSavepoint
79+ , testCase "Unicode" . testUnicode
80+ , testCase "Values" . testValues
81+ , testCase "Copy" . testCopy
82+ , testCopyFailures
83+ , testCase "Double" . testDouble
84+ , testCase "1-ary generic" . testGeneric1
85+ , testCase "2-ary generic" . testGeneric2
86+ , testCase "3-ary generic" . testGeneric3
87+ , testCase "Timeout" . testTimeout
88+ , testCase "Exceptions" . testExceptions
4789 ]
4890
49−testBytea :: TestEnv -> Test
50−testBytea TestEnv{..} = TestList
91+testBytea :: TestEnv -> TestTree
92+testBytea TestEnv{..} = testGroup "Bytea"
5193 [ testStr "empty" []
5294 , testStr "\"hello\"" $ map (fromIntegral . fromEnum) ("hello" :: String)
5395 , testStr "ascending" [0..255]
@@ -56,7 +98,7 @@ testBytea TestEnv{..} = TestList
5698 , testStr "descending, doubled up" $ doubleUp [255,254..0]
5799 ]
58100 where
59− testStr label bytes = TestLabel label $ TestCase $ do
101+ testStr label bytes = testCase label $ do
60102 let bs = B.pack bytes
61103
62104 [Only h] <- query conn "SELECT md5(?::bytea)" [Binary bs]
@@ -67,8 +109,8 @@ testBytea TestEnv{..} = TestList
67109
68110 doubleUp = concatMap (\x -> [x, x])
69111
70−testExecuteMany :: TestEnv -> Test
71−testExecuteMany TestEnv{..} = TestCase $ do
112+testExecuteMany :: TestEnv -> Assertion
113+testExecuteMany TestEnv{..} = do
72114 execute_ conn "CREATE TEMPORARY TABLE tmp_executeMany (i INT, t TEXT, b BYTEA)"
73115
74116 let rows :: [(Int, String, Binary ByteString)]
@@ -85,8 +127,8 @@ testExecuteMany TestEnv{..} = TestCase $ do
85127
86128 return ()
87129
88−testFold :: TestEnv -> Test
89−testFold TestEnv{..} = TestCase $ do
130+testFold :: TestEnv -> Assertion
131+testFold TestEnv{..} = do
90132 xs <- fold_ conn "SELECT generate_series(1,10000)"
91133 [] $ \xs (Only x) -> return (x:xs)
92134 reverse xs @?= ([1..10000] :: [Int])
@@ -97,7 +139,7 @@ testFold TestEnv{..} = TestCase $ do
97139 xs <- readIORef ref
98140 writeIORef ref $! (a,b):xs
99141 xs <- readIORef ref
100− reverse xs @?= [(a,b) | a <- [1..100], b <- [1..50]]
142+ reverse xs @?= [(a,b) | b <- [1..50], a <- [1..100]]
101143
102144 -- Make sure fold propagates our exception.
103145 ref <- newIORef []
@@ -155,8 +197,8 @@ queryFailure conn q resultType = do
155197 ++ show (typeOf resultType)
156198 ++ " -> " ++ show val)
157199
158−testArray :: TestEnv -> Test
159−testArray TestEnv{..} = TestCase $ do
200+testArray :: TestEnv -> Assertion
201+testArray TestEnv{..} = do
160202 xs <- query_ conn "SELECT '{1,2,3,4}'::_int4"
161203 xs @?= [Only (V.fromList [1,2,3,4 :: Int])]
162204 xs <- query_ conn "SELECT '{{1,2},{3,4}}'::_int4"
@@ -165,8 +207,16 @@ testArray TestEnv{..} = TestCase $ do
165207 queryFailure conn "SELECT '{1,2,3,4}'::_int4" (undefined :: V.Vector Bool)
166208 queryFailure conn "SELECT '{{1,2},{3,4}}'::_int4" (undefined :: V.Vector Int)
167209
168−testHStore :: TestEnv -> Test
169−testHStore TestEnv{..} = TestCase $ do
210+testNullableArray :: TestEnv -> Assertion
211+testNullableArray TestEnv{..} = do
212+ xs <- query_ conn "SELECT '{sometext, \"NULL\"}'::_text"
213+ xs @?= [Only (V.fromList ["sometext", "NULL" :: Text])]
214+ xs <- query_ conn "SELECT '{sometext, NULL}'::_text"
215+ xs @?= [Only (V.fromList [Just "sometext", Nothing :: Maybe Text])]
216+ queryFailure conn "SELECT '{sometext, NULL}'::_text" (undefined :: V.Vector Text)
217+
218+testHStore :: TestEnv -> Assertion
219+testHStore TestEnv{..} = do
170220 execute_ conn "CREATE EXTENSION IF NOT EXISTS hstore"
171221 roundTrip []
172222 roundTrip [("foo","bar"),("bar","baz"),("baz","hello")]
@@ -178,8 +228,21 @@ testHStore TestEnv{..} = TestCase $ do
178228 m' <- query conn "SELECT ?::hstore" m
179229 [m] @?= m'
180230
181−testJSON :: TestEnv -> Test
182−testJSON TestEnv{..} = TestCase $ do
231+testCIText :: TestEnv -> Assertion
232+testCIText TestEnv{..} = do
233+ execute_ conn "CREATE EXTENSION IF NOT EXISTS citext"
234+ roundTrip (CI.mk "")
235+ roundTrip (CI.mk "UPPERCASE")
236+ roundTrip (CI.mk "lowercase")
237+ where
238+ roundTrip :: (CI Text) -> Assertion
239+ roundTrip cit = do
240+ let toPostgres = Only cit
241+ fromPostgres <- query conn "SELECT ?::citext" toPostgres
242+ [toPostgres] @?= fromPostgres
243+
244+testJSON :: TestEnv -> Assertion
245+testJSON TestEnv{..} = do
183246 roundTrip (Map.fromList [] :: Map Text Text)
184247 roundTrip (Map.fromList [("foo","bar"),("bar","baz"),("baz","hello")] :: Map Text Text)
185248 roundTrip (Map.fromList [("fo\"o","bar"),("b\\ar","baz"),("baz","\"value\\with\"escapes")] :: Map Text Text)
@@ -193,8 +256,92 @@ testJSON TestEnv{..} = TestCase $ do
193256 js' <- query conn "SELECT ?::json" js
194257 [js] @?= js'
195258
196−testSavepoint :: TestEnv -> Test
197−testSavepoint TestEnv{..} = TestCase $ do
259+testAeson :: TestEnv -> Assertion
260+testAeson TestEnv{..} = do
261+ roundTrip (Map.fromList [] :: Map Text Text)
262+ roundTrip (Map.fromList [("foo","bar"),("bar","baz"),("baz","hello")] :: Map Text Text)
263+ roundTrip (Map.fromList [("fo\"o","bar"),("b\\ar","baz"),("baz","\"value\\with\"escapes")] :: Map Text Text)
264+ roundTrip (V.fromList [1,2,3,4,5::Int])
265+ roundTrip ("foo" :: Text)
266+ roundTrip (42 :: Int)
267+ where
268+ roundTrip :: (Eq a, Show a, Typeable a, ToJSON a, FromJSON a)=> a -> Assertion
269+ roundTrip x = do
270+ y <- query conn "SELECT ?::json" (Only (Aeson x))
271+ [Only (Aeson x)] @?= y
272+
273+testDerivingVia :: TestEnv -> Assertion
274+testDerivingVia TestEnv{..} = do
275+#if __GLASGOW_HASKELL__ <806
276+ return ()
277+#else
278+ roundTrip $ DerivingVia1 42 "Meaning of Life"
279+ where
280+ roundTrip :: (Eq a, Show a, Typeable a, ToField a, FromField a)=> a -> Assertion
281+ roundTrip x = do
282+ y <- query conn "SELECT ?::json" (Only x)
283+ [Only x] @?= y
284+
285+data DerivingVia1 = DerivingVia1 Int String
286+ deriving stock (Eq, Show, Generic)
287+ deriving anyclass (FromJSON, ToJSON)
288+ deriving (ToField, FromField) via Aeson DerivingVia1
289+
290+#endif
291+
292+
293+testQM :: TestEnv -> Assertion
294+testQM TestEnv{..} = do
295+ -- Just test on a single string
296+ let testQuery' b = "testing for ?" <> b <> " and making sure "
297+ testQueryDoubleQM = testQuery' "?"
298+ testQueryRest = "? is substituted"
299+ testQuery = fromString $ testQueryDoubleQM <> testQueryRest
300+ -- expect the entire first part with double QMs replaced with literal '?'
301+ expected = (fromString $ testQuery' "", fromString testQueryRest)
302+ tried = breakOnSingleQuestionMark testQuery
303+ errMsg = concat
304+ [ "Failed to break on single question mark exclusively:\n"
305+ , "expected: ", show expected
306+ , "result: ", show tried
307+ ]
308+ assertBool errMsg $ tried == expected
309+
310+ -- Let's also test the question mark operators in action
311+ -- ? -> Does the string exist as a top-level key within the JSON value?
312+ positiveQuery "SELECT ?::jsonb ?? ?" (testObj, "foo" :: Text)
313+ negativeQuery "SELECT ?::jsonb ?? ?" (testObj, "baz" :: Text)
314+ negativeQuery "SELECT ?::jsonb ?? ?" (toJSON numArray, "1" :: Text)
315+ -- ?| -> Do any of these array strings exist as top-level keys?
316+ positiveQuery "SELECT ?::jsonb ??| ?" (testObj, PGArray ["nope","bar","6" :: Text])
317+ negativeQuery "SELECT ?::jsonb ??| ?" (testObj, PGArray ["nope","6" :: Text])
318+ negativeQuery "SELECT ?::jsonb ??| ?" (toJSON numArray, PGArray ["1","2","6" :: Text])
319+ -- ?& -> Do all of these array strings exist as top-level keys?
320+ positiveQuery "SELECT ?::jsonb ??& ?" (testObj, PGArray ["foo","bar","quux" :: Text])
321+ positiveQuery "SELECT ?::jsonb ??& ?" (testObj, PGArray ["foo","bar" :: Text])
322+ negativeQuery "SELECT ?::jsonb ??& ?" (testObj, PGArray ["foo","bar","baz" :: Text])
323+ negativeQuery "SELECT ?::jsonb ??& ?" (toJSON numArray, PGArray ["1","2","3","4","5" :: Text])
324+ -- Format error for 2 question marks, not 4
325+ True <- expectError (isFormatError 2) $
326+ (query conn "SELECT ?::jsonb ?? ?" $ Only testObj :: IO [Only Bool])
327+ return ()
328+ where positiveQuery :: ToRow a => Query -> a -> Assertion
329+ positiveQuery = boolQuery True
330+ negativeQuery :: ToRow a => Query -> a -> Assertion
331+ negativeQuery = boolQuery False
332+ numArray :: [Int]
333+ numArray = [1,2,3,4,5]
334+ boolQuery :: ToRow a => Bool -> Query -> a -> Assertion
335+ boolQuery b t x = do
336+ a <- query conn t x
337+ [Only b] @?= a
338+ testObj = toJSON (Map.fromList [("foo",toJSON (1 :: Int))
339+ ,("bar",String "baz")
340+ ,("quux",toJSON [1 :: Int,2,3,4,5])] :: Map Text Value
341+ )
342+
343+testSavepoint :: TestEnv -> Assertion
344+testSavepoint TestEnv{..} = do
198345 True <- expectError ST.isNoActiveTransactionError $
199346 withSavepoint conn $ return ()
200347
@@ -254,8 +401,8 @@ testSavepoint TestEnv{..} = TestCase $ do
254401
255402 return ()
256403
257−testUnicode :: TestEnv -> Test
258−testUnicode TestEnv{..} = TestCase $ do
404+testUnicode :: TestEnv -> Assertion
405+testUnicode TestEnv{..} = do
259406 let q = Query . T.encodeUtf8 -- Handle encoding ourselves to ensure
260407 -- the table gets created correctly.
261408 let messages = map Only ["привет","мир"] :: [Only Text]
@@ -264,8 +411,8 @@ testUnicode TestEnv{..} = TestCase $ do
264411 messages' <- query_ conn "SELECT сообщение FROM ру́сский"
265412 sort messages @?= sort messages'
266413
267−testValues :: TestEnv -> Test
268−testValues TestEnv{..} = TestCase $ do
414+testValues :: TestEnv -> Assertion
415+testValues TestEnv{..} = do
269416 execute_ conn "CREATE TEMPORARY TABLE values_test (x int, y text)"
270417 test (Values ["int4","text"] [])
271418 test (Values ["int4","text"] [(1,"hello")])
@@ -282,8 +429,8 @@ testValues TestEnv{..} = TestCase $ do
282429 sort vals @?= sort vals'
283430
284431
285−testCopy :: TestEnv -> Test
286−testCopy TestEnv{..} = TestCase $ do
432+testCopy :: TestEnv -> Assertion
433+testCopy TestEnv{..} = do
287434 execute_ conn "CREATE TEMPORARY TABLE copy_test (x int, y text)"
288435 copy_ conn "COPY copy_test FROM STDIN (FORMAT CSV)"
289436 mapM_ (putCopyData conn) copyRows
@@ -300,6 +447,14 @@ testCopy TestEnv{..} = TestCase $ do
300447 -- so that we can issue more queries:
301448 [Only (x::Int)] <- query_ conn "SELECT 2 + 2"
302449 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
303458 where
304459 copyRows = ["1,foo\n"
305460 ,"2,bar\n"]
@@ -310,8 +465,70 @@ testCopy TestEnv{..} = TestCase $ do
310465 CopyOutDone _ -> return rows
311466 CopyOutRow row -> loop (row:rows)
312467
313−testDouble :: TestEnv -> Test
314−testDouble TestEnv{..} = TestCase $ do
468+testCopyFailures :: TestEnv -> TestTree
469+testCopyFailures env = testGroup "Copy failures"
470+ $ map ($ env)
471+ [ testCopyUniqueConstraintError
472+ , testCopyMalformedError
473+ ]
474+
475+goldenTest :: TestName -> IO BL.ByteString -> TestTree
476+goldenTest testName =
477+ goldenVsStringDiff testName diff (resultsDir </> fileName<.>"expected")
478+ where
479+ resultsDir = "test" </> "results"
480+ fileName = map normalize testName
481+ normalize c | not (isAlpha c) = '-'
482+ | otherwise = c
483+ diff ref new = ["diff", "-u", ref, new]
484+
485+-- | Test that we provide a sensible error message on failure
486+testCopyUniqueConstraintError :: TestEnv -> TestTree
487+testCopyUniqueConstraintError TestEnv{..} =
488+ goldenTest "unique constraint violation"
489+ $ handle (\(SomeException exc) -> return $ BL.pack $ show exc) $ do
490+ execute_ conn "CREATE TEMPORARY TABLE copy_unique_constraint_error_test (x int PRIMARY KEY, y text)"
491+ copy_ conn "COPY copy_unique_constraint_error_test FROM STDIN (FORMAT CSV)"
492+ mapM_ (putCopyData conn) copyRows
493+ _n <- putCopyEnd conn
494+ return BL.empty
495+ where
496+ copyRows = ["1,foo\n"
497+ ,"2,bar\n"
498+ ,"1,baz\n"]
499+
500+testCopyMalformedError :: TestEnv -> TestTree
501+testCopyMalformedError TestEnv{..} =
502+ goldenTest "malformed input"
503+ $ handle (\(SomeException exc) -> return $ BL.pack $ show exc) $ do
504+ execute_ conn "CREATE TEMPORARY TABLE copy_malformed_input_error_test (x int PRIMARY KEY, y text)"
505+ copy_ conn "COPY copy_unique_constraint_error_test FROM STDIN (FORMAT CSV)"
506+ mapM_ (putCopyData conn) copyRows
507+ _n <- putCopyEnd conn
508+ return BL.empty
509+ where
510+ copyRows = ["1,foo\n"
511+ ,"2,bar\n"
512+ ,"z,baz\n"]
513+
514+testTimeout :: TestEnv -> Assertion
515+testTimeout TestEnv{..} =
516+ withConn $ \c -> do
517+ start_t <- getCurrentTime
518+ res <- timeout 200000 $ do
519+ withTransaction c $ do
520+ query_ c "SELECT pg_sleep(1)" :: IO [Only ()]
521+ end_t <- getCurrentTime
522+ assertBool "Timeout did not occur" (res == Nothing)
523+#if !defined(mingw32_HOST_OS)
524+-- At the moment, you cannot timely abandon queries with async exceptions on
525+-- Windows.
526+ let d = end_t `diffUTCTime` start_t
527+ assertBool "Timeout didn't work in a timely fashion" (0.1 < d && d < 0.6)
528+#endif
529+
530+testDouble :: TestEnv -> Assertion
531+testDouble TestEnv{..} = do
315532 [Only (x :: Double)] <- query_ conn "SELECT 'NaN'::float8"
316533 assertBool "expected NaN" (isNaN x)
317534 [Only (x :: Double)] <- query_ conn "SELECT 'Infinity'::float8"
@@ -320,6 +537,45 @@ testDouble TestEnv{..} = TestCase $ do
320537 x @?= (-1 / 0)
321538
322539
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+
323579data TestException
324580 = TestException
325581 deriving (Eq, Show, Typeable)
@@ -337,28 +593,56 @@ isUniqueViolation SqlError{..} = sqlState == "23505"
337593isSyntaxError :: SqlError -> Bool
338594isSyntaxError SqlError{..} = sqlState == "42601"
339595
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+ ]
340604------------------------------------------------------------------------
341605
342606-- | Action for connecting to the database that will be used for testing.
343607--
344608-- Note that some tests, such as Notify, use multiple connections, and assume
345609-- that 'testConnect' connects to the same database every time it is called.
346−testConnect :: IO Connection
347−testConnect = connectPostgreSQL ""
610+withTestEnv :: ByteString -> (TestEnv -> IO a) -> IO a
611+withTestEnv connstr cb =
612+ withConn $ \conn -> do
613+ -- currently required for interval to work.
614+ -- we also test that this doesn't interfere with anything else
615+ execute_ conn "SET intervalstyle TO 'iso_8601'"
348616
349−withTestEnv :: (TestEnv -> IO a) -> IO a
350−withTestEnv cb =
351− withConn $ \conn ->
352617 cb TestEnv
353618 { conn = conn
354619 , withConn = withConn
355620 }
356621 where
357− withConn = bracket testConnect close
622+ withConn = bracket (connectPostgreSQL connstr) close
358623
359624main :: IO ()
360−main = do
361− mapM_ (`hSetBuffering` LineBuffering) [stdout, stderr]
362− Counts{cases, tried, errors, failures} <-
363− withTestEnv $ \env -> runTestTT $ TestList $ map ($ env) tests
364− when (cases /= tried || errors /= 0 || failures /= 0) $ exitFailure
625+main = withConnstring $ \connstring -> do
626+ withTestEnv connstring (defaultMain . tests)
627+
628+withConnstring :: (BS8.ByteString -> IO ()) -> IO ()
629+withConnstring kont = do
630+ env <- getEnvironment
631+ case lookup "DATABASE_CONNSTRING" env of
632+ Just s -> kont (BS8.pack (special s))
633+ Nothing -> case lookup "GITHUB_ACTIONS" env of
634+ Just "true" -> kont (BS8.pack gha)
635+ _ -> putStrLn "Set DATABASE_CONNSTRING environment variable"
636+ where
637+ -- https://www.appveyor.com/docs/services-databases/
638+ special "appveyor" = "dbname='TestDb' user='postgres' password='Password12!'"
639+ special "travis" = ""
640+ special s = s
641+
642+ gha = unwords
643+ [ "dbname='postgres'"
644+ , "user='postgres'"
645+ , "password='postgres'"
646+ , "host='postgres'"
647+ , "port=5432"
648+ ]
test/Notify.hs+1−2
@@ -14,9 +14,8 @@ import qualified Data.ByteString as B
1414-- TODO: Test with payload, but only for PostgreSQL >= 9.0
1515-- (when that feature was introduced).
1616
17−testNotify :: TestEnv -> Test
17+testNotify :: TestEnv -> Assertion
1818testNotify TestEnv{..} =
19− TestCase $
2019 withConn $ \conn2 -> do
2120 execute_ conn "LISTEN foo"
2221 execute_ conn "LISTEN bar"
test/Serializable.hs+1−2
@@ -23,9 +23,8 @@ putCounter conn n = do
2323 1 <- execute conn "UPDATE testSerializableCounter SET n=?" (Only n)
2424 return ()
2525
26−testSerializable :: TestEnv -> Test
26+testSerializable :: TestEnv -> Assertion
2727testSerializable TestEnv{..} =
28− TestCase $
2928 withConn $ \conn2 -> do
3029 initCounter conn
3130
test/Time.hs+3−3
@@ -36,15 +36,15 @@ module Time (testTime) where
3636
3737import Common
3838import Control.Monad(forM_, replicateM_)
39−import Data.Time
39+import Data.Time.Compat
4040import Data.ByteString(ByteString)
4141import Database.PostgreSQL.Simple.SqlQQ
4242
4343numTests :: Int
4444numTests = 200
4545
46−testTime :: TestEnv -> Test
47−testTime env@TestEnv{..} = TestCase $ do
46+testTime :: TestEnv -> Assertion
47+testTime env@TestEnv{..} = do
4848 initializeTable env
4949 execute_ conn "SET timezone TO 'UTC'"
5050 checkRoundTrips env "1860-01-01 00:00:00+00"
test/results/malformed-input.expectednew file+4
@@ -0,0 +1,4 @@
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.expectednew file+5
@@ -0,0 +1,5 @@
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/GenTypeInfo.hs+39−25
@@ -21,6 +21,9 @@
2121-- know about. It then constructs a TypeInfo record and stores it in
2222-- a per-connection cache for later use.
2323--
24+-- @
25+-- runghc -itools tools/GenTypeInfo.hs
26+-- @
2427------------------------------------------------------------------------------
2528
2629{-# LANGUAGE OverloadedStrings, QuasiQuotes, ViewPatterns, RecordWildCards #-}
@@ -38,12 +41,10 @@ import Database.PostgreSQL.Simple.FromRow
3841import Database.PostgreSQL.Simple.Ok
3942import Database.PostgreSQL.Simple.Types(Oid(..))
4043import Database.PostgreSQL.Simple.SqlQQ
41−import qualified Data.ByteString.Char8 as B
44+import qualified Data.ByteString.Char8 as B8
4245import Data.ByteString(ByteString)
4346import qualified Data.ByteString.Lazy as L
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
47+import qualified Data.ByteString.Builder as Blaze
4748import Data.String
4849import Data.List ( sort, intersperse )
4950import qualified Data.Map as Map
@@ -69,11 +70,11 @@ data TypeInfo = TypeInfo
6970instance FromRow TypeInfo where
7071 fromRow = TypeInfo <$> field <*> field <*> field <*> field <*> field <*> field
7172
72−type NameMap = Map.Map B.ByteString TypeInfo
73+type NameMap = Map.Map B8.ByteString TypeInfo
7374
7475type OidMap = Map.Map Oid TypeInfo
7576
76−type TypeName = (B.ByteString, B.ByteString)
77+type TypeName = (B8.ByteString, B8.ByteString)
7778
7879type TypeNames = [TypeName]
7980
@@ -197,9 +198,6 @@ int8range
197198_int8range
198199|]
199200
200−instance IsString Blaze.Builder where
201− fromString = Blaze.fromByteString . fromString
202−
203201connectionString = "dbname=postgres"
204202
205203withPostgreSQL = bracket (connectPostgreSQL connectionString) close
@@ -237,7 +235,7 @@ getTypeInfos typnames = withPostgreSQL $ \conn -> do
237235
238236main = do
239237 (oidmap, namemap) <- getTypeInfos typeNames
240− L.writeFile "../src/Database/PostgreSQL/Simple/TypeInfo/Static.hs"
238+ L.writeFile "src/Database/PostgreSQL/Simple/TypeInfo/Static.hs"
241239 (Blaze.toLazyByteString (renderFile oidmap namemap typeNames))
242240
243241
@@ -246,7 +244,7 @@ showOid (Oid n) = show n
246244renderOid :: NameMap -> TypeName -> Blaze.Builder
247245renderOid byName name
248246 = case Map.lookup (pg name) byName of
249− Nothing -> error (B.unpack (pg name))
247+ Nothing -> error (B8.unpack (pg name))
250248 Just (showOid . typoid -> n) -> fromString n
251249 ++ fromString (replicate (4 - length n) ' ')
252250
@@ -264,20 +262,25 @@ renderTypeInfo byOid info name
264262 typelem_hs_name =
265263 case lookup (typname typelem_info) typeNames of
266264 Nothing -> error ( "type not found: "
267− ++ B.unpack( typname typelem_info)
268− ++ " (typelem of " ++ B.unpack (typname info)
265+ ++ B8.unpack( typname typelem_info)
266+ ++ " (typelem of " ++ B8.unpack (typname info)
269267 ++ ")")
270268 Just x -> x
271269 in concat
272270 [ "\n"
273271 , bs (hs name), " :: TypeInfo\n"
274272 , bs (hs name), " = Array {\n"
275− , " typoid = ", fromString (show (typoid info)), ",\n"
276− , " typcategory = '", Blaze.fromChar (typcategory info), "',\n"
277− , " typdelim = '", Blaze.fromChar (typdelim info), "',\n"
273+ , " typoid = ", bs (hs name), "Oid,\n"
274+ , " typcategory = '", bs $ B8.singleton (typcategory info), "',\n"
275+ , " typdelim = '", bs $ B8.singleton (typdelim info), "',\n"
278276 , " typname = \"", bs (typname info), "\",\n"
279277 , " typelem = ", bs typelem_hs_name, "\n"
280278 , " }\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"
281284 ]
282285 | typcategory info == 'R' =
283286 let (Just rngsubtype_oid) = rngsubtype info
@@ -285,31 +288,41 @@ renderTypeInfo byOid info name
285288 rngsubtype_hs_name =
286289 case lookup (typname rngsubtype_info) typeNames of
287290 Nothing -> error ( "type not found: "
288− ++ B.unpack (typname rngsubtype_info)
291+ ++ B8.unpack (typname rngsubtype_info)
289292 ++ " (rngsubtype of "
290− ++ B.unpack (typname info) ++ ")")
293+ ++ B8.unpack (typname info) ++ ")")
291294 Just x -> x
292295 in concat
293296 [ "\n"
294297 , bs (hs name), " :: TypeInfo\n"
295298 , bs (hs name), " = Range {\n"
296− , " typoid = ", fromString (show (typoid info)), ",\n"
297− , " typcategory = '", Blaze.fromChar (typcategory info), "',\n"
298− , " typdelim = '", Blaze.fromChar (typdelim info), "',\n"
299+ , " typoid = ", bs (hs name), "Oid,\n"
300+ , " typcategory = '", bs $ B8.singleton (typcategory info), "',\n"
301+ , " typdelim = '", bs $ B8.singleton (typdelim info), "',\n"
299302 , " typname = \"", bs (typname info), "\",\n"
300303 , " rngsubtype = ", bs rngsubtype_hs_name, "\n"
301304 , " }\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"
302310 ]
303311 | otherwise =
304312 concat
305313 [ "\n"
306314 , bs (hs name), " :: TypeInfo\n"
307315 , bs (hs name), " = Basic {\n"
308− , " typoid = ", fromString (show (typoid info)), ",\n"
309− , " typcategory = '", Blaze.fromChar (typcategory info), "',\n"
310− , " typdelim = '", Blaze.fromChar (typdelim info), "',\n"
316+ , " typoid = ", bs (hs name), "Oid,\n"
317+ , " typcategory = '", bs $ B8.singleton (typcategory info), "',\n"
318+ , " typdelim = '", bs $ B8.singleton (typdelim info), "',\n"
311319 , " typname = \"", bs (typname info), "\"\n"
312320 , " }\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"
313326 ]
314327
315328-- FIXME: add in any names that we need that we didn't specify, (i.e.
@@ -318,7 +331,7 @@ renderTypeInfo byOid info name
318331getNames :: NameMap -> TypeNames -> TypeNames
319332getNames _ x = x
320333
321−bs = Blaze.fromByteString
334+bs = Blaze.byteString
322335
323336pg = fst
324337
@@ -347,6 +360,7 @@ module Database.PostgreSQL.Simple.TypeInfo.Static
347360 ( TypeInfo(..)
348361 , staticTypeInfo
349362|] ++ concat [ " , " ++ bs (hs name) ++ "\n"
363+ ++ " , " ++ bs (hs name) ++ "Oid\n"
350364 | name <- names ] ++ [longstring|
351365 ) where
352366