git.iko.soy/typeable/postgresql-simple
on master help sign in
swap
3ac2949353 ahead, 0 behind
63 files changed+6405−1993
since splitsnapshots
unifiedsplit
.ghci−2 .github/workflows/haskell-ci.yml+256 .github/workflows/simple.yml+58 .gitignore+8−1 CHANGES−348 CHANGES.md+746 CONTRIBUTING.md+13 CONTRIBUTORS+17 README.md+4 bench/Select.hs+32 cabal.haskell-ci+5 cabal.project+4 cabal.project.local.win+4 postgresql-simple.cabal+153−94 sdist.sh+25 src/Database/PostgreSQL/Simple.hs+164−183 src/Database/PostgreSQL/Simple/Arrays.hs+3−3 src/Database/PostgreSQL/Simple/BuiltinTypes.hs−420 src/Database/PostgreSQL/Simple/Compat.hs+17−21 src/Database/PostgreSQL/Simple/Copy.hs+46−6 src/Database/PostgreSQL/Simple/Cursor.hs+98 src/Database/PostgreSQL/Simple/Errors.hs+16−12 src/Database/PostgreSQL/Simple/FromField.hs+216−98 src/Database/PostgreSQL/Simple/FromRow.hs+239−6 src/Database/PostgreSQL/Simple/HStore.hs+3−2 src/Database/PostgreSQL/Simple/HStore/Implementation.hs+27−21 src/Database/PostgreSQL/Simple/HStore/Internal.hs−2 src/Database/PostgreSQL/Simple/Internal.hs+306−29 src/Database/PostgreSQL/Simple/Internal/PQResultUtils.hs+123 src/Database/PostgreSQL/Simple/LargeObjects.hs+2−2 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+317 src/Database/PostgreSQL/Simple/SqlQQ.hs+17−14 src/Database/PostgreSQL/Simple/Time.hs+216−50 src/Database/PostgreSQL/Simple/Time/Implementation.hs+51−157 src/Database/PostgreSQL/Simple/Time/Internal.hs+3 src/Database/PostgreSQL/Simple/Time/Internal/Parser.hs+204 src/Database/PostgreSQL/Simple/Time/Internal/Printer.hs+135 src/Database/PostgreSQL/Simple/ToField.hs+89−54 src/Database/PostgreSQL/Simple/ToField.hs-boot+1−1 src/Database/PostgreSQL/Simple/ToRow.hs+128−1 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+1377−73 src/Database/PostgreSQL/Simple/Types.hs+57−33 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+381−52 test/Notify.hs+1−2 test/Serializable.hs+1−2 test/Time.hs+63−15 test/results/malformed-input.expected+4 test/results/unique-constraint-violation.expected+5 tools/GenBuiltinTypes.hs−182 tools/GenTypeInfo.hs+170−39
.ghcideleted−2
@@ -1,2 +0,0 @@
1−:set -isrc
2−:set Wall
.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+8−1
@@ -7,4 +7,11 @@ dist/
77*.o
88\#*\#
99.#*
10−postgresql-simple-*.tar.gz
10+/CHANGELOG.md
11+.cabal-sandbox/
12+.stack-work/
13+cabal.sandbox.config
14+/dist-newstyle
15+.ghc.environment.*
16+cabal.project.local
17+dump-core
CHANGESdeleted−348
@@ -1,348 +0,0 @@
1−Version 0.4.2.1 (2014-03-27)
2− * Fixed bug in Values syntax generation
3−
4− * Improved documentation, including examples of multi-row update,
5− a better example for Values, documenting the inaccuracies in reading
6− floating point numbers from the database, and the IsString instance
7− for QualifiedIdentifier.
8−
9−Version 0.4.2.0 (2014-03-22)
10− * Added ToField and FromField instances for the scientific package
11−
12− * Changed the Identifier and QualifiedIdentifier to use Text in
13− order to avoid encoding errors. Technically this requires a
14− major verson bump, but let's pretend 0.4.1.0 didn't happen.
15−
16− * Removed non-exhaustive cases in the ToField instance for Values,
17− and tweaked error messages.
18−
19−Version 0.4.1.0 (2014-03-22)
20− * Fixed the parsing of arrays containing null values, courtesy of
21− Francesco Mazzoli
22−
23− * Added support for properly escaped identifiers, courtesy of
24− Tobias Florek. See the new Identifier and QualifiedIdentifier
25− types inside Database.PostgreSQL.Simple.Types.
26−
27− * Added support for parameterized VALUES expressions. This is
28− more general than executeMany and returning. See the
29− Database.PostgreSQL.Simple.Types.Values data type.
30−
31−Version 0.4.0.2 (2014-01-12)
32− * Tweaked C preprocessor directive to be more portable
33−
34− * Tweaked testsuite for compatibility with aeson-0.7
35−
36−Version 0.4.0.1 (2013-12-21)
37− * Relaxed dependency on aeson to >= 0.6
38−
39− * Update the documentation of `fromField`
40−
41−Version 0.4.0.0 (2013-12-21)
42− * Changed the calling code of `fromField` so that it always sends
43− a copy of the raw data. This should be a small but significant
44− performance bump for most people most of the time; however it
45− may slow down retrieval of large values not converted directly
46− to ByteString, such as large json, hstore, and array values.
47− See commit 8635f8 for more information.
48−
49− * Added the PGArray type. Thanks to Joey Adams for the suggestion
50−
51− * Fixed JSON decoding, which was almost entirely broken up until now,
52− due to bugs in the version of aeson currently available on Hackage.
53− Thanks to Amit Levy for the report.
54−
55− * Added FromField instances for IORef, MVar, and IOVector.
56−
57−Version 0.3.10.0 (2013-12-17)
58− * Added the queryWith function, courtesy of Leonid Onokhov
59−
60− * Added the Default type, for representing postgresql's default values
61−
62−Version 0.3.9.1 (2013-10-28)
63− * Removed dependency on hashable
64−
65−Version 0.3.9.0 (2013-10-27)
66− * Added FromField and ToField instances for the `uuid` package,
67− courtesy of Bas van Dijk.
68−
69− * Added instance FromRow (Maybe a) for most pre-packaged FromRow
70− instances. See issue #64 for some discussion.
71−
72− * Added the fromBinary, fromHStoreMap, and fromHStoreList newtype
73− unwrapper functions, courtesy of Bas van Dijk.
74−
75−Version 0.3.8.0 (2013-10-11)
76− * Fixed the example code in `FromField`, thanks to Adam Bergmark.
77−
78− * Added `Notification.getBackendPID`.
79−
80−Version 0.3.7.1 (2013-09-12)
81− * Relaxed the dependency on bytestring-0.10 back to bytestring-0.9,
82− courtesy of Michael Snoyman
83−
84−Version 0.3.7.0 (2013-09-11)
85− * Added `aeson` as a dependency.
86−
87− * Added ToField and FromField instances for aeson's JSON.Value type,
88− courtesy of Bas van Dijk.
89−
90− * Added toJSONField and fromJSONField helper functions for declaring
91− FromField/ToField JSON instances to other Haskell types, courtesy
92− of Bas van Dijk.
93−
94− * Added a FromField instance for (), corresponding to postgresql's void
95− type.
96−
97− * Added liftConversion and liftRowParser functions to the Internal
98− module, for lifting IO actions into the respective monads.
99−
100− * The SqlError predicates available in the Transaction module are now
101− also exported from the Errors module.
102−
103− * Various documentation fixes.
104−
105−Version 0.3.6.0 (2013-08-19)
106− * Added the json type to BuiltinTypes and TypeInfo.Static, courtesy of
107− Manuel Gómez.
108−
109− * Removed the remaining internal dependencies on BuiltinTypes from
110− FromField. Added the TypeInfo.Macro module as a result.
111−
112− * Deprecated the BuiltinTypes module, which will be removed several
113− months from now. Fixed the example code in FromField to reflect
114− this change.
115−
116−Version 0.3.5.0 (2013-08-09)
117− * Added an FromRow instance for Vector, semantically identical to the
118− existing FromRow instance for [], courtesy of Doug Beardsley
119−
120− * Reworked the documentation for the Copy module, and tweaked the
121− documentation for the LargeObjects module.
122−
123−Version 0.3.4.0 (2013-07-23)
124− * Added direct support for COPY IN and COPY OUT, without having
125− to use raw postgresql-libpq calls and postgresql-simple's Internal
126− module.
127−
128− * Changed `getNotification` so that it throws a IOError (resource vanished)
129− exception instead of an ErrorCall exception when it fails to fetch
130− the connection's file descriptor from libpq.
131−
132−Version 0.3.3.2 (2013-06-18)
133− * Optimized the definition of `mconcat` in the Monoid instance for
134− the Query type, courtesy of Joey Adams.
135−
136−Version 0.3.3.1 (2013-06-06)
137− * `getNotification` now works on Windows, albeit using a one-second
138− polling loop, courtesy of Joey Adams.
139−
140−Version 0.3.3.0 (2013-05-29)
141− * Fixed two issues with the fold operator: fold would raise the wrong
142− exception, and gave the database cursor a static name preventing
143− folds from being nested. Thanks to Joey Adams for his
144− work on these issues.
145−
146−Version 0.3.2.0 (2013-05-20)
147− * Added a savepoint abstraction to the Transaction module, courtesy
148− of Joey Adams
149−
150−Version 0.3.1.2 (2013-04-29)
151− * Fixed hstore parser to not unnecessarily reverse the key-value pairs
152−
153−Version 0.3.1.1 (2013-04-29)
154− * Fixed hstore parser to recognize empty hstores, courtesy of Simon
155− Meier
156−
157−Version 0.3.1.0 (2013-04-26)
158− * Added support for Range and Composite types to the TypeInfo system.
159−
160− * Added support for hstore types in the Simple.HStore module.
161−
162− * Improved documentation of the FromField module.
163−
164−Version 0.3.0.1 (2013-03-26)
165− * A large chunk of the documentation inside the FromField module had
166− silently failed to render in Haddock.
167−
168−Version 0.3.0.0 (2013-03-25)
169− * Added support for PostgreSQL's Array Types. Thanks to Jason Dusek
170− for his work on this feature.
171−
172− * Added a brand new TypeInfo system that gives FromField instances
173− convenient and efficient access to the pg_type metatable. This
174− replaced the older typename cache, and was neccesary to properly
175− support postgres array types. Thanks to Bas van Dijk for his
176− work on this feature.
177−
178− * Changed the type of the `fromField` and `fromRow` methods to allow
179− a restricted set of IO actions, and stopped pre-calculating the type
180− name of every column. As a result, the type of the `typename`
181− operator changed from `Field -> ByteString` to
182− `Field -> Conversion ByteString`, where Conversion is the new monad
183− that conversion computations run inside.
184−
185− * Improved the documentation of the FromField module.
186−
187− * Added the Database.PostgreSQL.Simple.Errors module, which offers
188− some predicates and functions for interpreting SqlError values, courtesy
189− of Leonid Onokhov.
190−
191− * Added a the name of a column and the associated table's object identifier
192− to ResultError exceptions, courtesy of Jeff Chu.
193−
194− * Moved most of the more detailed transaction operators into the
195− Database.PostgreSQL.Simple.Transaction module.
196−
197− * Changed withTransactionModeRetry to accept a predicate of which
198− SqlErrors to retry, due to the fact that serialization errors can
199− sometimes manifest themselves as constraint violations. Thanks
200− to Oliver Charles for pointing this out and implementing the change.
201−
202− * Added simple tests of the fold operator, thanks to Joey Adams.
203−
204− * Added simple tests of the array conversion code.
205−
206− * Added recognition of -- comments in the quasiquoter, which are
207− now stripped out.
208−
209−
210−Version 0.2.4.1 (2012-08-29)
211− * Fixed the documentation of `In`. Thanks to rekado and dstcruz for
212− pointing this out.
213−
214−Version 0.2.4.0 (2012-08-23)
215− * Added the `withTransactionSerializable` and `withTransactionModeRetry`
216− operators, thanks to Joey Adams.
217−
218−Version 0.2.3.0 (2012-08-09)
219− * Added the `returning` operator, thanks to Jason Dusek
220−
221−Version 0.2.2.0 (2012-07-26)
222− * Added a ToRow instance for the (:.) type, courtesy of Leonid Onokhov
223−
224− * Added the type oid for PostgreSQL's `uuid` type to BuiltinTypes
225−
226−Version 0.2.1.0 (2012-07-23)
227− * Added the FromRow.fieldWith operator, thanks to Leonid Onokhov
228−
229− * Added a type synonym for FieldParser
230−
231−Version 0.2.0.1 (2012-06-21)
232− * Fixed a compatibility problem with PostgreSQL 8.1, which does not allow
233− clients to set their own value for `standard_conforming_strings`. This
234− connection variable is still set to `on` for PostgreSQL 8.2 and later.
235−
236−Version 0.2: (2012-06-19)
237− * Removed the conversion from `timestamp` to `UTCTime`. Some code will be
238− broken even though it will still compile.
239−
240− * Renamed a number of data constructors, mostly in the BuiltinTypes module.
241−
242− * Exported ToRow/FromRow from Database.PostgreSQL.Simple
243−
244−
245−Version 0.1.4.3: (2012-06-10)
246− * Fix language extensions for compatibility with GHC 7.0
247−
248−Version 0.1.4.2: (2012-06-10)
249− * Fix a wayward dependency on Text.
250−
251−Version 0.1.4.1: (2012-06-10)
252− * Added support for timezones with minutes in their UTC offset.
253−
254−Version 0.1.4: (2012-06-10)
255− * Removed pcre-light dependency, courtesy of Joey Adams.
256−
257− * Reworked support for the Time types.
258−
259− * The conversion from PostgreSQL's `timestamp` (without time zone) type
260− to Haskell's `UTCTime` type is deprecated and will be removed in 0.2.
261−
262− * `Data.Time.LocalTime` now has `FromField`/`ToField` instances. It is
263− now the preferred way of dealing with `timestamp` (without time zone).
264−
265− * `Database.PostgreSQL.Simple.Time` is a new module that offers types
266− that accomodate PostgreSQL's infinities.
267−
268− * All time-related `FromField`/`ToField` instances are now based on new,
269− higher-speed parsers and printers instead of those provided by the
270− time package included in GHC.
271−
272− * Planned breaking changes for 0.2:
273−
274− * Removing the conversion from `timestamp` to `UTCTime`.
275−
276− * Renaming some of the type names in `BuiltinTypes`.
277−
278−
279−Version 0.1.3: (2012-05-30)
280− * Made ZonedTime an instance of FromField and ToField
281−
282− * Added getNotificationNonBlocking
283−
284−
285−Version 0.1.2: (2012-05-09)
286− * Switched to libpq-based escaping for bytea types; Binary now works with
287− PostgreSQL 8 courtesy of Joey Adams.
288−
289− * postgresql-simple now sets standard_conforming_strings to "on". This
290− per-connection variable is initialized according to the server
291− configuration, which defaults to "off" for PostgreSQL < 9, and "on"
292− for PostgreSQL >= 9. You may need to adjust any string literals in
293− your SQL queries, or set the variable yourself.
294−
295− * Exported (:.) from Database.PostgreSQL.Simple
296−
297−
298−Version 0.1.1: (2012-05-06)
299− * Added some preliminary documentation for the Ok, Notification, and
300− LargeObjects modules
301−
302− * Implemented the `fail` method for the monad instance for `Ok`.
303−
304− * Fixed a bug relating to handling the transaction level
305−
306−
307−Version 0.1: (2012-05-04)
308− * Renamed several modules, typeclasses, and functions:
309−
310− QueryParams (renderParams) -> ToRow (toRow)
311− QueryResults (convertResults) -> FromRow (fromRow)
312− Param (render) -> ToField (toField)
313− Result (convert) -> FromField (fromField)
314−
315− * Added the `Database.PostgreSQL.Simple.Ok` module, a variation of
316− `Either SomeException` that has an instance for `Alternative` and also
317− uses a list of exceptions to track the ways it has failed.
318−
319− * Changed the return type of `fromField` and `fromRow` from
320− `Either SomeException` to `Ok`.
321−
322− * Thanks to suggestions from Ozgun Ataman, the `FromRow` typeclass has been
323− massively improved. The result is simpler definitions and better
324− compositionality. Also, user-defined instances need not be to be
325− concerned about forcing the converted results to WHNF. Here is an
326− example comparing the old to the new:
327−
328− instance (Result a, Result b) => QueryResults (a,b) where
329− convertResults [fa,fb] [va,vb] = do
330− !a <- convert fa va
331− !b <- convert fb vb
332− return (a,b)
333− convertResults fs vs = convertError fs vs 2
334−
335− instance (FromField a, FromField b) => FromRow (a,b) where
336− fromRow = (,) <$> field <*> field
337−
338− * Added `(:.)`, a pair that allows one to compose `FromRow` instances:
339−
340− instance (FromRow a, FromRow b) => FromRow (a :. b) where
341− fromRow = (:.) <$> fromRow <*> fromRow
342−
343− * Moved the contents `Field` module into the `FromField` module.
344−
345− * Removed the `RawResult` type.
346−
347− * Added `DefaultIsolationLevel` as a distinct `IsolationLevel` option
348− and `DefaultReadWriteMode` as a distinct `ReadWriteMode`.
CHANGES.mdnew file+746
@@ -0,0 +1,746 @@
1+### Version 0.7.0.0 (2023-07-31)
2+
3+ * Remove Eq Null instance. (Future `base` may break it, we remove it profilacticly).
4+ * Use `postgresql-libpq >=0.10.0.0`. It includes critical fixes,
5+ by using `postgresql-simple >=0.7` you won't get older `postgresql-libpq`.
6+ * Drop support for GHC prior 8.6
7+ * Added a class for `postgresql-simple` exceptions: `SomePostgreSqlException`.
8+ This allows to catch all `postgresql-simple` exceptions at once.
9+ (c.f. `AsyncException` in `base).
10+
11+### Version 0.6.5.1 (2023-07-09)
12+
13+ * Support `aeson-2.2.0.0`
14+
15+### Version 0.6.5 (2022-10-30)
16+
17+ * Add `withConnect`
18+
19+### Version 0.6.4 (2021-01-06)
20+
21+ * Add foldCopyData helper function
22+ Thanks to Sebastián Estrella for the implementation
23+ https://github.com/haskellari/postgresql-simple/pull/56
24+ * Implement support for postgresql 'interval' type
25+ Thanks to Andre Marques Lee for the implementation
26+ https://github.com/haskellari/postgresql-simple/pull/60
27+ * Depend on `time-compat` to provide uniform `time` related interface.
28+
29+### Version 0.6.3 (2020-11-15)
30+
31+ * Add `fromFieldJSONByteString`
32+ Thanks to tomjaguarpaw for the implementation
33+ https://github.com/haskellari/postgresql-simple/pull/47
34+ * Add `attoFieldParser`
35+ Thanks to Victor Nawothnig for the implementation
36+ https://github.com/haskellari/postgresql-simple/pull/45
37+ * Add `Identity` and `Const` instance
38+ Thanks to Cary Robbins for the implementation
39+ https://github.com/haskellari/postgresql-simple/pull/46
40+ * Add `withTransactionModeRetry'`, a variant of `withTransactionModeRetry`
41+ for all exception types.
42+ Thanks to Elliot Cameron for the implementation
43+ https://github.com/haskellari/postgresql-simple/pull/42
44+ * Fix spurious aborts when retrying transactions
45+ Thanks to Elliot Cameron for the implementation
46+ https://github.com/haskellari/postgresql-simple/pull/34
47+ * Add `Database.PostgreSQL.Simple.Newtypes` module
48+ with `Aeson` newtype.
49+ https://github.com/haskellari/postgresql-simple/pull/55
50+
51+### Version 0.6.2 (2019-04-26)
52+
53+ * Define `MonadFail Ok`.
54+
55+### Version 0.6.1 (2019-03-04)
56+
57+ * Escape double '??' to a literal '?
58+ Thanks to Felix Paulusma for the implementation.
59+ https://github.com/phadej/postgresql-simple/pull/5
60+
61+ * Mention GHC Generics support in the documentation.
62+ Thanks to Gabriel Gonzalez for the implementation.
63+ https://github.com/phadej/postgresql-simple/pull/6
64+
65+ * Better error message for "Query resulted in a command response
66+ Thanks to Max Amanshauser for the implementation.
67+ https://github.com/phadej/postgresql-simple/pull/7
68+
69+ * fromJSONField: Include JSONPath on JSON parse errors
70+ Thanks to Simon Hengel for the implementation.
71+ https://github.com/phadej/postgresql-simple/pull/2
72+
73+ * No TH in implementation
74+ https://github.com/phadej/postgresql-simple/pull/4
75+
76+### Version 0.6 (2018-10-16)
77+
78+ * *Breaking change*: Use `Only` package's `Only` for a common 1-tuple.
79+
80+ Consider a downstream library depending already both on
81+ `Only` and `postgresql-simple` package. This library my define
82+ a `MyClass` with instances for `Only.Only` and `PostgreSQL.Only`.
83+ As now these types are the same, a library would break.
84+ Therefore I consider "merging" types a breaking change.
85+
86+ There are two ways for adopting this change in that scenario:
87+
88+ - Either CPP-guard `PostgreSQL.Only` instance with
89+
90+ ```haskell
91+ #if !MIN_VERSION_postgresql_simple(0,6,0)
92+ instance MyClass (PostgreSQL.Only a) where ...
93+ #endif
94+ ```
95+
96+ - or simply remove it and add `postgresql-simple >=0.6` lower bound,
97+ making sure that there's only single `Only`.
98+
99+ * Add `ToField` instances for case-insensitive strict and lazy text.
100+ Thanks to Max Tagher for the implementation.
101+ https://github.com/lpsmith/postgresql-simple/pull/232
102+
103+ * Add support to CockroachDB.
104+ Thanks to Georte Steel.
105+ https://github.com/lpsmith/postgresql-simple/pull/245
106+
107+ * Add Generic ConnectInfo instance
108+ Thanks to Dmitry Dzhus.
109+ https://github.com/lpsmith/postgresql-simple/pull/235
110+
111+ * Add `fromFieldRange :: Typeable a => FieldParser a -> FieldParser (PGRange a)`
112+ https://github.com/lpsmith/postgresql-simple/pull/221
113+
114+ * Add `fromFieldJSONByteString :: FieldParser ByteString`
115+ https://github.com/lpsmith/postgresql-simple/pull/222/files
116+
117+ * Fix off-by-one error in year builder.
118+ Thanks to Nathan Ferris Hunter.
119+ https://github.com/lpsmith/postgresql-simple/pull/230
120+
121+ * Extend ToRow and FromRow to tuples of size 18
122+ Thanks to Bardur Arantsson.
123+ https://github.com/lpsmith/postgresql-simple/pull/229
124+
125+ * Add `Vector` and `Vector.Unboxed` `query` variants.
126+ These are more memory efficient
127+ (especially, if you anyway will convert to some vector)
128+ https://github.com/phadej/1
129+
130+ * Documentation improvements
131+ https://github.com/lpsmith/postgresql-simple/pull/227
132+ https://github.com/lpsmith/postgresql-simple/pull/236
133+
134+### Version 0.5.4.0 (2018-05-23)
135+ * Support GHC-8.4 (Semigroup/Monoid)
136+
137+### Version 0.5.3.0 (2017-05-15)
138+ * Refactored some rudimentary cursor handling code out of the
139+ implementation of the fold operators, into a new
140+ `Database.PostgreSQL.Simple.Cursor` module, thanks to Bardur Arantsson.
141+
142+ * Made the `FromField` instance for `Char` compatible with
143+ postgresql's `bpchar` type. Thanks to Ivan Lazar Miljenovic for
144+ reporting the issue.
145+
146+ * Added `Show` and `Eq` instances for `Notification`, thanks to
147+ Matvey Aksenov.
148+
149+ * Fixed some example code, thanks to Matvey Aksenov.
150+
151+ * Fixed a problem with using `conversionError` to throw exceptions
152+ of type `SomeException`. Previously, the exception would be
153+ wrapped in a second `SomeException` dynamic constructor which
154+ would cause normal GHC typecase idioms over `SomeException` to fail.
155+
156+### Version 0.5.2.1 (2016-06-29)
157+ * Bumped the lower bound for `base` to 4.6. Thanks to Herbert
158+ Valerio Riedel for reporting the issue.
159+
160+ * Added an `Eq` instance for `SqlError`, thanks to Chris Allen
161+
162+ * Fixed a bug where a all-caps `"NULL"` text value inside a
163+ postgresql array would get parsed as the SQL null value. Thanks
164+ goes to Edgar Gomes and Silk for finding and fixing this mistake.
165+
166+ * Modified `withTransaction` and friends to ignore `IOError`s when
167+ attempting to roll back the transaction. This fixes a buggy
168+ interaction between `withTransaction` and async exceptions (e.g.
169+ `System.Timeout`) on unix platforms. Thanks goes to Erik
170+ Hesselink and Silk for providing the test case that exposed this
171+ issue.
172+
173+ * Added the `testTimeout` regression test for the problem above.
174+
175+### Version 0.5.2.0 (2016-05-25)
176+ * Significantly improved the error reporting from
177+ `Copy.putCopyData`, thanks to Ben Gamari.
178+
179+ * Moved the test suite to use `tasty`, with a big thanks
180+ to Ben Gamari.
181+
182+ * Added `FromField.optionalField`, and updated the documentation
183+ of `FromField.fromJSONField`, as inspired by an email conversation
184+ with Ian Wagner.
185+
186+ * Updated all links in the haddocks to use https, and added a link
187+ to the documentation of `connectPostgreSQL`.
188+
189+ * Added a truncated changelog to the source distribution.
190+
191+### Version 0.5.1.3 (2016-04-30)
192+ * Implemented the Monad of No Return proposal, future-proofing
193+ postgresql-simple against future releases of GHC.
194+
195+ * Fixed a rare and usually benign race condition where
196+ `getNotification` could end up waiting on a newly reallocated
197+ file descriptor index, potentially leading to deadlock if the
198+ descriptor does not become readable promptly. This fix only
199+ applies to GHC 7.8 or later, as it depends on `threadWaitReadSTM`.
200+
201+ * Tweaked the time parsers to accept times of day of the form `hh:mm`,
202+ omitting seconds, following changes made to aeson.
203+
204+ * Updated the documentation of the `In` type to point out a gotcha
205+ when using the SQL fragment `... NOT IN ?` with `In []`. Thanks
206+ goes to Simon Michael and Dan Haraj for bringing this issue to
207+ my attention.
208+
209+### Version 0.5.1.2 (2015-12-14)
210+ * The syntax generated for empty arrays was changed so that
211+ postgresql's type inference would work better, thanks to
212+ Amit Levy.
213+
214+ * Further revision and expansion of the new Time documentation.
215+
216+### Version 0.5.1.1 (2015-12-02)
217+ * This is a documentation-only release
218+
219+ * The documentation of the `Time` module has been completely
220+ rewritten, and is far longer and more informative. It contains
221+ a brief overview of civil time, the semantics of postgresql's
222+ time types, and their relation to Haskell's time types via
223+ postgresql-simple.
224+
225+ * The documentation of `connectPostgreSQL` has been modified to
226+ mention the effects of environment variables on the connection
227+ string parameters.
228+
229+ * The documentation of `HStore.Internal` has been unhidden from
230+ haddock.
231+
232+ * A typo in example code was fixed courtesy of Levi Notik.
233+
234+### Version 0.5.1.0 (2015-10-22)
235+ * Optimized the implementation of the streaming operators to avoid
236+ creating intermediate lists of rows, thanks to Timo von Holtz.
237+
238+ * Added default instances for `ToRow` and `FromRow` that depend on
239+ Generics, thanks to Alexey Khudyakov.
240+
241+ * Fixed support for bytestring-0.9 and GHC 7.4.
242+
243+### Version 0.5.0.1 (2015-09-21)
244+ * Fixed a bug when printing a `ZonedTime` with a negative offset
245+ that is not a whole number of hours.
246+
247+### Version 0.5.0.0 (2015-09-19)
248+ * Removed the deprecated `BuiltinTypes` module.
249+
250+ * Modified the SQL quasiquoter so that it returns a `Query`, not
251+ an overloaded string, and so that the `OverloadedStrings` language
252+ extension is no longer necessary, thanks to Mike Ledger.
253+
254+ * Moved away from `blaze-builder` in favor of `bytestring-builder`. This
255+ shouldn't affect very many people, but does reduce the transitive
256+ dependencies.
257+
258+ * Rewrote the timestamp printers to use the new `Prim`
259+ infrastructure in `bytestring-builder`. The new printers should
260+ be a fair bit faster.
261+
262+ * Added support for exclusion violations to the `ConstraintViolation`
263+ type in the Errors module, thanks to João Cristóvão.
264+
265+ * Moved away from the `uuid` package in favor of the `uuid-types` package,
266+ thanks to Bardur Arantsson. This shouldn't affect anybody, but does
267+ reduce the transitive dependencies.
268+
269+ * Postgresql-simple now explicitly assumes the UTF8 character encoding
270+ for communication between the client and server. All database encodings
271+ support UTF8 except for Mule Internal Code, the Multilingual
272+ Extensions for Emacs. An exception should be raised upon
273+ connecting to a database by the backend if the backend cannot
274+ accommodate this requirement.
275+
276+ * Added `Eq` and `Typeable` instances for `Connection`.
277+
278+ * Added the `foldWith`, `forEachWith`, and `returningWith` families
279+ of functions courtesy of Travis Staton.
280+
281+ * Support for Ranged types, with thanks to Leonid Onokhov for his
282+ contributions.
283+
284+ * The `FromField` instance for JSON now allows for top-level values that
285+ are not objects or arrays, thanks to Sam Rijs.
286+
287+ * The timestamp parsers have been replaced with those now in Aeson.
288+ Janne Hellsten adapted the old parsers from postgresql-simple for
289+ inclusion in Aeson; Bryan O'Sullivan rewrote those parsers to be
290+ faster, with some tweaks contributed by myself. And now to
291+ bring the effort full circle, the result has been brought back to
292+ postgresql-simple, with some adaptations.
293+
294+ * Fixed a bug in the typeinfo system where postgresql's `_record` type
295+ was being reported as a basic type and not an array type. Thanks to
296+ Nickolay Kolev for helping to expose this issue.
297+
298+ * Fixed a bug with the `typeInfo` operator, thanks to Timmy Tofu. In the
299+ case of parsing subfields of arrays and composites, it would fetch the
300+ `TypeInfo` of the array or composite type and not the subtype.
301+
302+### Version 0.4.10.0 (2015-02-26)
303+ * Added a blurb about SSL/TLS in the documentation for connectPostgreSQL
304+
305+ * Moved some functions into the Internal module, courtesy of Aleksey
306+ Uimanov.
307+
308+### Version 0.4.9.0 (2014-12-27)
309+ * Made the fromField method for PGArray available as pgArrayFieldParser,
310+ outside of the typeclass courtesy of Tom Ellis.
311+
312+ * Fixed a missing OverloadedStrings pragma in the documentation of SqlQQ.
313+
314+ * Fixed deprecation warnings, courtesy of Simon Hengel.
315+
316+### Version 0.4.8.0 (2014-11-24)
317+ * Added support for postgresql's citext type extension via the
318+ case-insensitive package.
319+
320+ * Added the function parseHStoreList to the HStore module.
321+
322+### Version 0.4.7.0 (2014-10-27)
323+ * Added support for very old timestamps to UTCTime. Depending on time
324+ zone, very old timestamps can be returned with a offset from UTC that
325+ contains seconds.
326+
327+ All timezones in the TZ database moved to a time standard offset an
328+ integer number of minutes from UTC before 1973, almost all locations
329+ moved before 1938, and a solid majority moved before 1921.
330+
331+ ZonedTime assumes offsets are a whole number of minutes, and thus the
332+ conversion to ZonedTime does not support these timestamps and will
333+ still throw a conversion error.
334+
335+ Note that PostgreSQL's "timestamp with time zone" (or "timestamptz")
336+ type is nearly universally misunderstood. For an explanation, see:
337+
338+ https://github.com/lpsmith/postgresql-simple/issues/69
339+
340+ Thanks to Michael Snoyman for his assistance with this issue.
341+
342+### Version 0.4.6.0 (2014-10-07)
343+ * Added an instance ToField NominalDiffTime.
344+
345+### Version 0.4.5.0 (2014-09-26)
346+ * Added support for retrieving NaN and ±Infinity floating point values
347+ from postgres to the FromField instances for Float, Double, and Rational.
348+ The instance for Scientific is unchanged due to the fact it has no
349+ way of representing these special values. Thanks goes to Tom Nielsen
350+ for reporting the issue.
351+
352+### Version 0.4.4.1 (2014-09-07)
353+ * Fixed a rather serious bug that prevented the COPY module from working
354+ at all on unix clients since version 0.4.3.0. Thanks goes to
355+ Dmitry Dzhus for reporting the issue.
356+
357+ * Added a regression test for the COPY module to the test suite.
358+
359+### Version 0.4.4.0 (2014-08-26)
360+ * Added the jsonb type debuting in PostgreSQL 9.4 to the TypeInfo.Static
361+ and Builtin tables, and extended the out-of-box json instances to
362+ be compatible with the new type. Thanks to Tobias Florek for the
363+ patch.
364+
365+ * Ported some expanded documentation from mysql-simple, and fixed
366+ a documentation typo.
367+
368+### Version 0.4.3.0 (2014-07-10)
369+ * connect and exec now use libpq asynchronously on non-Windows platforms.
370+ This means we are using threadWaitRead and threadWaitWrite to
371+ have GHC's IO manager schedule non-blocking C calls to libpq,
372+ instead of using blocking C calls and having the OS kernel do the
373+ scheduling. Among other things, this now means that System.Timeout
374+ will work with connect and exec on unix platforms.
375+
376+ * connect and exec now throw IOErrors instead of SQLErrors in
377+ some cases. The intention is for SQLErrors to represent
378+ an error returned by the server, and to use IOErrors for errors
379+ that originate from client-side code. However, this goal
380+ isn't perfectly achieved as of yet.
381+
382+### Version 0.4.2.3 (2014-06-04)
383+ * This is strictly a documentation release, with no code changes.
384+
385+ * Fixed several documentation typos, thanks to Chris Allen and remdezx.
386+
387+ * Expanded the documentation of connectPostgreSQL, including a short
388+ overview of common use cases and two new links to the official Postgres
389+ documentation about the authentication process.
390+
391+ * De-emphasized connect and ConnectInfo in favor of connectPostgreSQL.
392+
393+### Version 0.4.2.2 (2014-05-15)
394+ * Fixed compatibility with scientific-0.3.\*, thanks to Adam Bergmark
395+
396+ * Improved documentation of the FromField module, as well as the fold,
397+ foldWithOptions, executeMany, and returning operators.
398+
399+### Version 0.4.2.1 (2014-03-27)
400+ * Fixed bug in Values syntax generation
401+
402+ * Improved documentation, including examples of multi-row update,
403+ a better example for Values, documenting the inaccuracies in reading
404+ floating point numbers from the database, and the IsString instance
405+ for QualifiedIdentifier.
406+
407+### Version 0.4.2.0 (2014-03-22)
408+ * Added ToField and FromField instances for the scientific package
409+
410+ * Changed the Identifier and QualifiedIdentifier to use Text in
411+ order to avoid encoding errors. Technically this requires a
412+ major version bump, but let's pretend 0.4.1.0 didn't happen.
413+
414+ * Removed non-exhaustive cases in the ToField instance for Values,
415+ and tweaked error messages.
416+
417+### Version 0.4.1.0 (2014-03-22)
418+ * Fixed the parsing of arrays containing null values, courtesy of
419+ Francesco Mazzoli
420+
421+ * Added support for properly escaped identifiers, courtesy of
422+ Tobias Florek. See the new Identifier and QualifiedIdentifier
423+ types inside Database.PostgreSQL.Simple.Types.
424+
425+ * Added support for parameterized VALUES expressions. This is
426+ more general than executeMany and returning. See the
427+ Database.PostgreSQL.Simple.Types.Values data type.
428+
429+### Version 0.4.0.2 (2014-01-12)
430+ * Tweaked C preprocessor directive to be more portable
431+
432+ * Tweaked testsuite for compatibility with aeson-0.7
433+
434+### Version 0.4.0.1 (2013-12-21)
435+ * Relaxed dependency on aeson to >= 0.6
436+
437+ * Update the documentation of `fromField`
438+
439+### Version 0.4.0.0 (2013-12-21)
440+ * Changed the calling code of `fromField` so that it always sends
441+ a copy of the raw data. This should be a small but significant
442+ performance bump for most people most of the time; however it
443+ may slow down retrieval of large values not converted directly
444+ to ByteString, such as large json, hstore, and array values.
445+ See commit 8635f8 for more information.
446+
447+ * Added the PGArray type. Thanks to Joey Adams for the suggestion
448+
449+ * Fixed JSON decoding, which was almost entirely broken up until now,
450+ due to bugs in the version of aeson currently available on Hackage.
451+ Thanks to Amit Levy for the report.
452+
453+ * Added FromField instances for IORef, MVar, and IOVector.
454+
455+### Version 0.3.10.0 (2013-12-17)
456+ * Added the queryWith function, courtesy of Leonid Onokhov
457+
458+ * Added the Default type, for representing postgresql's default values
459+
460+### Version 0.3.9.1 (2013-10-28)
461+ * Removed dependency on hashable
462+
463+### Version 0.3.9.0 (2013-10-27)
464+ * Added FromField and ToField instances for the `uuid` package,
465+ courtesy of Bas van Dijk.
466+
467+ * Added instance FromRow (Maybe a) for most pre-packaged FromRow
468+ instances. See issue #64 for some discussion.
469+
470+ * Added the fromBinary, fromHStoreMap, and fromHStoreList newtype
471+ unwrapper functions, courtesy of Bas van Dijk.
472+
473+### Version 0.3.8.0 (2013-10-11)
474+ * Fixed the example code in `FromField`, thanks to Adam Bergmark.
475+
476+ * Added `Notification.getBackendPID`.
477+
478+### Version 0.3.7.1 (2013-09-12)
479+ * Relaxed the dependency on bytestring-0.10 back to bytestring-0.9,
480+ courtesy of Michael Snoyman
481+
482+### Version 0.3.7.0 (2013-09-11)
483+ * Added `aeson` as a dependency.
484+
485+ * Added ToField and FromField instances for aeson's JSON.Value type,
486+ courtesy of Bas van Dijk.
487+
488+ * Added toJSONField and fromJSONField helper functions for declaring
489+ FromField/ToField JSON instances to other Haskell types, courtesy
490+ of Bas van Dijk.
491+
492+ * Added a FromField instance for (), corresponding to postgresql's void
493+ type.
494+
495+ * Added liftConversion and liftRowParser functions to the Internal
496+ module, for lifting IO actions into the respective monads.
497+
498+ * The SqlError predicates available in the Transaction module are now
499+ also exported from the Errors module.
500+
501+ * Various documentation fixes.
502+
503+### Version 0.3.6.0 (2013-08-19)
504+ * Added the json type to BuiltinTypes and TypeInfo.Static, courtesy of
505+ Manuel Gómez.
506+
507+ * Removed the remaining internal dependencies on BuiltinTypes from
508+ FromField. Added the TypeInfo.Macro module as a result.
509+
510+ * Deprecated the BuiltinTypes module, which will be removed several
511+ months from now. Fixed the example code in FromField to reflect
512+ this change.
513+
514+### Version 0.3.5.0 (2013-08-09)
515+ * Added an FromRow instance for Vector, semantically identical to the
516+ existing FromRow instance for [], courtesy of Doug Beardsley
517+
518+ * Reworked the documentation for the Copy module, and tweaked the
519+ documentation for the LargeObjects module.
520+
521+### Version 0.3.4.0 (2013-07-23)
522+ * Added direct support for COPY IN and COPY OUT, without having
523+ to use raw postgresql-libpq calls and postgresql-simple's Internal
524+ module.
525+
526+ * Changed `getNotification` so that it throws a IOError (resource vanished)
527+ exception instead of an ErrorCall exception when it fails to fetch
528+ the connection's file descriptor from libpq.
529+
530+### Version 0.3.3.2 (2013-06-18)
531+ * Optimized the definition of `mconcat` in the Monoid instance for
532+ the Query type, courtesy of Joey Adams.
533+
534+### Version 0.3.3.1 (2013-06-06)
535+ * `getNotification` now works on Windows, albeit using a one-second
536+ polling loop, courtesy of Joey Adams.
537+
538+### Version 0.3.3.0 (2013-05-29)
539+ * Fixed two issues with the fold operator: fold would raise the wrong
540+ exception, and gave the database cursor a static name preventing
541+ folds from being nested. Thanks to Joey Adams for his
542+ work on these issues.
543+
544+### Version 0.3.2.0 (2013-05-20)
545+ * Added a savepoint abstraction to the Transaction module, courtesy
546+ of Joey Adams
547+
548+### Version 0.3.1.2 (2013-04-29)
549+ * Fixed hstore parser to not unnecessarily reverse the key-value pairs
550+
551+### Version 0.3.1.1 (2013-04-29)
552+ * Fixed hstore parser to recognize empty hstores, courtesy of Simon
553+ Meier
554+
555+### Version 0.3.1.0 (2013-04-26)
556+ * Added support for Range and Composite types to the TypeInfo system.
557+
558+ * Added support for hstore types in the Simple.HStore module.
559+
560+ * Improved documentation of the FromField module.
561+
562+### Version 0.3.0.1 (2013-03-26)
563+ * A large chunk of the documentation inside the FromField module had
564+ silently failed to render in Haddock.
565+
566+### Version 0.3.0.0 (2013-03-25)
567+ * Added support for PostgreSQL's Array Types. Thanks to Jason Dusek
568+ for his work on this feature.
569+
570+ * Added a brand new TypeInfo system that gives FromField instances
571+ convenient and efficient access to the pg_type metatable. This
572+ replaced the older typename cache, and was necessary to properly
573+ support postgres array types. Thanks to Bas van Dijk for his
574+ work on this feature.
575+
576+ * Changed the type of the `fromField` and `fromRow` methods to allow
577+ a restricted set of IO actions, and stopped pre-calculating the type
578+ name of every column. As a result, the type of the `typename`
579+ operator changed from `Field -> ByteString` to
580+ `Field -> Conversion ByteString`, where Conversion is the new monad
581+ that conversion computations run inside.
582+
583+ * Improved the documentation of the FromField module.
584+
585+ * Added the Database.PostgreSQL.Simple.Errors module, which offers
586+ some predicates and functions for interpreting SqlError values, courtesy
587+ of Leonid Onokhov.
588+
589+ * Added a the name of a column and the associated table's object identifier
590+ to ResultError exceptions, courtesy of Jeff Chu.
591+
592+ * Moved most of the more detailed transaction operators into the
593+ Database.PostgreSQL.Simple.Transaction module.
594+
595+ * Changed withTransactionModeRetry to accept a predicate of which
596+ SqlErrors to retry, due to the fact that serialization errors can
597+ sometimes manifest themselves as constraint violations. Thanks
598+ to Oliver Charles for pointing this out and implementing the change.
599+
600+ * Added simple tests of the fold operator, thanks to Joey Adams.
601+
602+ * Added simple tests of the array conversion code.
603+
604+ * Added recognition of -- comments in the quasiquoter, which are
605+ now stripped out.
606+
607+
608+### Version 0.2.4.1 (2012-08-29)
609+ * Fixed the documentation of `In`. Thanks to rekado and dstcruz for
610+ pointing this out.
611+
612+### Version 0.2.4.0 (2012-08-23)
613+ * Added the `withTransactionSerializable` and `withTransactionModeRetry`
614+ operators, thanks to Joey Adams.
615+
616+### Version 0.2.3.0 (2012-08-09)
617+ * Added the `returning` operator, thanks to Jason Dusek
618+
619+### Version 0.2.2.0 (2012-07-26)
620+ * Added a ToRow instance for the (:.) type, courtesy of Leonid Onokhov
621+
622+ * Added the type oid for PostgreSQL's `uuid` type to BuiltinTypes
623+
624+### Version 0.2.1.0 (2012-07-23)
625+ * Added the FromRow.fieldWith operator, thanks to Leonid Onokhov
626+
627+ * Added a type synonym for FieldParser
628+
629+### Version 0.2.0.1 (2012-06-21)
630+ * Fixed a compatibility problem with PostgreSQL 8.1, which does not allow
631+ clients to set their own value for `standard_conforming_strings`. This
632+ connection variable is still set to `on` for PostgreSQL 8.2 and later.
633+
634+### Version 0.2: (2012-06-19)
635+ * Removed the conversion from `timestamp` to `UTCTime`. Some code will be
636+ broken even though it will still compile.
637+
638+ * Renamed a number of data constructors, mostly in the BuiltinTypes module.
639+
640+ * Exported ToRow/FromRow from Database.PostgreSQL.Simple
641+
642+
643+### Version 0.1.4.3: (2012-06-10)
644+ * Fix language extensions for compatibility with GHC 7.0
645+
646+### Version 0.1.4.2: (2012-06-10)
647+ * Fix a wayward dependency on Text.
648+
649+### Version 0.1.4.1: (2012-06-10)
650+ * Added support for timezones with minutes in their UTC offset.
651+
652+### Version 0.1.4: (2012-06-10)
653+ * Removed pcre-light dependency, courtesy of Joey Adams.
654+
655+ * Reworked support for the Time types.
656+
657+ * The conversion from PostgreSQL's `timestamp` (without time zone) type
658+ to Haskell's `UTCTime` type is deprecated and will be removed in 0.2.
659+
660+ * `Data.Time.LocalTime` now has `FromField`/`ToField` instances. It is
661+ now the preferred way of dealing with `timestamp` (without time zone).
662+
663+ * `Database.PostgreSQL.Simple.Time` is a new module that offers types
664+ that accommodate PostgreSQL's infinities.
665+
666+ * All time-related `FromField`/`ToField` instances are now based on new,
667+ higher-speed parsers and printers instead of those provided by the
668+ time package included in GHC.
669+
670+ * Planned breaking changes for 0.2:
671+
672+ * Removing the conversion from `timestamp` to `UTCTime`.
673+
674+ * Renaming some of the type names in `BuiltinTypes`.
675+
676+
677+### Version 0.1.3: (2012-05-30)
678+ * Made ZonedTime an instance of FromField and ToField
679+
680+ * Added getNotificationNonBlocking
681+
682+
683+### Version 0.1.2: (2012-05-09)
684+ * Switched to libpq-based escaping for bytea types; Binary now works with
685+ PostgreSQL 8 courtesy of Joey Adams.
686+
687+ * postgresql-simple now sets standard_conforming_strings to "on". This
688+ per-connection variable is initialized according to the server
689+ configuration, which defaults to "off" for PostgreSQL < 9, and "on"
690+ for PostgreSQL >= 9. You may need to adjust any string literals in
691+ your SQL queries, or set the variable yourself.
692+
693+ * Exported (:.) from Database.PostgreSQL.Simple
694+
695+
696+### Version 0.1.1: (2012-05-06)
697+ * Added some preliminary documentation for the Ok, Notification, and
698+ LargeObjects modules
699+
700+ * Implemented the `fail` method for the monad instance for `Ok`.
701+
702+ * Fixed a bug relating to handling the transaction level
703+
704+
705+### Version 0.1: (2012-05-04)
706+ * Renamed several modules, typeclasses, and functions:
707+
708+ QueryParams (renderParams) -> ToRow (toRow)
709+ QueryResults (convertResults) -> FromRow (fromRow)
710+ Param (render) -> ToField (toField)
711+ Result (convert) -> FromField (fromField)
712+
713+ * Added the `Database.PostgreSQL.Simple.Ok` module, a variation of
714+ `Either SomeException` that has an instance for `Alternative` and also
715+ uses a list of exceptions to track the ways it has failed.
716+
717+ * Changed the return type of `fromField` and `fromRow` from
718+ `Either SomeException` to `Ok`.
719+
720+ * Thanks to suggestions from Ozgun Ataman, the `FromRow` typeclass has been
721+ massively improved. The result is simpler definitions and better
722+ compositionality. Also, user-defined instances need not be to be
723+ concerned about forcing the converted results to WHNF. Here is an
724+ example comparing the old to the new:
725+
726+ instance (Result a, Result b) => QueryResults (a,b) where
727+ convertResults [fa,fb] [va,vb] = do
728+ !a <- convert fa va
729+ !b <- convert fb vb
730+ return (a,b)
731+ convertResults fs vs = convertError fs vs 2
732+
733+ instance (FromField a, FromField b) => FromRow (a,b) where
734+ fromRow = (,) <$> field <*> field
735+
736+ * Added `(:.)`, a pair that allows one to compose `FromRow` instances:
737+
738+ instance (FromRow a, FromRow b) => FromRow (a :. b) where
739+ fromRow = (:.) <$> fromRow <*> fromRow
740+
741+ * Moved the contents `Field` module into the `FromField` module.
742+
743+ * Removed the `RawResult` type.
744+
745+ * Added `DefaultIsolationLevel` as a distinct `IsolationLevel` option
746+ and `DefaultReadWriteMode` as a distinct `ReadWriteMode`.
CONTRIBUTING.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+17
@@ -17,3 +17,20 @@ Michael Snoyman <michael@snoyman.com>
1717Adam Bergmark <adam@edea.se>
1818Tobias Florek <tob@butter.sh>
1919Francesco Mazzoli <francesco.mazzoli@erudify.com>
20+Chris Allen <cma@bitemyapp.com>
21+Simon Hengel <sol@typeful.net>
22+Tom Ellis <tom-2013@purelyagile.com>
23+Mike Ledger <mike@quasimal.com>
24+João Cristóvão <jmacristovao@gmail.com>
25+Bardur Arantsson <bardur@scientician.net>
26+Travis Staton <hello@travisstaton.com>
27+Sam Rijs <srijs@airpost.net>
28+Janne Hellsten <jjhellst@gmail.com>
29+Timmy Tofu <timmytofu@users.noreply.github.com>
30+Alexey Khudyakov <alexey.skladnoy@gmail.com>
31+Timo von Holtz <tvh@anchor.com.au>
32+Amit Levy <amit@amitlevy.com>
33+Ben Gamari <ben@smart-cactus.org>
34+Edgar Gomes Araujo <talktoedgar@gmail.com>
35+Erik Hesselink <hesselink@gmail.com>
36+Matvey Aksenov <matvey.aksenov@gmail.com>
README.mdnew file+4
@@ -0,0 +1,4 @@
1+[![Hackage page (downloads and API reference)][hackage-png]][hackage]
2+
3+ [hackage-png]: http://img.shields.io/hackage/v/postgresql-simple.svg
4+ [hackage]: http://hackage.haskell.org/package/postgresql-simple
bench/Select.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−94
@@ -1,116 +1,175 @@
1−Name: postgresql-simple
2−Version: 0.4.2.1
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.BuiltinTypes
26− Database.PostgreSQL.Simple.Copy
27− Database.PostgreSQL.Simple.FromField
28− Database.PostgreSQL.Simple.FromRow
29− Database.PostgreSQL.Simple.LargeObjects
30− Database.PostgreSQL.Simple.HStore
31− Database.PostgreSQL.Simple.HStore.Internal
32− Database.PostgreSQL.Simple.Notification
33− Database.PostgreSQL.Simple.Ok
34− Database.PostgreSQL.Simple.SqlQQ
35− Database.PostgreSQL.Simple.Time
36− Database.PostgreSQL.Simple.Time.Internal
37− Database.PostgreSQL.Simple.ToField
38− Database.PostgreSQL.Simple.ToRow
39− Database.PostgreSQL.Simple.Transaction
40− Database.PostgreSQL.Simple.TypeInfo
41− Database.PostgreSQL.Simple.TypeInfo.Macro
42− Database.PostgreSQL.Simple.TypeInfo.Static
43− Database.PostgreSQL.Simple.Types
44− Database.PostgreSQL.Simple.Errors
45−-- Other-modules:
46− Database.PostgreSQL.Simple.Internal
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.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
5367
54− Build-depends:
55− aeson >= 0.6,
56− attoparsec >= 0.10.3,
57− base < 5,
58− blaze-builder,
59− blaze-textual,
60− bytestring >= 0.9,
61− containers,
62− hashable,
63− postgresql-libpq >= 0.9,
64− template-haskell,
65− text >= 0.11.1,
66− time,
67− transformers,
68− uuid >= 1.3.1,
69− scientific,
70− 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
7199
72− extensions: DoAndIfThenElse, OverloadedStrings, BangPatterns, ViewPatterns
73− TypeOperators
100+ default-extensions:
101+ BangPatterns
102+ DoAndIfThenElse
103+ OverloadedStrings
104+ TypeOperators
105+ ViewPatterns
74106
75− ghc-options: -Wall -fno-warn-name-shadowing
107+ ghc-options: -Wall -fno-warn-name-shadowing
76108
77109source-repository head
78110 type: git
79− location: http://github.com/lpsmith/postgresql-simple
111+ location: http://github.com/haskellari/postgresql-simple
80112
81−source-repository this
82− type: git
83− location: http://github.com/lpsmith/postgresql-simple
84− tag: v0.4.2.1
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
85125
86126test-suite test
87− type: exitcode-stdio-1.0
88−
89− hs-source-dirs: test
90− main-is: Main.hs
127+ default-language: Haskell2010
128+ type: exitcode-stdio-1.0
129+ hs-source-dirs: test
130+ main-is: Main.hs
91131 other-modules:
92132 Common
133+ Exception
134+ Interval
93135 Notify
94136 Serializable
95137 Time
96138
97− 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
98148
99− extensions: NamedFieldPuns
100− , OverloadedStrings
101− , Rank2Types
102− , RecordWildCards
103− , PatternGuards
104− , 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
105166
106− build-depends: base
107− , aeson
108− , base16-bytestring
109− , bytestring
110− , containers
111− , cryptohash
112− , HUnit
113− , postgresql-simple
114− , text
115− , time
116− , 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+164−183
@@ -42,7 +42,7 @@ module Database.PostgreSQL.Simple
4242 -- ** Modifying multiple rows at once
4343 -- $many
4444
45− -- ** @RETURNING@: modifications that returns results
45+ -- ** @RETURNING@: modifications that return results
4646 -- $returning
4747
4848 -- * Extracting results
@@ -55,8 +55,7 @@ module Database.PostgreSQL.Simple
5555 -- $types
5656
5757 -- * Types
58− Base.ConnectInfo(..)
59− , Connection
58+ Connection
6059 , Query
6160 , ToRow
6261 , FromRow
@@ -65,17 +64,20 @@ module Database.PostgreSQL.Simple
6564 , Only(..)
6665 , (:.)(..)
6766 -- ** Exceptions
67+ , SomePostgreSqlException(..)
6868 , SqlError(..)
6969 , PQ.ExecStatus(..)
70− , FormatError(fmtMessage, fmtQuery, fmtParams)
71− , QueryError(qeMessage, qeQuery)
72− , ResultError(errSQLType, errHaskellType, errMessage)
70+ , FormatError(..)
71+ , QueryError(..)
72+ , ResultError(..)
7373 -- * Connection management
74− , Base.connect
7574 , Base.connectPostgreSQL
76− , Base.postgreSQLConnectionString
77− , Base.defaultConnectInfo
7875 , Base.close
76+ , Base.connect
77+ , Base.withConnect
78+ , Base.ConnectInfo(..)
79+ , Base.defaultConnectInfo
80+ , Base.postgreSQLConnectionString
7981 -- * Queries that return results
8082 , query
8183 , query_
@@ -93,6 +95,14 @@ module Database.PostgreSQL.Simple
9395 , forEach
9496 , forEach_
9597 , returning
98+ -- ** Queries that stream results taking a parser as an argument
99+ , foldWith
100+ , foldWithOptionsAndParser
101+ , foldWith_
102+ , foldWithOptionsAndParser_
103+ , forEachWith
104+ , forEachWith_
105+ , returningWith
96106 -- * Statements that do not return results
97107 , execute
98108 , execute_
@@ -110,46 +120,27 @@ module Database.PostgreSQL.Simple
110120 , formatQuery
111121 ) where
112122
113−import Blaze.ByteString.Builder
114− ( Builder, fromByteString, toByteString )
115−import Blaze.ByteString.Builder.Char8 (fromChar)
116−import Blaze.Text ( integral )
117−import Control.Applicative ((<$>), pure)
123+import Data.ByteString.Builder (Builder, byteString, char8)
124+import Control.Applicative ((<$>))
118125import Control.Exception as E
119−import Control.Monad (foldM)
120126import Data.ByteString (ByteString)
121127import Data.Int (Int64)
122128import Data.List (intersperse)
123129import Data.Monoid (mconcat)
124−import Data.Typeable (Typeable)
125−import Database.PostgreSQL.Simple.Compat ( (<>) )
130+import Database.PostgreSQL.Simple.Compat ((<>), toByteString)
131+import Database.PostgreSQL.Simple.Cursor
126132import Database.PostgreSQL.Simple.FromField (ResultError(..))
127133import Database.PostgreSQL.Simple.FromRow (FromRow(..))
128−import Database.PostgreSQL.Simple.Ok
129−import Database.PostgreSQL.Simple.ToField (Action(..), inQuotes)
134+import Database.PostgreSQL.Simple.ToField (Action(..))
130135import Database.PostgreSQL.Simple.ToRow (ToRow(..))
131136import Database.PostgreSQL.Simple.Types
132137 ( Binary(..), In(..), Only(..), Query(..), (:.)(..) )
133138import Database.PostgreSQL.Simple.Internal as Base
139+import Database.PostgreSQL.Simple.Internal.PQResultUtils
134140import Database.PostgreSQL.Simple.Transaction
135−import Database.PostgreSQL.Simple.TypeInfo
136141import qualified Database.PostgreSQL.LibPQ as PQ
137142import qualified Data.ByteString.Char8 as B
138−import qualified Data.Text as T
139−import qualified Data.Text.Encoding as TE
140−import Control.Monad.Trans.Reader
141−import Control.Monad.Trans.State.Strict
142−
143−-- | Exception thrown if a 'Query' could not be formatted correctly.
144−-- This may occur if the number of \'@?@\' characters in the query
145−-- string does not match the number of parameters provided.
146−data FormatError = FormatError {
147− fmtMessage :: String
148− , fmtQuery :: Query
149− , fmtParams :: [ByteString]
150− } deriving (Eq, Show, Typeable)
151−
152−instance Exception FormatError
143+
153144
154145-- | Format a query string.
155146--
@@ -186,9 +177,9 @@ formatMany conn q@(Query template) qs = do
186177 case parseTemplate template of
187178 Just (before, qbits, after) -> do
188179 bs <- mapM (buildQuery conn q qbits . toRow) qs
189− return . toByteString . mconcat $ fromByteString before :
190− intersperse (fromChar ',') bs ++
191− [fromByteString after]
180+ return . toByteString . mconcat $ byteString before :
181+ intersperse (char8 ',') bs ++
182+ [byteString after]
192183 Nothing -> fmtError "syntax error in multi-row template" q []
193184
194185-- Split the input string into three pieces, @before@, @qbits@, and @after@,
@@ -286,45 +277,32 @@ parseTemplate template =
286277
287278 skipSpace = B.dropWhile isSpace_ascii
288279
289−escapeStringConn :: Connection -> ByteString -> IO (Either ByteString ByteString)
290−escapeStringConn = escapeWrap PQ.escapeStringConn
291−
292−escapeIdentifier :: Connection -> ByteString -> IO (Either ByteString ByteString)
293−escapeIdentifier = escapeWrap PQ.escapeIdentifier
294−
295−escapeByteaConn :: Connection -> ByteString -> IO (Either ByteString ByteString)
296−escapeByteaConn = escapeWrap PQ.escapeByteaConn
297−
298−escapeWrap :: (PQ.Connection -> ByteString -> IO (Maybe ByteString))
299− -> Connection
300− -> ByteString
301− -> IO (Either ByteString ByteString)
302−escapeWrap f conn s =
303− withConnection conn $ \c ->
304− f c s >>= checkError c
305−
306−checkError :: PQ.Connection -> Maybe a -> IO (Either ByteString a)
307−checkError _ (Just x) = return $ Right x
308−checkError c Nothing = Left . maybe "" id <$> PQ.errorMessage c
309280
310281buildQuery :: Connection -> Query -> ByteString -> [Action] -> IO Builder
311−buildQuery conn q template xs = zipParams (split template) <$> mapM sub xs
312− where err' msg = fmtError (utf8ToString msg) q xs
313− quote = either err' (inQuotes . fromByteString)
314− utf8ToString = T.unpack . TE.decodeUtf8
315− sub (Plain b) = pure b
316− sub (Escape s) = quote <$> escapeStringConn conn s
317− sub (EscapeByteA s) = quote <$> escapeByteaConn conn s
318− sub (EscapeIdentifier s) = either err' fromByteString <$>
319− escapeIdentifier conn s
320− sub (Many ys) = mconcat <$> mapM sub ys
321− split s = fromByteString h : if B.null t then [] else split (B.tail t)
322− where (h,t) = B.break (=='?') s
282+buildQuery conn q template xs =
283+ zipParams (split template) <$> mapM (buildAction conn q xs) xs
284+ where split s =
285+ -- This part escapes double '??'s to make literal '?'s possible
286+ -- in PostgreSQL queries using the JSON operators: @?@, @?|@ and @?&@
287+ let (h,t) = breakOnSingleQuestionMark s
288+ in byteString h
289+ : if B.null t
290+ then []
291+ else split (B.tail t)
323292 zipParams (t:ts) (p:ps) = t <> p <> zipParams ts ps
324293 zipParams [t] [] = t
325− zipParams _ _ = fmtError (show (B.count '?' template) ++
326− " '?' characters, but " ++
294+ zipParams _ _ = fmtError (show countSingleQs ++
295+ " single '?' characters, but " ++
327296 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
328306
329307-- | Execute an @INSERT@, @UPDATE@, or other SQL query that is not
330308-- expected to return results.
@@ -362,10 +340,10 @@ execute conn template qs = do
362340-- @
363341-- executeMany c [sql|
364342-- UPDATE sometable
365−-- SET sometable.y = upd.y
343+-- SET y = upd.y
366344-- FROM (VALUES (?,?)) as upd(x,y)
367345-- WHERE sometable.x = upd.x
368−-- |] [(1, \"hello\"),(2, \"world\")
346+-- |] [(1, \"hello\"),(2, \"world\")]
369347-- @
370348
371349executeMany :: (ToRow q) => Connection -> Query -> [q] -> IO Int64
@@ -387,10 +365,14 @@ executeMany conn q qs = do
387365--
388366-- Throws 'FormatError' if the query could not be formatted correctly.
389367returning :: (ToRow q, FromRow r) => Connection -> Query -> [q] -> IO [r]
390−returning _ _ [] = return []
391−returning conn q qs = do
368+returning = returningWith fromRow
369+
370+-- | A version of 'returning' taking parser as argument
371+returningWith :: (ToRow q) => RowParser r -> Connection -> Query -> [q] -> IO [r]
372+returningWith _ _ _ [] = return []
373+returningWith parser conn q qs = do
392374 result <- exec conn =<< formatMany conn q qs
393− finishQuery conn q result
375+ finishQueryWith parser conn q result
394376
395377-- | Perform a @SELECT@ or other SQL query that is expected to return
396378-- results. All results are retrieved and converted before this
@@ -465,6 +447,17 @@ fold :: ( FromRow row, ToRow params )
465447 -> IO a
466448fold = foldWithOptions defaultFoldOptions
467449
450+-- | A version of 'fold' taking a parser as an argument
451+foldWith :: ( ToRow params )
452+ => RowParser row
453+ -> Connection
454+ -> Query
455+ -> params
456+ -> a
457+ -> (a -> row -> IO a)
458+ -> IO a
459+foldWith = foldWithOptionsAndParser defaultFoldOptions
460+
468461-- | Number of rows to fetch at a time. 'Automatic' currently defaults
469462-- to 256 rows, although it might be nice to make this more intelligent
470463-- based on e.g. the average size of the rows.
@@ -499,9 +492,21 @@ foldWithOptions :: ( FromRow row, ToRow params )
499492 -> a
500493 -> (a -> row -> IO a)
501494 -> IO a
502−foldWithOptions opts conn template qs a f = do
495+foldWithOptions opts = foldWithOptionsAndParser opts fromRow
496+
497+-- | A version of 'foldWithOptions' taking a parser as an argument
498+foldWithOptionsAndParser :: (ToRow params)
499+ => FoldOptions
500+ -> RowParser row
501+ -> Connection
502+ -> Query
503+ -> params
504+ -> a
505+ -> (a -> row -> IO a)
506+ -> IO a
507+foldWithOptionsAndParser opts parser conn template qs a f = do
503508 q <- formatQuery conn template qs
504− doFold opts conn template (Query q) a f
509+ doFold opts parser conn template (Query q) a f
505510
506511-- | A version of 'fold' that does not perform query substitution.
507512fold_ :: (FromRow r) =>
@@ -512,6 +517,14 @@ fold_ :: (FromRow r) =>
512517 -> IO a
513518fold_ = foldWithOptions_ defaultFoldOptions
514519
520+-- | A version of 'fold_' taking a parser as an argument
521+foldWith_ :: RowParser r
522+ -> Connection
523+ -> Query
524+ -> a
525+ -> (a -> r -> IO a)
526+ -> IO a
527+foldWith_ = foldWithOptionsAndParser_ defaultFoldOptions
515528
516529foldWithOptions_ :: (FromRow r) =>
517530 FoldOptions
@@ -520,18 +533,27 @@ foldWithOptions_ :: (FromRow r) =>
520533 -> a -- ^ Initial state for result consumer.
521534 -> (a -> r -> IO a) -- ^ Result consumer.
522535 -> IO a
523−foldWithOptions_ opts conn query a f = doFold opts conn query query a f
524−
525−
526−doFold :: ( FromRow row )
527− => FoldOptions
536+foldWithOptions_ opts conn query' a f = doFold opts fromRow conn query' query' a f
537+
538+-- | A version of 'foldWithOptions_' taking a parser as an argument
539+foldWithOptionsAndParser_ :: FoldOptions
540+ -> RowParser r
541+ -> Connection
542+ -> Query -- ^ Query.
543+ -> a -- ^ Initial state for result consumer.
544+ -> (a -> r -> IO a) -- ^ Result consumer.
545+ -> IO a
546+foldWithOptionsAndParser_ opts parser conn query' a f = doFold opts parser conn query' query' a f
547+
548+doFold :: FoldOptions
549+ -> RowParser row
528550 -> Connection
529551 -> Query
530552 -> Query
531553 -> a
532554 -> (a -> row -> IO a)
533555 -> IO a
534−doFold FoldOptions{..} conn _template q a0 f = do
556+doFold FoldOptions{..} parser conn _template q a0 f = do
535557 stat <- withConnection conn PQ.transactionStatus
536558 case stat of
537559 PQ.TransIdle -> withTransactionMode transactionMode conn go
@@ -549,28 +571,17 @@ doFold FoldOptions{..} conn _template q a0 f = do
549571 PQ.TransUnknown -> fail "foldWithOpts FIXME: PQ.TransUnknown"
550572 -- Not sure what this means.
551573 where
552− declare = do
553− name <- newTempName conn
554− _ <- execute_ conn $ mconcat
555− [ "DECLARE ", name, " NO SCROLL CURSOR FOR ", q ]
556− return name
557− fetch (Query name) = query_ conn $
558− Query (toByteString (fromByteString "FETCH FORWARD "
559− <> integral chunkSize
560− <> fromByteString " FROM "
561− <> fromByteString name
562− ))
563− close name =
564− (execute_ conn ("CLOSE " <> name) >> return ()) `E.catch` \ex ->
565− -- Don't throw exception if CLOSE failed because the transaction is
566− -- aborted. Otherwise, it will throw away the original error.
567− if isFailedTransactionError ex then return () else throwIO ex
568−
569− go = bracket declare close $ \name ->
570− let loop a = do
571− rs <- fetch name
572− if null rs then return a else foldM f a rs >>= loop
573− 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
574585
575586-- FIXME: choose the Automatic chunkSize more intelligently
576587-- One possibility is to use the type of the results, although this
@@ -589,87 +600,37 @@ forEach :: (ToRow q, FromRow r) =>
589600 -> q -- ^ Query parameters.
590601 -> (r -> IO ()) -- ^ Result consumer.
591602 -> IO ()
592−forEach conn template qs = fold conn template qs () . const
603+forEach = forEachWith fromRow
593604{-# INLINE forEach #-}
594605
606+-- | A version of 'forEach' taking a parser as an argument
607+forEachWith :: ( ToRow q )
608+ => RowParser r
609+ -> Connection
610+ -> Query
611+ -> q
612+ -> (r -> IO ())
613+ -> IO ()
614+forEachWith parser conn template qs = foldWith parser conn template qs () . const
615+{-# INLINE forEachWith #-}
616+
595617-- | A version of 'forEach' that does not perform query substitution.
596618forEach_ :: (FromRow r) =>
597619 Connection
598620 -> Query -- ^ Query template.
599621 -> (r -> IO ()) -- ^ Result consumer.
600622 -> IO ()
601−forEach_ conn template = fold_ conn template () . const
623+forEach_ = forEachWith_ fromRow
602624{-# INLINE forEach_ #-}
603625
604−forM' :: (Ord n, Num n) => n -> n -> (n -> IO a) -> IO [a]
605−forM' lo hi m = loop hi []
606− where
607− loop !n !as
608− | n < lo = return as
609− | otherwise = do
610− a <- m n
611− loop (n-1) (a:as)
612−
613−finishQuery :: FromRow r => Connection -> Query -> PQ.Result -> IO [r]
614−finishQuery = finishQueryWith fromRow
615−
616−finishQueryWith :: RowParser r -> Connection -> Query -> PQ.Result -> IO [r]
617−finishQueryWith parser conn q result = do
618− status <- PQ.resultStatus result
619− case status of
620− PQ.EmptyQuery ->
621− throwIO $ QueryError "query: Empty query" q
622− PQ.CommandOk -> do
623− throwIO $ QueryError "query resulted in a command response" q
624− PQ.TuplesOk -> do
625− let unCol (PQ.Col x) = fromIntegral x :: Int
626− nrows <- PQ.ntuples result
627− ncols <- PQ.nfields result
628− forM' 0 (nrows-1) $ \row -> do
629− let rw = Row row result
630− okvc <- runConversion (runStateT (runReaderT (unRP parser) rw) 0) conn
631− case okvc of
632− Ok (val,col) | col == ncols -> return val
633− | otherwise -> do
634− vals <- forM' 0 (ncols-1) $ \c -> do
635− tinfo <- getTypeInfo conn =<< PQ.ftype result c
636− v <- PQ.getvalue result row c
637− return ( tinfo
638− , fmap ellipsis v )
639− throw (ConversionFailed
640− (show (unCol ncols) ++ " values: " ++ show vals)
641− Nothing
642− ""
643− (show (unCol col) ++ " slots in target type")
644− "mismatch between number of columns to \
645− \convert and number in target type")
646− Errors [] -> throwIO $ ConversionFailed "" Nothing "" "" "unknown error"
647− Errors [x] -> throwIO x
648− Errors xs -> throwIO $ ManyErrors xs
649− PQ.CopyOut ->
650− throwIO $ QueryError "query: COPY TO is not supported" q
651− PQ.CopyIn ->
652− throwIO $ QueryError "query: COPY FROM is not supported" q
653− PQ.BadResponse -> throwResultError "query" result status
654− PQ.NonfatalError -> throwResultError "query" result status
655− PQ.FatalError -> throwResultError "query" result status
656−
657−ellipsis :: ByteString -> ByteString
658−ellipsis bs
659− | B.length bs > 15 = B.take 10 bs `B.append` "[...]"
660− | otherwise = bs
661−
662−fmtError :: String -> Query -> [Action] -> a
663−fmtError msg q xs = throw FormatError {
664− fmtMessage = msg
665− , fmtQuery = q
666− , fmtParams = map twiddle xs
667− }
668− where twiddle (Plain b) = toByteString b
669− twiddle (Escape s) = s
670− twiddle (EscapeByteA s) = s
671− twiddle (EscapeIdentifier s) = s
672− twiddle (Many ys) = B.concat (map twiddle ys)
626+forEachWith_ :: RowParser r
627+ -> Connection
628+ -> Query
629+ -> (r -> IO ())
630+ -> IO ()
631+forEachWith_ parser conn template = foldWith_ parser conn template () . const
632+{-# INLINE forEachWith_ #-}
633+
673634
674635-- $use
675636--
@@ -697,9 +658,11 @@ fmtError msg q xs = throw FormatError {
697658-- >
698659-- > import Database.PostgreSQL.Simple
699660-- >
661+-- > hello :: IO Int
700662-- > hello = do
701−-- > conn <- connect defaultConnectInfo
702−-- > query_ conn "select 2 + 2"
663+-- > conn <- connectPostgreSQL ""
664+-- > [Only i] <- query_ conn "select 2 + 2"
665+-- > return i
703666--
704667-- A 'Query' value does not represent the actual query that will be
705668-- executed, but is a template for constructing the final query.
@@ -760,11 +723,26 @@ fmtError msg q xs = throw FormatError {
760723-- The same kind of problem can arise with string literals if you have
761724-- the @OverloadedStrings@ language extension enabled. Again, just
762725-- use an explicit type signature if this happens.
726+--
727+-- Finally, remember that the compiler must be able to infer the type
728+-- of a query's /results/ as well as its parameters. We might like
729+-- the following example to work:
730+--
731+-- > print =<< query_ conn "select 2 + 2"
732+--
733+-- Unfortunately, while a quick glance tells us that the result type
734+-- should be a single row containing a single numeric column, the
735+-- compiler has no way to infer what the types are. We can easily fix
736+-- this by providing an explicit type annotation:
737+--
738+-- > xs <- query_ conn "select 2 + 2"
739+-- > print (xs :: [Only Int])
763740
764741-- $only_param
765742--
766743-- Haskell lacks a single-element tuple type, so if you have just one
767−-- value you want substituted into a query, what should you do?
744+-- value you want substituted into a query or a single-column result,
745+-- what should you do?
768746--
769747-- The obvious approach would appear to be something like this:
770748--
@@ -779,6 +757,9 @@ fmtError msg q xs = throw FormatError {
779757--
780758-- > execute conn "insert into users (first_name) values (?)"
781759-- > ["Nuala"]
760+--
761+-- A row of /n/ query results is represented using an /n/-tuple, so
762+-- you should use 'Only' to represent a single-column result.
782763
783764-- $in
784765--
@@ -796,7 +777,7 @@ fmtError msg q xs = throw FormatError {
796777-- Here's an example:
797778--
798779-- > query conn "select * from users where first_name in ?" $
799−-- > In ["Anna", "Boris", "Carla"]
780+-- > Only $ In ["Anna", "Boris", "Carla"]
800781--
801782-- If your 'In'-wrapped list is empty, the string @\"(null)\"@ will be
802783-- substituted instead, to ensure that your clause remains
@@ -921,7 +902,7 @@ fmtError msg q xs = throw FormatError {
921902-- all values of the given PostgreSQL type is considered \"compatible\".
922903-- For instance, you can always extract a PostgreSQL 16-bit @SMALLINT@
923904-- column to a Haskell 'Int'. The Haskell 'Float' type can accurately
924−-- represent a @SMALLINT@, so it is considered compatble with those types.
905+-- represent a @SMALLINT@, so it is considered compatible with those types.
925906--
926907-- * A numeric compatibility check is based only on the type of a
927908-- column, /not/ on its values. For instance, a PostgreSQL 64-bit
src/Database/PostgreSQL/Simple/Arrays.hs+3−3
@@ -17,7 +17,7 @@ import Control.Applicative (Applicative(..), Alternative(..), (<$>))
1717import Data.ByteString.Char8 (ByteString)
1818import qualified Data.ByteString.Char8 as B
1919import Data.Monoid
20−import Data.Attoparsec.Char8
20+import Data.Attoparsec.ByteString.Char8
2121
2222
2323-- | Parse one of three primitive field formats: array, quoted and plain.
@@ -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/BuiltinTypes.hsdeleted−420
@@ -1,420 +0,0 @@
1−{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}
2−
3−------------------------------------------------------------------------------
4−-- |
5−-- Module: Database.PostgreSQL.Simple.BuiltinTypes
6−-- Copyright: (c) 2011-2012 Leon P Smith
7−-- License: BSD3
8−-- Maintainer: Leon P Smith <leon@melding-monads.com>
9−-- Stability: experimental
10−--
11−------------------------------------------------------------------------------
12−
13−-- Note that this file is generated by tools/GenBuiltinTypes.hs, and should
14−-- not be edited directly
15−
16−module Database.PostgreSQL.Simple.BuiltinTypes
17− {-# DEPRECATED "Use TypeInfo instead" #-}
18− ( BuiltinType (..)
19− , builtin2oid
20− , oid2builtin
21− , builtin2typname
22− , oid2typname
23− ) where
24−
25−import Data.Typeable
26−import Data.ByteString (ByteString)
27−import qualified Database.PostgreSQL.LibPQ as PQ
28−
29−data BuiltinType
30− = Bool
31− | ByteA
32− | Char
33− | Name
34− | Int8
35− | Int2
36− | Int4
37− | RegProc
38− | Text
39− | Oid
40− | Tid
41− | Xid
42− | Cid
43− | Xml
44− | Point
45− | LSeg
46− | Path
47− | Box
48− | Polygon
49− | Line
50− | Cidr
51− | Float4
52− | Float8
53− | AbsTime
54− | RelTime
55− | TInterval
56− | Unknown
57− | Circle
58− | Money
59− | MacAddr
60− | Inet
61− | BpChar
62− | VarChar
63− | Date
64− | Time
65− | Timestamp
66− | TimestampTZ
67− | Interval
68− | TimeTZ
69− | Bit
70− | VarBit
71− | Numeric
72− | RefCursor
73− | Record
74− | Void
75− | UUID
76− | JSON
77− deriving (Eq, Ord, Enum, Bounded, Read, Show, Typeable)
78−
79−builtin2oid :: BuiltinType -> PQ.Oid
80−builtin2oid typ = PQ.Oid $ case typ of
81− Bool -> 16
82− ByteA -> 17
83− Char -> 18
84− Name -> 19
85− Int8 -> 20
86− Int2 -> 21
87− Int4 -> 23
88− RegProc -> 24
89− Text -> 25
90− Oid -> 26
91− Tid -> 27
92− Xid -> 28
93− Cid -> 29
94− Xml -> 142
95− Point -> 600
96− LSeg -> 601
97− Path -> 602
98− Box -> 603
99− Polygon -> 604
100− Line -> 628
101− Cidr -> 650
102− Float4 -> 700
103− Float8 -> 701
104− AbsTime -> 702
105− RelTime -> 703
106− TInterval -> 704
107− Unknown -> 705
108− Circle -> 718
109− Money -> 790
110− MacAddr -> 829
111− Inet -> 869
112− BpChar -> 1042
113− VarChar -> 1043
114− Date -> 1082
115− Time -> 1083
116− Timestamp -> 1114
117− TimestampTZ -> 1184
118− Interval -> 1186
119− TimeTZ -> 1266
120− Bit -> 1560
121− VarBit -> 1562
122− Numeric -> 1700
123− RefCursor -> 1790
124− Record -> 2249
125− Void -> 2278
126− UUID -> 2950
127− JSON -> 114
128−
129−oid2builtin :: PQ.Oid -> Maybe BuiltinType
130−oid2builtin (PQ.Oid x) = case x of
131− 16 -> Just Bool
132− 17 -> Just ByteA
133− 18 -> Just Char
134− 19 -> Just Name
135− 20 -> Just Int8
136− 21 -> Just Int2
137− 23 -> Just Int4
138− 24 -> Just RegProc
139− 25 -> Just Text
140− 26 -> Just Oid
141− 27 -> Just Tid
142− 28 -> Just Xid
143− 29 -> Just Cid
144− 142 -> Just Xml
145− 600 -> Just Point
146− 601 -> Just LSeg
147− 602 -> Just Path
148− 603 -> Just Box
149− 604 -> Just Polygon
150− 628 -> Just Line
151− 650 -> Just Cidr
152− 700 -> Just Float4
153− 701 -> Just Float8
154− 702 -> Just AbsTime
155− 703 -> Just RelTime
156− 704 -> Just TInterval
157− 705 -> Just Unknown
158− 718 -> Just Circle
159− 790 -> Just Money
160− 829 -> Just MacAddr
161− 869 -> Just Inet
162− 1042 -> Just BpChar
163− 1043 -> Just VarChar
164− 1082 -> Just Date
165− 1083 -> Just Time
166− 1114 -> Just Timestamp
167− 1184 -> Just TimestampTZ
168− 1186 -> Just Interval
169− 1266 -> Just TimeTZ
170− 1560 -> Just Bit
171− 1562 -> Just VarBit
172− 1700 -> Just Numeric
173− 1790 -> Just RefCursor
174− 2249 -> Just Record
175− 2278 -> Just Void
176− 2950 -> Just UUID
177− 114 -> Just JSON
178− _ -> Nothing
179−
180−builtin2typname :: BuiltinType -> ByteString
181−builtin2typname typ = case typ of
182− Bool -> bool
183− ByteA -> bytea
184− Char -> char
185− Name -> name
186− Int8 -> int8
187− Int2 -> int2
188− Int4 -> int4
189− RegProc -> regproc
190− Text -> text
191− Oid -> oid
192− Tid -> tid
193− Xid -> xid
194− Cid -> cid
195− Xml -> xml
196− Point -> point
197− LSeg -> lseg
198− Path -> path
199− Box -> box
200− Polygon -> polygon
201− Line -> line
202− Cidr -> cidr
203− Float4 -> float4
204− Float8 -> float8
205− AbsTime -> abstime
206− RelTime -> reltime
207− TInterval -> tinterval
208− Unknown -> unknown
209− Circle -> circle
210− Money -> money
211− MacAddr -> macaddr
212− Inet -> inet
213− BpChar -> bpchar
214− VarChar -> varchar
215− Date -> date
216− Time -> time
217− Timestamp -> timestamp
218− TimestampTZ -> timestamptz
219− Interval -> interval
220− TimeTZ -> timetz
221− Bit -> bit
222− VarBit -> varbit
223− Numeric -> numeric
224− RefCursor -> refcursor
225− Record -> record
226− Void -> void
227− UUID -> uuid
228− JSON -> json
229−
230−oid2typname :: PQ.Oid -> Maybe ByteString
231−oid2typname (PQ.Oid x) = case x of
232− 16 -> Just bool
233− 17 -> Just bytea
234− 18 -> Just char
235− 19 -> Just name
236− 20 -> Just int8
237− 21 -> Just int2
238− 23 -> Just int4
239− 24 -> Just regproc
240− 25 -> Just text
241− 26 -> Just oid
242− 27 -> Just tid
243− 28 -> Just xid
244− 29 -> Just cid
245− 142 -> Just xml
246− 600 -> Just point
247− 601 -> Just lseg
248− 602 -> Just path
249− 603 -> Just box
250− 604 -> Just polygon
251− 628 -> Just line
252− 650 -> Just cidr
253− 700 -> Just float4
254− 701 -> Just float8
255− 702 -> Just abstime
256− 703 -> Just reltime
257− 704 -> Just tinterval
258− 705 -> Just unknown
259− 718 -> Just circle
260− 790 -> Just money
261− 829 -> Just macaddr
262− 869 -> Just inet
263− 1042 -> Just bpchar
264− 1043 -> Just varchar
265− 1082 -> Just date
266− 1083 -> Just time
267− 1114 -> Just timestamp
268− 1184 -> Just timestamptz
269− 1186 -> Just interval
270− 1266 -> Just timetz
271− 1560 -> Just bit
272− 1562 -> Just varbit
273− 1700 -> Just numeric
274− 1790 -> Just refcursor
275− 2249 -> Just record
276− 2278 -> Just void
277− 2950 -> Just uuid
278− 114 -> Just json
279− _ -> Nothing
280−
281−bool :: ByteString
282−bool = "bool"
283−
284−bytea :: ByteString
285−bytea = "bytea"
286−
287−char :: ByteString
288−char = "char"
289−
290−name :: ByteString
291−name = "name"
292−
293−int8 :: ByteString
294−int8 = "int8"
295−
296−int2 :: ByteString
297−int2 = "int2"
298−
299−int4 :: ByteString
300−int4 = "int4"
301−
302−regproc :: ByteString
303−regproc = "regproc"
304−
305−text :: ByteString
306−text = "text"
307−
308−oid :: ByteString
309−oid = "oid"
310−
311−tid :: ByteString
312−tid = "tid"
313−
314−xid :: ByteString
315−xid = "xid"
316−
317−cid :: ByteString
318−cid = "cid"
319−
320−xml :: ByteString
321−xml = "xml"
322−
323−point :: ByteString
324−point = "point"
325−
326−lseg :: ByteString
327−lseg = "lseg"
328−
329−path :: ByteString
330−path = "path"
331−
332−box :: ByteString
333−box = "box"
334−
335−polygon :: ByteString
336−polygon = "polygon"
337−
338−line :: ByteString
339−line = "line"
340−
341−cidr :: ByteString
342−cidr = "cidr"
343−
344−float4 :: ByteString
345−float4 = "float4"
346−
347−float8 :: ByteString
348−float8 = "float8"
349−
350−abstime :: ByteString
351−abstime = "abstime"
352−
353−reltime :: ByteString
354−reltime = "reltime"
355−
356−tinterval :: ByteString
357−tinterval = "tinterval"
358−
359−unknown :: ByteString
360−unknown = "unknown"
361−
362−circle :: ByteString
363−circle = "circle"
364−
365−money :: ByteString
366−money = "money"
367−
368−macaddr :: ByteString
369−macaddr = "macaddr"
370−
371−inet :: ByteString
372−inet = "inet"
373−
374−bpchar :: ByteString
375−bpchar = "bpchar"
376−
377−varchar :: ByteString
378−varchar = "varchar"
379−
380−date :: ByteString
381−date = "date"
382−
383−time :: ByteString
384−time = "time"
385−
386−timestamp :: ByteString
387−timestamp = "timestamp"
388−
389−timestamptz :: ByteString
390−timestamptz = "timestamptz"
391−
392−interval :: ByteString
393−interval = "interval"
394−
395−timetz :: ByteString
396−timetz = "timetz"
397−
398−bit :: ByteString
399−bit = "bit"
400−
401−varbit :: ByteString
402−varbit = "varbit"
403−
404−numeric :: ByteString
405−numeric = "numeric"
406−
407−refcursor :: ByteString
408−refcursor = "refcursor"
409−
410−record :: ByteString
411−record = "record"
412−
413−void :: ByteString
414−void = "void"
415−
416−uuid :: ByteString
417−uuid = "uuid"
418−
419−json :: ByteString
420−json = "json"
src/Database/PostgreSQL/Simple/Compat.hs+17−21
@@ -5,19 +5,20 @@ module Database.PostgreSQL.Simple.Compat
55 ( mask
66 , (<>)
77 , unsafeDupablePerformIO
8+ , toByteString
9+ , scientificBuilder
10+ , toPico
11+ , fromPico
812 ) where
913
1014import qualified Control.Exception as E
11−import Data.Monoid
12−
13−#if __GLASGOW_HASKELL__ >= 702
15+import Data.ByteString (ByteString)
16+import Data.ByteString.Lazy (toStrict)
17+import Data.ByteString.Builder (Builder, toLazyByteString)
18+import Data.Text.Lazy.Builder.Scientific (scientificBuilder)
1419import System.IO.Unsafe (unsafeDupablePerformIO)
15−#elif __GLASGOW_HASKELL__ >= 611
16−import GHC.IO (unsafeDupablePerformIO)
17−#else
18−import GHC.IOBase (unsafeDupablePerformIO)
19−#endif
20−
20+import Data.Fixed (Pico)
21+import Data.Fixed (Fixed(MkFixed))
2122
2223-- | Like 'E.mask', but backported to base before version 4.3.0.
2324--
@@ -27,19 +28,14 @@ import GHC.IOBase (unsafeDupablePerformIO)
2728-- 'withTransactionMode' function calls the restore callback only once, so we
2829-- don't need that polymorphism.
2930mask :: ((IO a -> IO a) -> IO b) -> IO b
30−#if MIN_VERSION_base(4,3,0)
3131mask io = E.mask $ \restore -> io restore
32−#else
33−mask io = do
34− b <- E.blocked
35− E.block $ io $ \m -> if b then m else E.unblock m
36−#endif
3732{-# INLINE mask #-}
3833
39−#if !MIN_VERSION_base(4,5,0)
40−infixr 6 <>
34+toByteString :: Builder -> ByteString
35+toByteString x = toStrict (toLazyByteString x)
36+
37+toPico :: Integer -> Pico
38+toPico = MkFixed
4139
42−(<>) :: Monoid m => m -> m -> m
43−(<>) = mappend
44−{-# INLINE (<>) #-}
45−#endif
40+fromPico :: Pico -> Integer
41+fromPico (MkFixed i) = i
src/Database/PostgreSQL/Simple/Copy.hs+46−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,
@@ -186,6 +214,7 @@ putCopyEnd conn = withConnection conn $ \pqconn -> do
186214putCopyError :: Connection -> B.ByteString -> IO ()
187215putCopyError conn err = withConnection conn $ \pqconn -> do
188216 doCopyIn funcName (\c -> PQ.putCopyEnd c (Just err)) pqconn
217+ consumeResults pqconn
189218 where
190219 funcName = "Database.PostgreSQL.Simple.Copy.putCopyError"
191220
@@ -220,10 +249,21 @@ getCopyCommandTag :: B.ByteString -> PQ.Connection -> IO Int64
220249getCopyCommandTag funcName pqconn = do
221250 result <- maybe (fail errCmdStatus) return =<< PQ.getResult pqconn
222251 cmdStat <- maybe (fail errCmdStatus) return =<< PQ.cmdStatus result
252+ consumeResults pqconn
223253 let rowCount = P.string "COPY " *> (P.decimal <* P.endOfInput)
224254 case P.parseOnly rowCount cmdStat of
225− Left _ -> fail errCmdStatusFmt
255+ Left _ -> do mmsg <- PQ.errorMessage pqconn
256+ fail $ errCmdStatusFmt
257+ ++ maybe "" (\msg -> "\nConnection error: "++B.unpack msg) mmsg
226258 Right n -> return $! n
227259 where
228260 errCmdStatus = B.unpack funcName ++ ": failed to fetch command status"
229261 errCmdStatusFmt = B.unpack funcName ++ ": failed to parse command status"
262+
263+
264+consumeResults :: PQ.Connection -> IO ()
265+consumeResults pqconn = do
266+ mres <- PQ.getResult pqconn
267+ case mres of
268+ Nothing -> return ()
269+ Just _ -> consumeResults pqconn
src/Database/PostgreSQL/Simple/Cursor.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+16−12
@@ -25,10 +25,9 @@ module Database.PostgreSQL.Simple.Errors
2525 )
2626 where
2727
28−import Control.Applicative
2928import Control.Exception as E
3029
31−import Data.Attoparsec.Char8
30+import Data.Attoparsec.ByteString.Char8
3231import Data.ByteString (ByteString)
3332import Data.Typeable
3433
@@ -55,19 +54,23 @@ data ConstraintViolation
5554 -- ^ Name of violated constraint
5655 | CheckViolation ByteString ByteString
5756 -- ^ Relation name (usually table), constraint name
57+ | ExclusionViolation ByteString
58+ -- ^ Name of the exclusion violation constraint
5859 deriving (Show, Eq, Ord, Typeable)
5960
6061-- Default instance should be enough
61−instance Exception ConstraintViolation
62+instance Exception ConstraintViolation where
63+ toException = postgresqlExceptionToException
64+ fromException = postgresqlExceptionFromException
6265
6366
6467-- | Tries to convert 'SqlError' to 'ConstrainViolation', checks sqlState and
65−-- succeedes only if able to parse sqlErrorMsg.
68+-- succeeds only if able to parse sqlErrorMsg.
6669--
67−-- > createUser = catchJust constraintViolation catcher $ execute conn ...
70+-- > createUser = handleJust constraintViolation handler $ execute conn ...
6871-- > where
69−-- > catcher UniqueViolation "user_login_key" = ...
70−-- > catcher _ = ...
72+-- > handler (UniqueViolation "user_login_key") = ...
73+-- > handler _ = ...
7174constraintViolation :: SqlError -> Maybe ConstraintViolation
7275constraintViolation e =
7376 case sqlState e of
@@ -75,22 +78,23 @@ constraintViolation e =
7578 "23503" -> uncurry ForeignKeyViolation <$> parseMaybe parseQ2 msg
7679 "23505" -> UniqueViolation <$> parseMaybe parseQ1 msg
7780 "23514" -> uncurry CheckViolation <$> parseMaybe parseQ2 msg
81+ "23P01" -> ExclusionViolation <$> parseMaybe parseQ1 msg
7882 _ -> Nothing
7983 where msg = sqlErrorMsg e
8084
8185
8286-- | Like constraintViolation, but also packs original SqlError.
8387--
84−-- > createUser = catchJust constraintViolationE catcher $ execute conn ...
88+-- > createUser = handleJust constraintViolationE handler $ execute conn ...
8589-- > where
86−-- > catcher (_, UniqueViolation "user_login_key") = ...
87−-- > catcher (e, _) = throwIO e
90+-- > handler (_, UniqueViolation "user_login_key") = ...
91+-- > handler (e, _) = throwIO e
8892--
8993constraintViolationE :: SqlError -> Maybe (SqlError, ConstraintViolation)
9094constraintViolationE e = fmap ((,) e) $ constraintViolation e
9195
9296-- | Catches SqlError, tries to convert to ConstraintViolation, re-throws
93−-- on fail. Provides alternative interface to catchJust
97+-- on fail. Provides alternative interface to 'E.handleJust'
9498--
9599-- > createUser = catchViolation catcher $ execute conn ...
96100-- > where
@@ -121,7 +125,7 @@ parseMaybe p b = either (const Nothing) Just $ parseOnly p b
121125------------------------------------------------------------------------
122126-- Error predicates
123127--
124−-- http://www.postgresql.org/docs/current/static/errcodes-appendix.html
128+-- https://www.postgresql.org/docs/9.5/static/errcodes-appendix.html
125129
126130isSerializationError :: SqlError -> Bool
127131isSerializationError = isSqlState "40001"
src/Database/PostgreSQL/Simple/FromField.hs+216−98
@@ -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
@@ -27,13 +28,20 @@ Note that the 'Float' and 'Double' instances use attoparsec's 'double'
2728conversion routine, which sacrifices some accuracy for speed. If you
2829need accuracy, consider first converting data to a 'Scientific' or 'Rational'
2930type, and then converting to a floating-point type. If you are defining
30−your own 'Database.PostgreSQL.Simple.FromRow.FromRow' instances, this can be
31−acheived simply by
32−@'fromRational' '<$>' 'Database.PostgreSQL.Simple.FromRow.field'@, although
33−this idiom is additionally compatible with PostgreSQL's @numeric@ type.
34−If this is unacceptable, you may find
31+your own 'Database.PostgreSQL.Simple.FromRow.FromRow' instances, this can be
32+achieved simply by
33+@'fromRational' '<$>' 'Database.PostgreSQL.Simple.FromRow.field'@, although
34+this idiom is additionally compatible with PostgreSQL's @int8@ and @numeric@
35+types. If this is unacceptable, you may find
3536'Database.PostgreSQL.Simple.FromRow.fieldWith' useful.
3637
38+Also note that while converting to a 'Double' through the 'Scientific' type
39+is likely somewhat faster than converting through the 'Rational' type,
40+the 'Scientific' type has no way to represent @NaN@ and @±Infinity@ values.
41+Thus, if you need precision conversion of regular floating point values
42+and the possibility of receiving these special values from the backend,
43+stick with 'Rational'.
44+
3745Because 'FromField' is a typeclass, one may provide conversions to
3846additional Haskell types without modifying postgresql-simple. This is
3947particularly useful for supporting PostgreSQL types that postgresql-simple
@@ -98,24 +106,28 @@ module Database.PostgreSQL.Simple.FromField
98106 , typeOid
99107 , PQ.Oid(..)
100108 , PQ.Format(..)
109+ , pgArrayFieldParser
110+ , attoFieldParser
101111
112+ , optionalField
102113 , fromJSONField
114+ , fromFieldJSONByteString
103115 ) where
104116
105117#include "MachDeps.h"
106118
107−import Control.Applicative
108− ( Applicative, (<|>), (<$>), pure )
119+import Control.Applicative ( Const(Const), (<|>), (<$>), pure, (*>), (<*) )
109120import Control.Concurrent.MVar (MVar, newMVar)
110−import Control.Exception (Exception)
121+import Control.Exception (Exception (toException, fromException))
111122import qualified Data.Aeson as JSON
112−import Data.Attoparsec.Char8 hiding (Result)
123+import Data.Attoparsec.ByteString.Char8 hiding (Result)
113124import Data.ByteString (ByteString)
114125import qualified Data.ByteString.Char8 as B
126+import Data.Functor.Identity (Identity(Identity))
115127import Data.Int (Int16, Int32, Int64)
116128import Data.IORef (IORef, newIORef)
117129import Data.Ratio (Ratio)
118−import Data.Time ( UTCTime, ZonedTime, LocalTime, Day, TimeOfDay )
130+import Data.Time.Compat ( UTCTime, ZonedTime, LocalTime, Day, TimeOfDay, CalendarDiffTime )
119131import Data.Typeable (Typeable, typeOf)
120132import Data.Vector (Vector)
121133import Data.Vector.Mutable (IOVector)
@@ -126,7 +138,6 @@ import Database.PostgreSQL.Simple.Ok
126138import Database.PostgreSQL.Simple.Types
127139import Database.PostgreSQL.Simple.TypeInfo as TI
128140import qualified Database.PostgreSQL.Simple.TypeInfo.Static as TI
129−import Database.PostgreSQL.Simple.TypeInfo.Macro as TI
130141import Database.PostgreSQL.Simple.Time
131142import Database.PostgreSQL.Simple.Arrays as Arrays
132143import qualified Database.PostgreSQL.LibPQ as PQ
@@ -136,9 +147,14 @@ import qualified Data.ByteString.Lazy as LB
136147import qualified Data.Text as ST
137148import qualified Data.Text.Encoding as ST
138149import qualified Data.Text.Lazy as LT
139−import Data.UUID (UUID)
140−import qualified Data.UUID as UUID
150+import Data.CaseInsensitive (CI)
151+import qualified Data.CaseInsensitive as CI
152+import Data.UUID.Types (UUID)
153+import qualified Data.UUID.Types as UUID
141154import Data.Scientific (Scientific)
155+import GHC.Real (infinity, notANumber)
156+
157+import qualified Data.Aeson.Types as JSON
142158
143159-- | Exception thrown if conversion from a SQL value to a Haskell
144160-- value fails.
@@ -166,7 +182,9 @@ data ResultError = Incompatible { errSQLType :: String
166182 -- between metadata and actual data in a row).
167183 deriving (Eq, Show, Typeable)
168184
169−instance Exception ResultError
185+instance Exception ResultError where
186+ toException = postgresqlExceptionToException
187+ fromException = postgresqlExceptionFromException
170188
171189left :: Exception a => a -> Conversion b
172190left = conversionError
@@ -207,7 +225,7 @@ typename field = typname <$> typeInfo field
207225
208226typeInfo :: Field -> Conversion TypeInfo
209227typeInfo Field{..} = Conversion $ \conn -> do
210− Ok <$> (getTypeInfo conn =<< PQ.ftype result column)
228+ Ok <$> (getTypeInfo conn typeOid)
211229
212230typeInfoByOid :: PQ.Oid -> Conversion TypeInfo
213231typeInfoByOid oid = Conversion $ \conn -> do
@@ -232,9 +250,11 @@ tableOid Field{..} = toMaybeOid (unsafeDupablePerformIO (PQ.ftable result column
232250 then Nothing
233251 else Just x
234252
235−-- | If the column has a table associated with it, this returns the number
236−-- off the associated table column. Numbering starts from 0. Analogous
237−-- 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@.
238258
239259tableColumn :: Field -> Int
240260tableColumn Field{..} = fromCol (unsafeDupablePerformIO (PQ.ftablecol result column))
@@ -250,16 +270,33 @@ format Field{..} = unsafeDupablePerformIO (PQ.fformat result column)
250270-- | void
251271instance FromField () where
252272 fromField f _bs
253− | typeOid f /= $(inlineTypoid TI.void) = returnError Incompatible f ""
273+ | typeOid f /= TI.voidOid = returnError Incompatible f ""
254274 | otherwise = pure ()
255275
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+
256282-- | For dealing with null values. Compatible with any postgresql type
257283-- compatible with type @a@. Note that the type is not checked if
258284-- the value is null, although it is inadvisable to rely on this
259285-- behavior.
260−instance (FromField a) => FromField (Maybe a) where
261− fromField _ Nothing = pure Nothing
262− 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 #-}
263300
264301-- | compatible with any data type, but the value must be null
265302instance FromField Null where
@@ -269,30 +306,30 @@ instance FromField Null where
269306-- | bool
270307instance FromField Bool where
271308 fromField f bs
272− | typeOid f /= $(inlineTypoid TI.bool) = returnError Incompatible f ""
309+ | typeOid f /= TI.boolOid = returnError Incompatible f ""
273310 | bs == Nothing = returnError UnexpectedNull f ""
274311 | bs == Just "t" = pure True
275312 | bs == Just "f" = pure False
276313 | otherwise = returnError ConversionFailed f ""
277314
278−-- | \"char\"
315+-- | \"char\", bpchar
279316instance FromField Char where
280− fromField f bs =
281− if typeOid f /= $(inlineTypoid TI.char)
282− then returnError Incompatible f ""
283− else case bs of
317+ fromField f bs0 =
318+ if (eq TI.charOid \/ eq TI.bpcharOid) (typeOid f)
319+ then case bs0 of
284320 Nothing -> returnError UnexpectedNull f ""
285321 Just bs -> if B.length bs /= 1
286322 then returnError ConversionFailed f "length not 1"
287323 else return $! (B.head bs)
324+ else returnError Incompatible f ""
288325
289326-- | int2
290327instance FromField Int16 where
291− fromField = atto ok16 $ signed decimal
328+ fromField = attoFieldParser ok16 $ signed decimal
292329
293330-- | int2, int4
294331instance FromField Int32 where
295− fromField = atto ok32 $ signed decimal
332+ fromField = attoFieldParser ok32 $ signed decimal
296333
297334#if WORD_SIZE_IN_BITS < 64
298335-- | int2, int4, and if compiled as 64-bit code, int8 as well.
@@ -302,50 +339,64 @@ instance FromField Int32 where
302339-- This library was compiled as 64-bit code.
303340#endif
304341instance FromField Int where
305− fromField = atto okInt $ signed decimal
342+ fromField = attoFieldParser okInt $ signed decimal
306343
307344-- | int2, int4, int8
308345instance FromField Int64 where
309− fromField = atto ok64 $ signed decimal
346+ fromField = attoFieldParser ok64 $ signed decimal
310347
311348-- | int2, int4, int8
312349instance FromField Integer where
313− fromField = atto ok64 $ signed decimal
350+ fromField = attoFieldParser ok64 $ signed decimal
314351
315352-- | int2, float4 (Uses attoparsec's 'double' routine, for
316353-- better accuracy convert to 'Scientific' or 'Rational' first)
317354instance FromField Float where
318− fromField = atto ok (realToFrac <$> double)
319− where ok = $(mkCompats [TI.float4,TI.int2])
355+ fromField = attoFieldParser ok (realToFrac <$> pg_double)
356+ where ok = eq TI.float4Oid \/ eq TI.int2Oid
320357
321358-- | int2, int4, float4, float8 (Uses attoparsec's 'double' routine, for
322359-- better accuracy convert to 'Scientific' or 'Rational' first)
323360instance FromField Double where
324− fromField = atto ok double
325− 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
326363
327−-- | int2, int4, float4, float8, numeric
364+-- | int2, int4, int8, float4, float8, numeric
328365instance FromField (Ratio Integer) where
329− fromField = atto ok rational
330− where ok = $(mkCompats [TI.float4,TI.float8,TI.int2,TI.int4,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
331368
332−-- | int2, int4, float4, float8, numeric
369+-- | int2, int4, int8, float4, float8, numeric
333370instance FromField Scientific where
334− fromField = atto ok rational
335− where ok = $(mkCompats [TI.float4,TI.float8,TI.int2,TI.int4,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
336373
337374unBinary :: Binary t -> t
338375unBinary (Binary x) = x
339376
377+pg_double :: Parser Double
378+pg_double
379+ = (string "NaN" *> pure ( 0 / 0))
380+ <|> (string "Infinity" *> pure ( 1 / 0))
381+ <|> (string "-Infinity" *> pure (-1 / 0))
382+ <|> double
383+
384+pg_rational :: Parser Rational
385+pg_rational
386+ = (string "NaN" *> pure notANumber )
387+ <|> (string "Infinity" *> pure infinity )
388+ <|> (string "-Infinity" *> pure (-infinity))
389+ <|> rational
390+
340391-- | bytea, name, text, \"char\", bpchar, varchar, unknown
341392instance FromField SB.ByteString where
342− fromField f dat = if typeOid f == $(inlineTypoid TI.bytea)
393+ fromField f dat = if typeOid f == TI.byteaOid
343394 then unBinary <$> fromField f dat
344395 else doFromField f okText' pure dat
345396
346397-- | oid
347398instance FromField PQ.Oid where
348− fromField f dat = PQ.Oid <$> atto (== $(inlineTypoid TI.oid)) decimal f dat
399+ fromField f dat = PQ.Oid <$> attoFieldParser (== TI.oidOid) decimal f dat
349400
350401-- | bytea, name, text, \"char\", bpchar, varchar, unknown
351402instance FromField LB.ByteString where
@@ -353,7 +404,7 @@ instance FromField LB.ByteString where
353404
354405unescapeBytea :: Field -> SB.ByteString
355406 -> Conversion (Binary SB.ByteString)
356−unescapeBytea f str = case unsafeDupablePerformIO (PQ.unescapeBytea str) of
407+unescapeBytea f str' = case unsafeDupablePerformIO (PQ.unescapeBytea str') of
357408 Nothing -> returnError ConversionFailed f "unescapeBytea failed"
358409 Just str -> pure (Binary str)
359410
@@ -376,54 +427,85 @@ instance FromField ST.Text where
376427instance FromField LT.Text where
377428 fromField f dat = LT.fromStrict <$> fromField f dat
378429
430+-- | citext
431+instance FromField (CI ST.Text) where
432+ fromField f mdat = do
433+ typ <- typename f
434+ if typ /= "citext"
435+ then returnError Incompatible f ""
436+ else case mdat of
437+ Nothing -> returnError UnexpectedNull f ""
438+ Just dat -> either left (pure . CI.mk)
439+ (ST.decodeUtf8' dat)
440+
441+-- | citext
442+instance FromField (CI LT.Text) where
443+ fromField f mdat = do
444+ typ <- typename f
445+ if typ /= "citext"
446+ then returnError Incompatible f ""
447+ else case mdat of
448+ Nothing -> returnError UnexpectedNull f ""
449+ Just dat -> either left (pure . CI.mk . LT.fromStrict)
450+ (ST.decodeUtf8' dat)
451+
379452-- | name, text, \"char\", bpchar, varchar
380453instance FromField [Char] where
381454 fromField f dat = ST.unpack <$> fromField f dat
382455
383456-- | timestamptz
384457instance FromField UTCTime where
385− fromField = ff $(inlineTypoid TI.timestamptz) "UTCTime" parseUTCTime
458+ fromField = ff TI.timestamptzOid "UTCTime" parseUTCTime
386459
387460-- | timestamptz
388461instance FromField ZonedTime where
389− fromField = ff $(inlineTypoid TI.timestamptz) "ZonedTime" parseZonedTime
462+ fromField = ff TI.timestamptzOid "ZonedTime" parseZonedTime
390463
391464-- | timestamp
392465instance FromField LocalTime where
393− fromField = ff $(inlineTypoid TI.timestamp) "LocalTime" parseLocalTime
466+ fromField = ff TI.timestampOid "LocalTime" parseLocalTime
394467
395468-- | date
396469instance FromField Day where
397− fromField = ff $(inlineTypoid TI.date) "Day" parseDay
470+ fromField = ff TI.dateOid "Day" parseDay
398471
399472-- | time
400473instance FromField TimeOfDay where
401− fromField = ff $(inlineTypoid TI.time) "TimeOfDay" parseTimeOfDay
474+ fromField = ff TI.timeOid "TimeOfDay" parseTimeOfDay
402475
403476-- | timestamptz
404477instance FromField UTCTimestamp where
405− fromField = ff $(inlineTypoid TI.timestamptz) "UTCTimestamp" parseUTCTimestamp
478+ fromField = ff TI.timestamptzOid "UTCTimestamp" parseUTCTimestamp
406479
407480-- | timestamptz
408481instance FromField ZonedTimestamp where
409− fromField = ff $(inlineTypoid TI.timestamptz) "ZonedTimestamp" parseZonedTimestamp
482+ fromField = ff TI.timestamptzOid "ZonedTimestamp" parseZonedTimestamp
410483
411484-- | timestamp
412485instance FromField LocalTimestamp where
413− fromField = ff $(inlineTypoid TI.timestamp) "LocalTimestamp" parseLocalTimestamp
486+ fromField = ff TI.timestampOid "LocalTimestamp" parseLocalTimestamp
414487
415488-- | date
416489instance FromField Date where
417− 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
418500
419501ff :: PQ.Oid -> String -> (B8.ByteString -> Either String a)
420502 -> Field -> Maybe B8.ByteString -> Conversion a
421−ff compatOid hsType parse f mstr =
503+ff compatOid hsType parseBS f mstr =
422504 if typeOid f /= compatOid
423505 then err Incompatible ""
424506 else case mstr of
425507 Nothing -> err UnexpectedNull ""
426− Just str -> case parse str of
508+ Just str -> case parseBS str of
427509 Left msg -> err ConversionFailed msg
428510 Right val -> return val
429511 where
@@ -445,27 +527,29 @@ instance (FromField a, FromField b) => FromField (Either a b) where
445527
446528-- | any postgresql array whose elements are compatible with type @a@
447529instance (FromField a, Typeable a) => FromField (PGArray a) where
448− fromField f mdat = do
530+ fromField = pgArrayFieldParser fromField
531+
532+pgArrayFieldParser :: Typeable a => FieldParser a -> FieldParser (PGArray a)
533+pgArrayFieldParser fieldParser f mdat = do
449534 info <- typeInfo f
450535 case info of
451536 TI.Array{} ->
452537 case mdat of
453538 Nothing -> returnError UnexpectedNull f ""
454539 Just dat -> do
455− case parseOnly (fromArray info f) dat of
540+ case parseOnly (fromArray fieldParser info f) dat of
456541 Left err -> returnError ConversionFailed f err
457542 Right conv -> PGArray <$> conv
458543 _ -> returnError Incompatible f ""
459544
460−fromArray :: (FromField a)
461− => TypeInfo -> Field -> Parser (Conversion [a])
462−fromArray typeInfo f = sequence . (parseIt <$>) <$> array delim
545+fromArray :: FieldParser a -> TypeInfo -> Field -> Parser (Conversion [a])
546+fromArray fieldParser typInfo f = sequence . (parseIt <$>) <$> array delim
463547 where
464− delim = typdelim (typelem typeInfo)
465− fElem = f{ typeOid = typoid (typelem typeInfo) }
548+ delim = typdelim (typelem typInfo)
549+ fElem = f{ typeOid = typoid (typelem typInfo) }
466550
467551 parseIt item =
468− fromField f' $ if item' == "NULL" then Nothing else Just item'
552+ fieldParser f' $ if item == Arrays.Plain "NULL" then Nothing else Just item'
469553 where
470554 item' = fmt delim item
471555 f' | Arrays.Array _ <- item = f
@@ -480,7 +564,7 @@ instance (FromField a, Typeable a) => FromField (IOVector a) where
480564-- | uuid
481565instance FromField UUID where
482566 fromField f mbs =
483− if typeOid f /= $(inlineTypoid TI.uuid)
567+ if typeOid f /= TI.uuidOid
484568 then returnError Incompatible f ""
485569 else case mbs of
486570 Nothing -> returnError UnexpectedNull f ""
@@ -489,26 +573,26 @@ instance FromField UUID where
489573 Nothing -> returnError ConversionFailed f "Invalid UUID"
490574 Just uuid -> pure uuid
491575
492−-- | json
576+-- | json, jsonb
493577instance FromField JSON.Value where
494− fromField f mbs =
495− if typeOid f /= $(inlineTypoid TI.json)
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
496589 then returnError Incompatible f ""
497590 else case mbs of
498591 Nothing -> returnError UnexpectedNull f ""
499− Just bs ->
500−#if MIN_VERSION_aeson(0,6,3)
501− case JSON.eitherDecodeStrict' bs of
502−#elif MIN_VERSION_bytestring(0,10,0)
503− case JSON.eitherDecode' $ LB.fromStrict bs of
504−#else
505− case JSON.eitherDecode' $ LB.fromChunks [bs] of
506−#endif
507− Left err -> returnError ConversionFailed f err
508− Right val -> pure val
592+ Just bs -> pure bs
509593
510594-- | Parse a field to a JSON 'JSON.Value' and convert that into a
511−-- Haskell value using 'JSON.fromJSON'.
595+-- Haskell value using the 'JSON.FromJSON' instance.
512596--
513597-- This can be used as the default implementation for the 'fromField'
514598-- method for Haskell types that have a JSON representation in
@@ -516,14 +600,23 @@ instance FromField JSON.Value where
516600--
517601-- The 'Typeable' constraint is required to show more informative
518602-- 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@
519613fromJSONField :: (JSON.FromJSON a, Typeable a) => FieldParser a
520614fromJSONField f mbBs = do
521615 value <- fromField f mbBs
522− case JSON.fromJSON value of
523− JSON.Error err -> returnError ConversionFailed f $
524− "JSON decoding error: " ++ err
525− JSON.Success x -> pure x
526−
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
527620
528621-- | Compatible with the same set of types as @a@. Note that
529622-- modifying the 'IORef' does not have any effects outside
@@ -540,20 +633,33 @@ instance FromField a => FromField (MVar a) where
540633type Compat = PQ.Oid -> Bool
541634
542635okText, okText', okBinary, ok16, ok32, ok64, okInt :: Compat
543−okText = $( mkCompats [ TI.name, TI.text, TI.char,
544− TI.bpchar, TI.varchar ] )
545−okText' = $( mkCompats [ TI.name, TI.text, TI.char,
546− TI.bpchar, TI.varchar, TI.unknown ] )
547−okBinary = (== $( inlineTypoid TI.bytea ))
548−ok16 = (== $( inlineTypoid TI.int2 ))
549−ok32 = $( mkCompats [TI.int2,TI.int4] )
550−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
551644#if WORD_SIZE_IN_BITS < 64
552645okInt = ok32
553646#else
554647okInt = ok64
555648#endif
556649
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+
557663doFromField :: forall a . (Typeable a)
558664 => Field -> Compat -> (ByteString -> Conversion a)
559665 -> Maybe ByteString -> Conversion a
@@ -578,10 +684,22 @@ returnError mkErr f msg = do
578684 (show (typeOf (undefined :: a)))
579685 msg
580686
581−atto :: forall a. (Typeable a)
582− => Compat -> Parser a -> Field -> Maybe ByteString
583− -> Conversion a
584−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
585703 where
586704 go :: Parser a -> ByteString -> Conversion a
587705 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+3−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------------------------------------------------------------------------------
@@ -28,6 +28,7 @@ module Database.PostgreSQL.Simple.HStore
2828 , toBuilder
2929 , toLazyByteString
3030 , hstore
31+ , parseHStoreList
3132 , ToHStoreText(..)
3233 , HStoreText
3334 ) where
src/Database/PostgreSQL/Simple/HStore/Implementation.hs+27−21
@@ -15,17 +15,13 @@
1515module Database.PostgreSQL.Simple.HStore.Implementation where
1616
1717import Control.Applicative
18−import Blaze.ByteString.Builder as Blaze
19− ( Builder, toLazyByteString, copyByteString )
20−import Blaze.ByteString.Builder.Char8 (fromChar)
2118import qualified Data.Attoparsec.ByteString as P
2219import qualified Data.Attoparsec.ByteString.Char8 as P (isSpace_w8)
2320import qualified Data.ByteString as BS
21+import Data.ByteString.Builder (Builder, byteString, char8)
22+import qualified Data.ByteString.Builder as BU
2423import Data.ByteString.Internal (c2w, w2c)
2524import qualified Data.ByteString.Lazy as BL
26−#if !MIN_VERSION_bytestring(0,10,0)
27−import qualified Data.ByteString.Lazy.Internal as BL (foldrChunks)
28−#endif
2925import Data.Map(Map)
3026import qualified Data.Map as Map
3127import Data.Text(Text)
@@ -35,6 +31,7 @@ import Data.Text.Encoding.Error(UnicodeException)
3531import qualified Data.Text.Lazy as TL
3632import Data.Typeable
3733import Data.Monoid(Monoid(..))
34+import Data.Semigroup
3835import Database.PostgreSQL.Simple.FromField
3936import Database.PostgreSQL.Simple.ToField
4037
@@ -53,26 +50,28 @@ instance ToHStore HStoreBuilder where
5350toBuilder :: HStoreBuilder -> Builder
5451toBuilder x = case x of
5552 Empty -> mempty
56− Comma x -> x
53+ Comma c -> c
5754
5855toLazyByteString :: HStoreBuilder -> BL.ByteString
5956toLazyByteString x = case x of
6057 Empty -> BL.empty
61− Comma x -> Blaze.toLazyByteString x
58+ Comma c -> BU.toLazyByteString c
6259
63−instance Monoid HStoreBuilder where
64− mempty = Empty
65− mappend Empty x = x
66− mappend (Comma a) x
60+instance Semigroup HStoreBuilder where
61+ Empty <> x = x
62+ Comma a <> x
6763 = Comma (a `mappend` case x of
6864 Empty -> mempty
69− Comma b -> fromChar ',' `mappend` b)
65+ Comma b -> char8 ',' `mappend` b)
66+
67+instance Monoid HStoreBuilder where
68+ mempty = Empty
7069
7170class ToHStoreText a where
7271 toHStoreText :: a -> HStoreText
7372
7473-- | Represents escape text, ready to be the key or value to a hstore value
75−newtype HStoreText = HStoreText Builder deriving (Typeable, Monoid)
74+newtype HStoreText = HStoreText Builder deriving (Typeable, Semigroup, Monoid)
7675
7776instance ToHStoreText HStoreText where
7877 toHStoreText = id
@@ -95,24 +94,24 @@ escapeAppend :: BS.ByteString -> Builder -> Builder
9594escapeAppend = loop
9695 where
9796 loop (BS.break quoteNeeded -> (a,b)) rest
98− = copyByteString a `mappend`
97+ = byteString a `mappend`
9998 case BS.uncons b of
10099 Nothing -> rest
101100 Just (c,d) -> quoteChar c `mappend` loop d rest
102101
103102 quoteNeeded c = c == c2w '\"' || c == c2w '\\'
104103 quoteChar c
105− | c == c2w '\"' = copyByteString "\\\""
106− | otherwise = copyByteString "\\\\"
104+ | c == c2w '\"' = byteString "\\\""
105+ | otherwise = byteString "\\\\"
107106
108107hstore :: (ToHStoreText a, ToHStoreText b) => a -> b -> HStoreBuilder
109108hstore (toHStoreText -> (HStoreText key)) (toHStoreText -> (HStoreText val)) =
110− Comma (fromChar '"' `mappend` key `mappend` copyByteString "\"=>\""
111− `mappend` val `mappend` fromChar '"')
109+ Comma (char8 '"' `mappend` key `mappend` byteString "\"=>\""
110+ `mappend` val `mappend` char8 '"')
112111
113112instance ToField HStoreBuilder where
114113 toField Empty = toField (BS.empty)
115− toField (Comma x) = toField (Blaze.toLazyByteString x)
114+ toField (Comma x) = toField (BU.toLazyByteString x)
116115
117116newtype HStoreList = HStoreList {fromHStoreList :: [(Text,Text)]} deriving (Typeable, Show)
118117
@@ -145,7 +144,7 @@ newtype HStoreMap = HStoreMap {fromHStoreMap :: Map Text Text} deriving (Eq, Or
145144
146145instance ToHStore HStoreMap where
147146 toHStore (HStoreMap xs) = Map.foldrWithKey f mempty xs
148− where f k v xs = hstore k v `mappend` xs
147+ where f k v xs' = hstore k v `mappend` xs'
149148
150149instance ToField HStoreMap where
151150 toField xs = toField (toHStore xs)
@@ -154,6 +153,13 @@ instance FromField HStoreMap where
154153 fromField f mdat = convert <$> fromField f mdat
155154 where convert (HStoreList xs) = HStoreMap (Map.fromList xs)
156155
156+parseHStoreList :: BS.ByteString -> Either String HStoreList
157+parseHStoreList dat =
158+ case P.parseOnly (parseHStore <* P.endOfInput) dat of
159+ Left err -> Left (show err)
160+ Right (Left err) -> Left (show err)
161+ Right (Right val) -> Right val
162+
157163parseHStore :: P.Parser (Either UnicodeException HStoreList)
158164parseHStore = do
159165 kvs <- P.sepBy' (skipWhiteSpace *> parseHStoreKeyVal)
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+306−29
@@ -1,12 +1,13 @@
1−{-# LANGUAGE BangPatterns #-}
2−{-# LANGUAGE DeriveDataTypeable #-}
3−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4−{-# LANGUAGE RecordWildCards #-}
1+{-# LANGUAGE CPP, BangPatterns, DoAndIfThenElse, RecordWildCards #-}
2+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}
3+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4+{-# LANGUAGE ExistentialQuantification #-}
5+{-# LANGUAGE InstanceSigs #-}
56
67------------------------------------------------------------------------------
78-- |
89-- Module: Database.PostgreSQL.Simple.Internal
9−-- Copyright: (c) 2011-2012 Leon P Smith
10+-- Copyright: (c) 2011-2015 Leon P Smith
1011-- License: BSD3
1112-- Maintainer: Leon P Smith <leon@melding-monads.com>
1213-- Stability: experimental
@@ -27,25 +28,35 @@ import Control.Exception
2728import Control.Concurrent.MVar
2829import Control.Monad(MonadPlus(..))
2930import Data.ByteString(ByteString)
31+import qualified Data.ByteString as B
3032import qualified Data.ByteString.Char8 as B8
33+import Data.ByteString.Builder ( Builder, byteString )
3134import Data.Char (ord)
3235import Data.Int (Int64)
3336import qualified Data.IntMap as IntMap
3437import Data.IORef
3538import Data.Maybe(fromMaybe)
3639import Data.String
40+import qualified Data.Text as T
41+import qualified Data.Text.Encoding as TE
3742import Data.Typeable
3843import Data.Word
3944import Database.PostgreSQL.LibPQ(Oid(..))
4045import qualified Database.PostgreSQL.LibPQ as PQ
4146import Database.PostgreSQL.LibPQ(ExecStatus(..))
47+import Database.PostgreSQL.Simple.Compat ( toByteString )
4248import Database.PostgreSQL.Simple.Ok
49+import Database.PostgreSQL.Simple.ToField (Action(..), inQuotes)
4350import Database.PostgreSQL.Simple.Types (Query(..))
4451import Database.PostgreSQL.Simple.TypeInfo.Types(TypeInfo)
4552import Control.Monad.Trans.State.Strict
4653import Control.Monad.Trans.Reader
4754import Control.Monad.Trans.Class
55+import GHC.Generics
4856import GHC.IO.Exception
57+#if !defined(mingw32_HOST_OS)
58+import Control.Concurrent(threadWaitRead, threadWaitWrite)
59+#endif
4960
5061-- | A Field represents metadata about a particular field
5162--
@@ -67,7 +78,29 @@ data Connection = Connection {
6778 connectionHandle :: {-# UNPACK #-} !(MVar PQ.Connection)
6879 , connectionObjects :: {-# UNPACK #-} !(MVar TypeInfoCache)
6980 , connectionTempNameCounter :: {-# UNPACK #-} !(IORef Int64)
70− }
81+ } deriving (Typeable)
82+
83+instance Eq Connection where
84+ x == y = connectionHandle x == connectionHandle y
85+
86+-- | Superclass for postgresql exceptions
87+data SomePostgreSqlException = forall e. Exception e => SomePostgreSqlException e
88+ deriving Typeable
89+
90+postgresqlExceptionToException :: Exception e => e -> SomeException
91+postgresqlExceptionToException = toException . SomePostgreSqlException
92+
93+postgresqlExceptionFromException :: Exception e => SomeException -> Maybe e
94+postgresqlExceptionFromException x = do
95+ SomePostgreSqlException a <- fromException x
96+ cast a
97+
98+instance Show SomePostgreSqlException where
99+ showsPrec :: Int -> SomePostgreSqlException -> ShowS
100+ showsPrec p (SomePostgreSqlException e) = showsPrec p e
101+
102+instance Exception SomePostgreSqlException where
103+ displayException (SomePostgreSqlException e) = displayException e
71104
72105data SqlError = SqlError {
73106 sqlState :: ByteString
@@ -75,12 +108,15 @@ data SqlError = SqlError {
75108 , sqlErrorMsg :: ByteString
76109 , sqlErrorDetail :: ByteString
77110 , sqlErrorHint :: ByteString
78− } deriving (Show, Typeable)
111+ } deriving (Eq, Show, Typeable)
79112
80113fatalError :: ByteString -> SqlError
81114fatalError msg = SqlError "" FatalError msg "" ""
82115
83−instance Exception SqlError
116+instance Exception SqlError where
117+ toException = postgresqlExceptionToException
118+ fromException = postgresqlExceptionFromException
119+
84120
85121-- | Exception thrown if 'query' is used to perform an @INSERT@-like
86122-- operation, or 'execute' is used to perform a @SELECT@-like operation.
@@ -89,7 +125,22 @@ data QueryError = QueryError {
89125 , qeQuery :: Query
90126 } deriving (Eq, Show, Typeable)
91127
92−instance Exception QueryError
128+instance Exception QueryError where
129+ toException = postgresqlExceptionToException
130+ fromException = postgresqlExceptionFromException
131+
132+-- | Exception thrown if a 'Query' could not be formatted correctly.
133+-- This may occur if the number of \'@?@\' characters in the query
134+-- string does not match the number of parameters provided.
135+data FormatError = FormatError {
136+ fmtMessage :: String
137+ , fmtQuery :: Query
138+ , fmtParams :: [ByteString]
139+ } deriving (Eq, Show, Typeable)
140+
141+instance Exception FormatError where
142+ toException = postgresqlExceptionToException
143+ fromException = postgresqlExceptionFromException
93144
94145data ConnectInfo = ConnectInfo {
95146 connectHost :: String
@@ -97,7 +148,7 @@ data ConnectInfo = ConnectInfo {
97148 , connectUser :: String
98149 , connectPassword :: String
99150 , connectDatabase :: String
100− } deriving (Eq,Read,Show,Typeable)
151+ } deriving (Generic,Eq,Read,Show,Typeable)
101152
102153-- | Default information for setting up a connection.
103154--
@@ -131,13 +182,85 @@ defaultConnectInfo = ConnectInfo {
131182connect :: ConnectInfo -> IO Connection
132183connect = connectPostgreSQL . postgreSQLConnectionString
133184
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+
134191-- | Attempt to make a connection based on a libpq connection string.
135−-- See <http://www.postgresql.org/docs/9.1/static/libpq-connect.html>
136−-- for more information.
192+-- See <https://www.postgresql.org/docs/9.5/static/libpq-connect.html#LIBPQ-CONNSTRING>
193+-- for more information. Also note that environment variables also affect
194+-- parameters not provided, parameters provided as the empty string, and a
195+-- few other things; see
196+-- <https://www.postgresql.org/docs/9.5/static/libpq-envars.html>
197+-- for details. Here is an example with some of the most commonly used
198+-- parameters:
199+--
200+-- > host='db.somedomain.com' port=5432 ...
201+--
202+-- This attempts to connect to @db.somedomain.com:5432@. Omitting the port
203+-- will normally default to 5432.
204+--
205+-- On systems that provide unix domain sockets, omitting the host parameter
206+-- will cause libpq to attempt to connect via unix domain sockets.
207+-- The default filesystem path to the socket is constructed from the
208+-- port number and the @DEFAULT_PGSOCKET_DIR@ constant defined in the
209+-- @pg_config_manual.h@ header file. Connecting via unix sockets tends
210+-- to use the @peer@ authentication method, which is very secure and
211+-- does not require a password.
212+--
213+-- On Windows and other systems without unix domain sockets, omitting
214+-- the host will default to @localhost@.
215+--
216+-- > ... dbname='postgres' user='postgres' password='secret \' \\ pw'
217+--
218+-- This attempts to connect to a database named @postgres@ with
219+-- user @postgres@ and password @secret \' \\ pw@. Backslash
220+-- characters will have to be double-quoted in literal Haskell strings,
221+-- of course. Omitting @dbname@ and @user@ will both default to the
222+-- system username that the client process is running as.
223+--
224+-- Omitting @password@ will default to an appropriate password found
225+-- in the @pgpass@ file, or no password at all if a matching line is
226+-- not found. The path of the @pgpass@ file may be specified by setting
227+-- the @PGPASSFILE@ environment variable. See
228+-- <https://www.postgresql.org/docs/9.5/static/libpq-pgpass.html> for
229+-- more information regarding this file.
230+--
231+-- As all parameters are optional and the defaults are sensible, the
232+-- empty connection string can be useful for development and
233+-- exploratory use, assuming your system is set up appropriately.
234+--
235+-- On Unix, such a setup would typically consist of a local
236+-- postgresql server listening on port 5432, as well as a system user,
237+-- database user, and database sharing a common name, with permissions
238+-- granted to the user on the database.
239+--
240+-- On Windows, in addition you will either need @pg_hba.conf@
241+-- to specify the use of the @trust@ authentication method for
242+-- the connection, which may not be appropriate for multiuser
243+-- or production machines, or you will need to use a @pgpass@ file
244+-- with the @password@ or @md5@ authentication methods.
245+--
246+-- See <https://www.postgresql.org/docs/9.5/static/client-authentication.html>
247+-- for more information regarding the authentication process.
248+--
249+-- SSL/TLS will typically "just work" if your postgresql server supports or
250+-- requires it. However, note that libpq is trivially vulnerable to a MITM
251+-- attack without setting additional SSL connection parameters. In
252+-- particular, @sslmode@ needs to be set to @require@, @verify-ca@, or
253+-- @verify-full@ in order to perform certificate validation. When @sslmode@
254+-- is @require@, then you will also need to specify a @sslrootcert@ file,
255+-- otherwise no validation of the server's identity will be performed.
256+-- Client authentication via certificates is also possible via the
257+-- @sslcert@ and @sslkey@ parameters. See
258+-- <https://www.postgresql.org/docs/9.5/static/libpq-ssl.html>
259+-- for detailed information regarding libpq and SSL.
137260
138261connectPostgreSQL :: ByteString -> IO Connection
139262connectPostgreSQL connstr = do
140− conn <- PQ.connectdb connstr
263+ conn <- connectdb connstr
141264 stat <- PQ.status conn
142265 case stat of
143266 PQ.ConnectionOk -> do
@@ -147,15 +270,45 @@ connectPostgreSQL connstr = do
147270 let wconn = Connection{..}
148271 version <- PQ.serverVersion conn
149272 let settings
150− | version < 80200 = "SET datestyle TO ISO"
151− | otherwise = "SET standard_conforming_strings TO on;\
152− \SET datestyle TO ISO"
273+ | version < 80200 = "SET datestyle TO ISO;SET client_encoding TO UTF8"
274+ | otherwise = "SET datestyle TO ISO;SET client_encoding TO UTF8;SET standard_conforming_strings TO on"
153275 _ <- execute_ wconn settings
154276 return wconn
155277 _ -> do
156278 msg <- maybe "connectPostgreSQL error" id <$> PQ.errorMessage conn
157279 throwIO $ fatalError msg
158280
281+connectdb :: ByteString -> IO PQ.Connection
282+#if defined(mingw32_HOST_OS)
283+connectdb = PQ.connectdb
284+#else
285+connectdb conninfo = do
286+ conn <- PQ.connectStart conninfo
287+ loop conn
288+ where
289+ funcName = "Database.PostgreSQL.Simple.connectPostgreSQL"
290+ loop conn = do
291+ status <- PQ.connectPoll conn
292+ case status of
293+ PQ.PollingFailed -> throwLibPQError conn "connection failed"
294+ PQ.PollingReading -> do
295+ mfd <- PQ.socket conn
296+ case mfd of
297+ Nothing -> throwIO $! fdError funcName
298+ Just fd -> do
299+ threadWaitRead fd
300+ loop conn
301+ PQ.PollingWriting -> do
302+ mfd <- PQ.socket conn
303+ case mfd of
304+ Nothing -> throwIO $! fdError funcName
305+ Just fd -> do
306+ threadWaitWrite fd
307+ loop conn
308+ PQ.PollingOk -> return conn
309+
310+#endif
311+
159312-- | Turns a 'ConnectInfo' data structure into a libpq connection string.
160313
161314postgreSQLConnectionString :: ConnectInfo -> ByteString
@@ -170,7 +323,7 @@ postgreSQLConnectionString connectInfo = fromString connstr
170323
171324 str name field
172325 | null value = id
173− | otherwise = showString name . quote value . space
326+ | otherwise = showString name . addQuotes value . space
174327 where value = field connectInfo
175328
176329 num name field
@@ -178,7 +331,7 @@ postgreSQLConnectionString connectInfo = fromString connstr
178331 | otherwise = showString name . shows value . space
179332 where value = field connectInfo
180333
181− quote str rest = '\'' : foldr delta ('\'' : rest) str
334+ addQuotes s rest = '\'' : foldr delta ('\'' : rest) s
182335 where
183336 delta c cs = case c of
184337 '\\' -> '\\' : '\\' : cs
@@ -197,15 +350,53 @@ oid2int (Oid x) = fromIntegral x
197350exec :: Connection
198351 -> ByteString
199352 -> IO PQ.Result
353+#if defined(mingw32_HOST_OS)
200354exec conn sql =
201355 withConnection conn $ \h -> do
202356 mres <- PQ.exec h sql
203357 case mres of
204− Nothing -> do
205− msg <- maybe "execute error" id <$> PQ.errorMessage h
206− throwIO $ fatalError msg
207− Just res -> do
208− return res
358+ Nothing -> throwLibPQError h "PQexec returned no results"
359+ Just res -> return res
360+#else
361+exec conn sql =
362+ withConnection conn $ \h -> do
363+ success <- PQ.sendQuery h sql
364+ if success
365+ then awaitResult h Nothing
366+ else throwLibPQError h "PQsendQuery failed"
367+ where
368+ awaitResult h mres = do
369+ mfd <- PQ.socket h
370+ case mfd of
371+ Nothing -> throwIO $! fdError "Database.PostgreSQL.Simple.Internal.exec"
372+ Just fd -> do
373+ threadWaitRead fd
374+ _ <- PQ.consumeInput h -- FIXME?
375+ getResult h mres
376+
377+ getResult h mres = do
378+ isBusy <- PQ.isBusy h
379+ if isBusy
380+ then awaitResult h mres
381+ else do
382+ mres' <- PQ.getResult h
383+ case mres' of
384+ Nothing -> case mres of
385+ Nothing -> throwLibPQError h "PQgetResult returned no results"
386+ Just res -> return res
387+ Just res -> do
388+ status <- PQ.resultStatus res
389+ case status of
390+ -- FIXME: handle PQ.CopyBoth and PQ.SingleTuple
391+ PQ.EmptyQuery -> getResult h mres'
392+ PQ.CommandOk -> getResult h mres'
393+ PQ.TuplesOk -> getResult h mres'
394+ PQ.CopyOut -> return res
395+ PQ.CopyIn -> return res
396+ PQ.BadResponse -> getResult h mres'
397+ PQ.NonfatalError -> getResult h mres'
398+ PQ.FatalError -> getResult h mres'
399+#endif
209400
210401-- | A version of 'execute' that does not perform query substitution.
211402execute_ :: Connection -> Query -> IO Int64
@@ -217,6 +408,7 @@ finishExecute :: Connection -> Query -> PQ.Result -> IO Int64
217408finishExecute _conn q result = do
218409 status <- PQ.resultStatus result
219410 case status of
411+ -- FIXME: handle PQ.CopyBoth and PQ.SingleTuple
220412 PQ.EmptyQuery -> throwIO $ QueryError "execute: Empty query" q
221413 PQ.CommandOk -> do
222414 ncols <- PQ.nfields result
@@ -227,7 +419,7 @@ finishExecute _conn q result = do
227419 nstr <- PQ.cmdTuples result
228420 return $ case nstr of
229421 Nothing -> 0 -- is this appropriate?
230− Just str -> toInteger str
422+ Just str -> mkInteger str
231423 PQ.TuplesOk -> do
232424 ncols <- PQ.nfields result
233425 throwIO $ QueryError ("execute resulted in " ++ show ncols ++
@@ -240,7 +432,7 @@ finishExecute _conn q result = do
240432 PQ.NonfatalError -> throwResultError "execute" result status
241433 PQ.FatalError -> throwResultError "execute" result status
242434 where
243− toInteger str = B8.foldl' delta 0 str
435+ mkInteger str = B8.foldl' delta 0 str
244436 where
245437 delta acc c =
246438 if '0' <= c && c <= '9'
@@ -255,8 +447,8 @@ throwResultError _ result status = do
255447 PQ.resultErrorField result PQ.DiagMessageDetail
256448 hint <- fromMaybe "" <$>
257449 PQ.resultErrorField result PQ.DiagMessageHint
258− state <- maybe "" id <$> PQ.resultErrorField result PQ.DiagSqlstate
259− throwIO $ SqlError { sqlState = state
450+ state' <- maybe "" id <$> PQ.resultErrorField result PQ.DiagSqlstate
451+ throwIO $ SqlError { sqlState = state'
260452 , sqlExecStatus = status
261453 , sqlErrorMsg = errormsg
262454 , sqlErrorDetail = detail
@@ -325,7 +517,6 @@ instance Alternative Conversion where
325517 Errors _ -> (oka <|>) <$> runConversion mb conn
326518
327519instance Monad Conversion where
328− return a = Conversion $ \_conn -> return (return a)
329520 m >>= f = Conversion $ \conn -> do
330521 oka <- runConversion m conn
331522 case oka of
@@ -340,7 +531,7 @@ conversionMap :: (Ok a -> Ok b) -> Conversion a -> Conversion b
340531conversionMap f m = Conversion $ \conn -> f <$> runConversion m conn
341532
342533conversionError :: Exception err => err -> Conversion a
343−conversionError err = Conversion $ \_ -> return (Errors [SomeException err])
534+conversionError err = Conversion $ \_ -> return (Errors [toException err])
344535
345536newTempName :: Connection -> IO Query
346537newTempName Connection{..} = do
@@ -358,3 +549,89 @@ fdError funcName = IOError {
358549 ioe_errno = Nothing,
359550 ioe_filename = Nothing
360551 }
552+
553+
554+libPQError :: ByteString -> IOError
555+libPQError desc = IOError {
556+ ioe_handle = Nothing,
557+ ioe_type = OtherError,
558+ ioe_location = "libpq",
559+ ioe_description = B8.unpack desc,
560+ ioe_errno = Nothing,
561+ ioe_filename = Nothing
562+ }
563+
564+throwLibPQError :: PQ.Connection -> ByteString -> IO a
565+throwLibPQError conn default_desc = do
566+ msg <- maybe default_desc id <$> PQ.errorMessage conn
567+ throwIO $! libPQError msg
568+
569+
570+fmtError :: String -> Query -> [Action] -> a
571+fmtError msg q xs = throw FormatError {
572+ fmtMessage = msg
573+ , fmtQuery = q
574+ , fmtParams = map twiddle xs
575+ }
576+ where twiddle (Plain b) = toByteString b
577+ twiddle (Escape s) = s
578+ twiddle (EscapeByteA s) = s
579+ twiddle (EscapeIdentifier s) = s
580+ twiddle (Many ys) = B.concat (map twiddle ys)
581+
582+fmtErrorBs :: Query -> [Action] -> ByteString -> a
583+fmtErrorBs q xs msg = fmtError (T.unpack $ TE.decodeUtf8 msg) q xs
584+
585+-- | Quote bytestring or throw 'FormatError'
586+quote :: Query -> [Action] -> Either ByteString ByteString -> Builder
587+quote q xs = either (fmtErrorBs q xs) (inQuotes . byteString)
588+
589+buildAction :: Connection -- ^ Connection for string escaping
590+ -> Query -- ^ Query for message error
591+ -> [Action] -- ^ List of parameters for message error
592+ -> Action -- ^ Action to build
593+ -> IO Builder
594+buildAction _ _ _ (Plain b) = pure b
595+buildAction conn q xs (Escape s) = quote q xs <$> escapeStringConn conn s
596+buildAction conn q xs (EscapeByteA s) = quote q xs <$> escapeByteaConn conn s
597+buildAction conn q xs (EscapeIdentifier s) =
598+ either (fmtErrorBs q xs) byteString <$> escapeIdentifier conn s
599+buildAction conn q xs (Many ys) =
600+ mconcat <$> mapM (buildAction conn q xs) ys
601+
602+checkError :: PQ.Connection -> Maybe a -> IO (Either ByteString a)
603+checkError _ (Just x) = return $ Right x
604+checkError c Nothing = Left . maybe "" id <$> PQ.errorMessage c
605+
606+escapeWrap :: (PQ.Connection -> ByteString -> IO (Maybe ByteString))
607+ -> Connection
608+ -> ByteString
609+ -> IO (Either ByteString ByteString)
610+escapeWrap f conn s =
611+ withConnection conn $ \c ->
612+ f c s >>= checkError c
613+
614+escapeStringConn :: Connection -> ByteString -> IO (Either ByteString ByteString)
615+escapeStringConn = escapeWrap PQ.escapeStringConn
616+
617+escapeIdentifier :: Connection -> ByteString -> IO (Either ByteString ByteString)
618+escapeIdentifier = escapeWrap PQ.escapeIdentifier
619+
620+escapeByteaConn :: Connection -> ByteString -> IO (Either ByteString ByteString)
621+escapeByteaConn = escapeWrap PQ.escapeByteaConn
622+
623+breakOnSingleQuestionMark :: ByteString -> (ByteString, ByteString)
624+breakOnSingleQuestionMark b = go (B8.empty, b)
625+ where go (x,bs) = (x `B8.append` x',bs')
626+ -- seperate from first QM
627+ where tup@(noQ, restWithQ) = B8.break (=='?') bs
628+ -- if end of query, just return
629+ -- else check for second QM in 'go2'
630+ (x', bs') = maybe tup go2 $
631+ -- drop found QM and peek at next char
632+ B8.uncons restWithQ >>= B8.uncons . snd
633+ -- another QM after the first means:
634+ -- take literal QM and keep going.
635+ go2 ('?', t2) = go (noQ `B8.snoc` '?',t2)
636+ -- Anything else means
637+ go2 _ = tup
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+2−2
@@ -7,14 +7,14 @@
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
1414-- database transaction, so if you are interested in using anything beyond
1515-- 'loCreat', 'loCreate', and 'loUnlink', you will need to run the entire
1616-- sequence of functions in a transaction. As 'loImport' and 'loExport'
17−-- are simply C functions that call 'loCreat', 'loOpen', 'loRead', and
17+-- are simply C functions that call 'loCreat', 'loOpen', 'loRead', and
1818-- 'loWrite', and do not perform any transaction handling themselves,
1919-- they also need to be wrapped in an explicit transaction.
2020--
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.hsnew file+317
@@ -0,0 +1,317 @@
1+{-# LANGUAGE DeriveDataTypeable #-}
2+{-# LANGUAGE DeriveFunctor #-}
3+{-# LANGUAGE OverloadedStrings #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+
6+------------------------------------------------------------------------------
7+-- |
8+-- Module: Database.PostgreSQL.Simple.Range
9+-- Copyright: (c) 2014-2015 Leonid Onokhov
10+-- (c) 2014-2015 Leon P Smith
11+-- License: BSD3
12+-- Maintainer: Leon P Smith <leon@melding-monads.com>
13+--
14+------------------------------------------------------------------------------
15+
16+module Database.PostgreSQL.Simple.Range
17+ ( RangeBound(..)
18+ , PGRange(..)
19+ , empty
20+ , isEmpty, isEmptyBy
21+ , contains, containsBy
22+ , fromFieldRange
23+ ) where
24+
25+import Control.Applicative hiding (empty)
26+import Data.Attoparsec.ByteString.Char8 (Parser, parseOnly)
27+import qualified Data.Attoparsec.ByteString.Char8 as A
28+import qualified Data.ByteString as B
29+import Data.ByteString.Builder
30+ ( Builder, byteString, lazyByteString, char8
31+ , intDec, int8Dec, int16Dec, int32Dec, int64Dec, integerDec
32+ , wordDec, word8Dec, word16Dec, word32Dec, word64Dec
33+ , doubleDec, floatDec )
34+import Data.Int (Int16, Int32, Int64,
35+ Int8)
36+import Data.Function (on)
37+import Data.Monoid (mempty)
38+import Data.Scientific (Scientific)
39+import qualified Data.Text.Lazy.Builder as LT
40+import qualified Data.Text.Lazy.Encoding as LT
41+import Data.Time.Compat (Day, LocalTime,
42+ NominalDiffTime,
43+ TimeOfDay, UTCTime,
44+ ZonedTime,
45+ zonedTimeToUTC)
46+import Data.Typeable (Typeable)
47+import Data.Word (Word, Word16, Word32,
48+ Word64, Word8)
49+
50+import Database.PostgreSQL.Simple.Compat (scientificBuilder, (<>), toByteString)
51+import Database.PostgreSQL.Simple.FromField
52+import Database.PostgreSQL.Simple.Time
53+ hiding (PosInfinity, NegInfinity)
54+-- import qualified Database.PostgreSQL.Simple.Time as Time
55+import Database.PostgreSQL.Simple.ToField
56+
57+-- | Represents boundary of a range
58+data RangeBound a = NegInfinity
59+ | Inclusive !a
60+ | Exclusive !a
61+ | PosInfinity
62+ deriving (Show, Typeable, Eq, Functor)
63+
64+-- | Generic range type
65+data PGRange a = PGRange !(RangeBound a) !(RangeBound a)
66+ deriving (Show, Typeable, Functor)
67+
68+empty :: PGRange a
69+empty = PGRange PosInfinity NegInfinity
70+
71+instance Ord a => Eq (PGRange a) where
72+ x == y = eq x y || (isEmpty x && isEmpty y)
73+ where eq (PGRange a m) (PGRange b n) = a == b && m == n
74+
75+isEmptyBy :: (a -> a -> Ordering) -> PGRange a -> Bool
76+isEmptyBy cmp v =
77+ case v of
78+ (PGRange PosInfinity _) -> True
79+ (PGRange _ NegInfinity) -> True
80+ (PGRange NegInfinity _) -> False
81+ (PGRange _ PosInfinity) -> False
82+ (PGRange (Inclusive x) (Inclusive y)) -> cmp x y == GT
83+ (PGRange (Inclusive x) (Exclusive y)) -> cmp x y /= LT
84+ (PGRange (Exclusive x) (Inclusive y)) -> cmp x y /= LT
85+ (PGRange (Exclusive x) (Exclusive y)) -> cmp x y /= LT
86+
87+-- | Is a range empty? If this returns 'True', then the 'contains'
88+-- predicate will always return 'False'. However, if this returns
89+-- 'False', it is not necessarily true that there exists a point for
90+-- which 'contains' returns 'True'.
91+-- Consider @'PGRange' ('Excludes' 2) ('Excludes' 3) :: PGRange Int@,
92+-- for example.
93+isEmpty :: Ord a => PGRange a -> Bool
94+isEmpty = isEmptyBy compare
95+
96+
97+-- | Does a range contain a given point? Note that in some cases, this may
98+-- not correspond exactly with a server-side computation. Consider @UTCTime@
99+-- for example, which has a resolution of a picosecond, whereas postgresql's
100+-- @timestamptz@ types have a resolution of a microsecond. Putting such
101+-- Haskell values into the database will result in them being rounded, which
102+-- can change the value of the containment predicate.
103+
104+contains :: Ord a => PGRange a -> (a -> Bool)
105+contains = containsBy compare
106+
107+containsBy :: (a -> a -> Ordering) -> PGRange a -> (a -> Bool)
108+containsBy cmp rng x =
109+ case rng of
110+ PGRange _lb NegInfinity -> False
111+ PGRange lb ub -> checkLB lb x && checkUB ub x
112+ where
113+ checkLB lb y =
114+ case lb of
115+ NegInfinity -> True
116+ PosInfinity -> False
117+ Inclusive a -> cmp a y /= GT
118+ Exclusive a -> cmp a y == LT
119+
120+ checkUB ub y =
121+ case ub of
122+ NegInfinity -> False
123+ PosInfinity -> True
124+ Inclusive z -> cmp y z /= GT
125+ Exclusive z -> cmp y z == LT
126+
127+lowerBound :: Parser (a -> RangeBound a)
128+lowerBound = (A.char '(' *> pure Exclusive) <|> (A.char '[' *> pure Inclusive)
129+{-# INLINE lowerBound #-}
130+
131+upperBound :: Parser (a -> RangeBound a)
132+upperBound = (A.char ')' *> pure Exclusive) <|> (A.char ']' *> pure Inclusive)
133+{-# INLINE upperBound #-}
134+
135+-- | Generic range parser
136+pgrange :: Parser (RangeBound B.ByteString, RangeBound B.ByteString)
137+pgrange = do
138+ lb <- lowerBound
139+ v1 <- (A.char ',' *> "") <|> (rangeElem (==',') <* A.char ',')
140+ v2 <- rangeElem $ \c -> c == ')' || c == ']'
141+ ub <- upperBound
142+ A.endOfInput
143+ let low = if B.null v1 then NegInfinity else lb v1
144+ up = if B.null v2 then PosInfinity else ub v2
145+ return (low, up)
146+
147+rangeElem :: (Char -> Bool) -> Parser B.ByteString
148+rangeElem end = (A.char '"' *> doubleQuoted)
149+ <|> A.takeTill end
150+{-# INLINE rangeElem #-}
151+
152+-- | Simple double quoted value parser
153+doubleQuoted :: Parser B.ByteString
154+doubleQuoted = toByteString <$> go mempty
155+ where
156+ go acc = do
157+ h <- byteString <$> A.takeTill (\c -> c == '\\' || c == '"')
158+ let rest = do
159+ start <- A.anyChar
160+ case start of
161+ '\\' -> do
162+ c <- A.anyChar
163+ go (acc <> h <> char8 c)
164+ '"' -> (A.char '"' *> go (acc <> h <> char8 '"'))
165+ <|> pure (acc <> h)
166+ _ -> error "impossible in doubleQuoted"
167+ rest
168+
169+rangeToBuilder :: Ord a => (a -> Builder) -> PGRange a -> Builder
170+rangeToBuilder = rangeToBuilderBy compare
171+
172+-- | Generic range to builder for plain values
173+rangeToBuilderBy :: (a -> a -> Ordering) -> (a -> Builder) -> PGRange a -> Builder
174+rangeToBuilderBy cmp f x =
175+ if isEmptyBy cmp x
176+ then byteString "'empty'"
177+ else let (PGRange a b) = x
178+ in buildLB a <> buildUB b
179+ where
180+ buildLB NegInfinity = byteString "'[,"
181+ buildLB (Inclusive v) = byteString "'[\"" <> f v <> byteString "\","
182+ buildLB (Exclusive v) = byteString "'(\"" <> f v <> byteString "\","
183+ buildLB PosInfinity = error "impossible in rangeToBuilder"
184+
185+ buildUB NegInfinity = error "impossible in rangeToBuilder"
186+ buildUB (Inclusive v) = char8 '"' <> f v <> byteString "\"]'"
187+ buildUB (Exclusive v) = char8 '"' <> f v <> byteString "\")'"
188+ buildUB PosInfinity = byteString "]'"
189+{-# INLINE rangeToBuilder #-}
190+
191+
192+instance (FromField a, Typeable a) => FromField (PGRange a) where
193+ fromField = fromFieldRange fromField
194+
195+fromFieldRange :: Typeable a => FieldParser a -> FieldParser (PGRange a)
196+fromFieldRange fromField' f mdat = do
197+ info <- typeInfo f
198+ case info of
199+ Range{} ->
200+ let f' = f { typeOid = typoid (rngsubtype info) }
201+ in case mdat of
202+ Nothing -> returnError UnexpectedNull f ""
203+ Just "empty" -> pure $ empty
204+ Just bs ->
205+ let parseIt NegInfinity = pure NegInfinity
206+ parseIt (Inclusive v) = Inclusive <$> fromField' f' (Just v)
207+ parseIt (Exclusive v) = Exclusive <$> fromField' f' (Just v)
208+ parseIt PosInfinity = pure PosInfinity
209+ in case parseOnly pgrange bs of
210+ Left e -> returnError ConversionFailed f e
211+ Right (lb,ub) -> PGRange <$> parseIt lb <*> parseIt ub
212+ _ -> returnError Incompatible f ""
213+
214+
215+instance ToField (PGRange Int8) where
216+ toField = Plain . rangeToBuilder int8Dec
217+ {-# INLINE toField #-}
218+
219+instance ToField (PGRange Int16) where
220+ toField = Plain . rangeToBuilder int16Dec
221+ {-# INLINE toField #-}
222+
223+instance ToField (PGRange Int32) where
224+ toField = Plain . rangeToBuilder int32Dec
225+ {-# INLINE toField #-}
226+
227+instance ToField (PGRange Int) where
228+ toField = Plain . rangeToBuilder intDec
229+ {-# INLINE toField #-}
230+
231+instance ToField (PGRange Int64) where
232+ toField = Plain . rangeToBuilder int64Dec
233+ {-# INLINE toField #-}
234+
235+instance ToField (PGRange Integer) where
236+ toField = Plain . rangeToBuilder integerDec
237+ {-# INLINE toField #-}
238+
239+instance ToField (PGRange Word8) where
240+ toField = Plain . rangeToBuilder word8Dec
241+ {-# INLINE toField #-}
242+
243+instance ToField (PGRange Word16) where
244+ toField = Plain . rangeToBuilder word16Dec
245+ {-# INLINE toField #-}
246+
247+instance ToField (PGRange Word32) where
248+ toField = Plain . rangeToBuilder word32Dec
249+ {-# INLINE toField #-}
250+
251+instance ToField (PGRange Word) where
252+ toField = Plain . rangeToBuilder wordDec
253+ {-# INLINE toField #-}
254+
255+instance ToField (PGRange Word64) where
256+ toField = Plain . rangeToBuilder word64Dec
257+ {-# INLINE toField #-}
258+
259+instance ToField (PGRange Float) where
260+ toField = Plain . rangeToBuilder floatDec
261+ {-# INLINE toField #-}
262+
263+instance ToField (PGRange Double) where
264+ toField = Plain . rangeToBuilder doubleDec
265+ {-# INLINE toField #-}
266+
267+instance ToField (PGRange Scientific) where
268+ toField = Plain . rangeToBuilder f
269+ where
270+ f = lazyByteString . LT.encodeUtf8 . LT.toLazyText . scientificBuilder
271+ {-# INLINE toField #-}
272+
273+instance ToField (PGRange UTCTime) where
274+ toField = Plain . rangeToBuilder utcTimeToBuilder
275+ {-# INLINE toField #-}
276+
277+instance ToField (PGRange ZonedTime) where
278+ toField = Plain . rangeToBuilderBy cmpZonedTime zonedTimeToBuilder
279+ {-# INLINE toField #-}
280+
281+cmpZonedTime :: ZonedTime -> ZonedTime -> Ordering
282+cmpZonedTime = compare `on` zonedTimeToUTC -- FIXME: optimize
283+
284+instance ToField (PGRange LocalTime) where
285+ toField = Plain . rangeToBuilder localTimeToBuilder
286+ {-# INLINE toField #-}
287+
288+instance ToField (PGRange Day) where
289+ toField = Plain . rangeToBuilder dayToBuilder
290+ {-# INLINE toField #-}
291+
292+instance ToField (PGRange TimeOfDay) where
293+ toField = Plain . rangeToBuilder timeOfDayToBuilder
294+ {-# INLINE toField #-}
295+
296+instance ToField (PGRange UTCTimestamp) where
297+ toField = Plain . rangeToBuilder utcTimestampToBuilder
298+ {-# INLINE toField #-}
299+
300+instance ToField (PGRange ZonedTimestamp) where
301+ toField = Plain . rangeToBuilderBy cmpZonedTimestamp zonedTimestampToBuilder
302+ {-# INLINE toField #-}
303+
304+cmpZonedTimestamp :: ZonedTimestamp -> ZonedTimestamp -> Ordering
305+cmpZonedTimestamp = compare `on` (zonedTimeToUTC <$>)
306+
307+instance ToField (PGRange LocalTimestamp) where
308+ toField = Plain . rangeToBuilder localTimestampToBuilder
309+ {-# INLINE toField #-}
310+
311+instance ToField (PGRange Date) where
312+ toField = Plain . rangeToBuilder dateToBuilder
313+ {-# INLINE toField #-}
314+
315+instance ToField (PGRange NominalDiffTime) where
316+ toField = Plain . rangeToBuilder nominalDiffTimeToBuilder
317+ {-# INLINE toField #-}
src/Database/PostgreSQL/Simple/SqlQQ.hs+17−14
@@ -1,3 +1,9 @@
1+{-# LANGUAGE CPP #-}
2+#if __GLASGOW_HASKELL__ >= 800
3+{-# LANGUAGE TemplateHaskellQuotes #-}
4+#else
5+{-# LANGUAGE TemplateHaskell #-}
6+#endif
17------------------------------------------------------------------------------
28-- |
39-- Module: Database.PostgreSQL.Simple.SqlQQ
@@ -9,10 +15,11 @@
915------------------------------------------------------------------------------
1016
1117module Database.PostgreSQL.Simple.SqlQQ (sql) where
12−
18+import Database.PostgreSQL.Simple.Types (Query)
1319import Language.Haskell.TH
1420import Language.Haskell.TH.Quote
1521import Data.Char
22+import Data.String
1623
1724-- | 'sql' is a quasiquoter that eases the syntactic burden
1825-- of writing big sql statements in Haskell source code. For example:
@@ -27,10 +34,10 @@ import Data.Char
2734-- > LIMIT 100 |]
2835-- > (beginTime,endTime,string)
2936--
30−-- This quasiquoter attempts to mimimize whitespace; otherwise the
31−-- above query would consist of approximately half whitespace when sent
32−-- to the database backend. It also recognizes and strips out standard
33−-- sql comments "--".
37+-- This quasiquoter returns a literal string expression of type 'Query',
38+-- and attempts to minimize whitespace; otherwise the above query would
39+-- consist of approximately half whitespace when sent to the database
40+-- backend. It also recognizes and strips out standard sql comments "--".
3441--
3542-- The implementation of the whitespace reducer is currently incomplete.
3643-- Thus it can mess up your syntax in cases where whitespace should be
@@ -50,17 +57,14 @@ import Data.Char
5057
5158sql :: QuasiQuoter
5259sql = QuasiQuoter
53− { quotePat = error "Database.PostgreSQL.Simple.SqlQQ.sql:\
54− \ quasiquoter used in pattern context"
55− , quoteType = error "Database.PostgreSQL.Simple.SqlQQ.sql:\
56− \ 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"
5762 , quoteExp = sqlExp
58− , quoteDec = error "Database.PostgreSQL.Simple.SqlQQ.sql:\
59− \ quasiquoter used in declaration context"
63+ , quoteDec = error "Database.PostgreSQL.Simple.SqlQQ.sql: quasiquoter used in declaration context"
6064 }
6165
6266sqlExp :: String -> Q Exp
63−sqlExp = stringE . minimizeSpace
67+sqlExp = appE [| fromString :: String -> Query |] . stringE . minimizeSpace
6468
6569minimizeSpace :: String -> String
6670minimizeSpace = drop 1 . reduceSpace
@@ -83,5 +87,4 @@ minimizeSpace = drop 1 . reduceSpace
8387 instring ('\'':'\'':xs) = '\'':'\'': instring xs
8488 instring ('\'':xs) = '\'': insql xs
8589 instring (x:xs) = x : instring xs
86− instring [] = error "Database.PostgreSQL.Simple.SqlQQ.sql:\
87− \ string literal not terminated"
90+ instring [] = error "Database.PostgreSQL.Simple.SqlQQ.sql: string literal not terminated"
src/Database/PostgreSQL/Simple/Time.hs+216−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
@@ -75,6 +239,8 @@ module Database.PostgreSQL.Simple.Time
75239 , zonedTimestampToBuilder
76240 , localTimestampToBuilder
77241 , unboundedToBuilder
242+ , nominalDiffTimeToBuilder
243+ , calendarDiffTimeToBuilder
78244 ) where
79245
80246import Database.PostgreSQL.Simple.Time.Implementation
src/Database/PostgreSQL/Simple/Time/Implementation.hs+51−157
@@ -1,51 +1,44 @@
11------------------------------------------------------------------------------
22-- |
33-- Module: Database.PostgreSQL.Simple.Time.Implementation
4−-- Copyright: (c) 2012 Leon P Smith
4+-- Copyright: (c) 2012-2015 Leon P Smith
55-- License: BSD3
66-- Maintainer: Leon P Smith <leon@melding-monads.com>
77-- Stability: experimental
88--
99------------------------------------------------------------------------------
1010
11−{-# LANGUAGE DeriveDataTypeable #-}
11+{-# LANGUAGE DeriveDataTypeable, DeriveFunctor #-}
1212
1313module Database.PostgreSQL.Simple.Time.Implementation where
1414
15−import Prelude hiding (take, (++))
16−import Blaze.ByteString.Builder(Builder, fromByteString)
17−import Blaze.ByteString.Builder.Char8(fromChar)
18−import Blaze.Text.Int(integral)
15+import Prelude hiding (take)
16+import Data.ByteString.Builder(Builder, byteString)
17+import Data.ByteString.Builder.Prim(primBounded)
1918import Control.Arrow((***))
2019import Control.Applicative
21−import Control.Monad(when)
22−import Data.Bits((.&.))
2320import qualified Data.ByteString as B
24−import Data.ByteString.Internal (c2w, w2c)
25−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)
2623import Data.Typeable
27−import Data.Word(Word8)
28−import qualified Data.Attoparsec.Char8 as A
29−import Data.Monoid(Monoid(..))
30−import Data.Fixed (Pico)
31−import Unsafe.Coerce
32−
33−(++) :: Monoid a => a -> a -> a
34−(++) = mappend
35−infixr 5 ++
24+import Data.Maybe (fromMaybe)
25+import qualified Data.Attoparsec.ByteString.Char8 as A
26+import Database.PostgreSQL.Simple.Compat ((<>))
27+import qualified Database.PostgreSQL.Simple.Time.Internal.Parser as TP
28+import qualified Database.PostgreSQL.Simple.Time.Internal.Printer as TPP
3629
3730data Unbounded a
3831 = NegInfinity
3932 | Finite !a
4033 | PosInfinity
41− deriving (Eq, Ord, Typeable)
34+ deriving (Eq, Ord, Typeable, Functor)
4235
4336instance Show a => Show (Unbounded a) where
4437 showsPrec prec x rest
4538 = case x of
46− NegInfinity -> "-infinity" ++ rest
39+ NegInfinity -> "-infinity" <> rest
4740 Finite time -> showsPrec prec time rest
48− PosInfinity -> "infinity" ++ rest
41+ PosInfinity -> "infinity" <> rest
4942
5043instance Read a => Read (Unbounded a) where
5144 readsPrec prec = readParen False $ \str -> case str of
@@ -85,6 +78,9 @@ parseLocalTimestamp = A.parseOnly (getLocalTimestamp <* A.endOfInput)
8578parseDate :: B.ByteString -> Either String Date
8679parseDate = A.parseOnly (getDate <* A.endOfInput)
8780
81+parseCalendarDiffTime :: B.ByteString -> Either String CalendarDiffTime
82+parseCalendarDiffTime = A.parseOnly (getCalendarDiffTime <* A.endOfInput)
83+
8884getUnbounded :: A.Parser a -> A.Parser (Unbounded a)
8985getUnbounded getFinite
9086 = (pure NegInfinity <* A.string "-infinity")
@@ -92,130 +88,74 @@ getUnbounded getFinite
9288 <|> (Finite <$> getFinite)
9389
9490getDay :: A.Parser Day
95−getDay = do
96− yearStr <- A.takeWhile A.isDigit
97− when (B.length yearStr < 4) (fail "year must consist of at least 4 digits")
98−
99− let !year = toNum yearStr
100− _ <- A.char '-'
101− month <- digits "month"
102− _ <- A.char '-'
103− day <- digits "day"
104−
105− case fromGregorianValid year month day of
106− Nothing -> fail "invalid date"
107− Just x -> return $! x
91+getDay = TP.day
10892
10993getDate :: A.Parser Date
11094getDate = getUnbounded getDay
11195
112−decimal :: Fractional a => B.ByteString -> a
113−decimal str = toNum str / 10^(B.length str)
114−{-# INLINE decimal #-}
115−
11696getTimeOfDay :: A.Parser TimeOfDay
117−getTimeOfDay = do
118− hour <- digits "hours"
119− _ <- A.char ':'
120− minute <- digits "minutes"
121− _ <- A.char ':'
122− second <- digits "seconds"
123− subsec <- (A.char '.' *> (decimal <$> A.takeWhile1 A.isDigit)) <|> return 0
124−
125− let !picos' = second + subsec
126−
127− case makeTimeOfDayValid hour minute picos' of
128− Nothing -> fail "invalid time of day"
129− Just x -> return $! x
97+getTimeOfDay = TP.timeOfDay
13098
13199getLocalTime :: A.Parser LocalTime
132−getLocalTime = LocalTime <$> getDay <*> (A.char ' ' *> getTimeOfDay)
100+getLocalTime = TP.localTime
133101
134102getLocalTimestamp :: A.Parser LocalTimestamp
135103getLocalTimestamp = getUnbounded getLocalTime
136104
137105getTimeZone :: A.Parser TimeZone
138−getTimeZone = do
139− sign <- A.satisfy (\c -> c == '+' || c == '-')
140− hours <- digits "timezone"
141− mins <- (A.char ':' *> digits "timezone minutes") <|> pure 0
142− let !absset = 60 * hours + mins
143− !offset = if sign == '+' then absset else -absset
144− return $! minutesToTimeZone offset
106+getTimeZone = fromMaybe utc <$> TP.timeZone
107+
108+type TimeZoneHMS = (Int,Int,Int)
109+
110+getTimeZoneHMS :: A.Parser TimeZoneHMS
111+getTimeZoneHMS = munge <$> TP.timeZoneHMS
112+ where
113+ munge Nothing = (0,0,0)
114+ munge (Just (TP.UTCOffsetHMS h m s)) = (h,m,s)
115+
116+localToUTCTimeOfDayHMS :: TimeZoneHMS -> TimeOfDay -> (Integer, TimeOfDay)
117+localToUTCTimeOfDayHMS (dh, dm, ds) tod =
118+ TP.localToUTCTimeOfDayHMS (TP.UTCOffsetHMS dh dm ds) tod
145119
146120getZonedTime :: A.Parser ZonedTime
147−getZonedTime = ZonedTime <$> getLocalTime <*> getTimeZone
121+getZonedTime = TP.zonedTime
148122
149123getZonedTimestamp :: A.Parser ZonedTimestamp
150124getZonedTimestamp = getUnbounded getZonedTime
151125
152126getUTCTime :: A.Parser UTCTime
153−getUTCTime = do
154− day <- getDay
155− _ <- A.char ' '
156− time <- getTimeOfDay
157− zone <- getTimeZone
158− let (!dayDelta,!time') = localToUTCTimeOfDay zone time
159− let !day' = addDays dayDelta day
160− let !time'' = timeOfDayToTime time'
161− return (UTCTime day' time'')
127+getUTCTime = TP.utcTime
162128
163129getUTCTimestamp :: A.Parser UTCTimestamp
164130getUTCTimestamp = getUnbounded getUTCTime
165131
166−toNum :: Num n => B.ByteString -> n
167−toNum = B.foldl' (\a c -> 10*a + digit c) 0
168−{-# INLINE toNum #-}
169−
170−digit :: Num n => Word8 -> n
171−digit c = fromIntegral (c .&. 0x0f)
172−{-# INLINE digit #-}
173−
174−digits :: Num n => String -> A.Parser n
175−digits msg = do
176− x <- A.anyChar
177− y <- A.anyChar
178− if A.isDigit x && A.isDigit y
179− then return $! (10 * digit (c2w x) + digit (c2w y))
180− else fail (msg ++ " is not 2 digits")
181−{-# INLINE digits #-}
132+getCalendarDiffTime :: A.Parser CalendarDiffTime
133+getCalendarDiffTime = TP.calendarDiffTime
182134
183135dayToBuilder :: Day -> Builder
184−dayToBuilder (toGregorian -> (y,m,d)) = do
185− pad4 y ++ fromChar '-' ++ pad2 m ++ fromChar '-' ++ pad2 d
136+dayToBuilder = primBounded TPP.day
186137
187138timeOfDayToBuilder :: TimeOfDay -> Builder
188−timeOfDayToBuilder (TimeOfDay h m s) = do
189− pad2 h ++ fromChar ':' ++ pad2 m ++ fromChar ':' ++ showSeconds s
139+timeOfDayToBuilder = primBounded TPP.timeOfDay
190140
191141timeZoneToBuilder :: TimeZone -> Builder
192−timeZoneToBuilder tz
193− | m == 0 = sign h ++ pad2 (abs h)
194− | otherwise = sign h ++ pad2 (abs h) ++ fromChar ':' ++ pad2 (abs m)
195− where
196− (h,m) = timeZoneMinutes tz `quotRem` 60
197− sign h | h >= 0 = fromChar '+'
198− | otherwise = fromChar '-'
142+timeZoneToBuilder = primBounded TPP.timeZone
199143
200144utcTimeToBuilder :: UTCTime -> Builder
201−utcTimeToBuilder (UTCTime day time) =
202− dayToBuilder day ++ fromChar ' '
203− ++ timeOfDayToBuilder (timeToTimeOfDay time) ++ fromByteString "+00"
145+utcTimeToBuilder = primBounded TPP.utcTime
204146
205147zonedTimeToBuilder :: ZonedTime -> Builder
206−zonedTimeToBuilder (ZonedTime localTime tz) =
207− localTimeToBuilder localTime ++ timeZoneToBuilder tz
148+zonedTimeToBuilder = primBounded TPP.zonedTime
208149
209150localTimeToBuilder :: LocalTime -> Builder
210−localTimeToBuilder (LocalTime day tod) =
211− dayToBuilder day ++ fromChar ' ' ++ timeOfDayToBuilder tod
151+localTimeToBuilder = primBounded TPP.localTime
212152
213153unboundedToBuilder :: (a -> Builder) -> (Unbounded a -> Builder)
214154unboundedToBuilder finiteToBuilder unbounded
215155 = case unbounded of
216− NegInfinity -> fromByteString "-infinity"
156+ NegInfinity -> byteString "-infinity"
217157 Finite a -> finiteToBuilder a
218− PosInfinity -> fromByteString "infinity"
158+ PosInfinity -> byteString "infinity"
219159
220160utcTimestampToBuilder :: UTCTimestamp -> Builder
221161utcTimestampToBuilder = unboundedToBuilder utcTimeToBuilder
@@ -229,54 +169,8 @@ localTimestampToBuilder = unboundedToBuilder localTimeToBuilder
229169dateToBuilder :: Date -> Builder
230170dateToBuilder = unboundedToBuilder dayToBuilder
231171
232−showSeconds :: Pico -> Builder
233−showSeconds xyz
234− | yz == 0 = pad2 x
235− | z == 0 = pad2 x ++ fromChar '.' ++ showD6 y
236− | otherwise = pad2 x ++ fromChar '.' ++ pad6 y ++ showD6 z
237− where
238− -- A kludge to work around the fact that Data.Fixed isn't very fast and
239− -- doesn't give me access to the MkFixed constructor.
240− (x_,yz) = (unsafeCoerce xyz :: Integer) `quotRem` 1000000000000
241− x = fromIntegral x_ :: Int
242− (fromIntegral -> y, fromIntegral -> z) = yz `quotRem` 1000000
243−
244−pad6 :: Int -> Builder
245−pad6 xy = let (x,y) = xy `quotRem` 1000
246− in pad3 x ++ pad3 y
247−
248−showD6 :: Int -> Builder
249−showD6 xy = case xy `quotRem` 1000 of
250− (x,0) -> showD3 x
251− (x,y) -> pad3 x ++ showD3 y
252−
253−pad3 :: Int -> Builder
254−pad3 abc = let (ab,c) = abc `quotRem` 10
255− (a,b) = ab `quotRem` 10
256− in p a ++ p b ++ p c
257−
258−showD3 :: Int -> Builder
259−showD3 abc = case abc `quotRem` 100 of
260− (a, 0) -> p a
261− (a,bc) -> case bc `quotRem` 10 of
262− (b,0) -> p a ++ p b
263− (b,c) -> p a ++ p b ++ p c
264−
265−-- | p assumes its input is in the range [0..9]
266−p :: Integral n => n -> Builder
267−p n = fromChar (w2c (fromIntegral (n + 48)))
268−{-# INLINE p #-}
269−
270−-- | pad2 assumes its input is in the range [0..99]
271−pad2 :: Integral n => n -> Builder
272−pad2 n = let (a,b) = n `quotRem` 10 in p a ++ p b
273−{-# INLINE pad2 #-}
274−
275−-- | pad4 assumes its input is positive
276−pad4 :: (Integral n, Show n) => n -> Builder
277−pad4 abcd | abcd >= 10000 = integral abcd
278− | otherwise = p a ++ p b ++ p c ++ p d
279− where (ab,cd) = abcd `quotRem` 100
280− (a,b) = ab `quotRem` 10
281− (c,d) = cd `quotRem` 10
282−{-# INLINE pad4 #-}
172+nominalDiffTimeToBuilder :: NominalDiffTime -> Builder
173+nominalDiffTimeToBuilder = TPP.nominalDiffTime
174+
175+calendarDiffTimeToBuilder :: CalendarDiffTime -> Builder
176+calendarDiffTimeToBuilder = TPP.calendarDiffTime
src/Database/PostgreSQL/Simple/Time/Internal.hs+3
@@ -19,6 +19,9 @@ module Database.PostgreSQL.Simple.Time.Internal
1919 , getZonedTimestamp
2020 , getUTCTime
2121 , getUTCTimestamp
22+ , TimeZoneHMS
23+ , getTimeZoneHMS
24+ , localToUTCTimeOfDayHMS
2225 ) where
2326
2427import Database.PostgreSQL.Simple.Time.Implementation
src/Database/PostgreSQL/Simple/Time/Internal/Parser.hsnew file+204
@@ -0,0 +1,204 @@
1+{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}
2+
3+-- |
4+-- Module: Database.PostgreSQL.Simple.Time.Internal.Parser
5+-- Copyright: (c) 2012-2015 Leon P Smith
6+-- (c) 2015 Bryan O'Sullivan
7+-- License: BSD3
8+-- Maintainer: Leon P Smith <leon@melding-monads.com>
9+-- Stability: experimental
10+--
11+-- Parsers for parsing dates and times.
12+
13+module Database.PostgreSQL.Simple.Time.Internal.Parser
14+ (
15+ day
16+ , localTime
17+ , timeOfDay
18+ , timeZone
19+ , UTCOffsetHMS(..)
20+ , timeZoneHMS
21+ , localToUTCTimeOfDayHMS
22+ , utcTime
23+ , zonedTime
24+ , calendarDiffTime
25+ ) where
26+
27+import Control.Applicative ((<$>), (<*>), (<*), (*>))
28+import Database.PostgreSQL.Simple.Compat (toPico)
29+import Data.Attoparsec.ByteString.Char8 as A
30+import Data.Bits ((.&.))
31+import Data.ByteString (ByteString)
32+import Data.Char (ord)
33+import Data.Fixed (Pico)
34+import Data.Int (Int64)
35+import Data.Maybe (fromMaybe)
36+import Data.Time.Calendar.Compat (Day, fromGregorianValid, addDays)
37+import Data.Time.Clock.Compat (UTCTime(..))
38+import Data.Time.Format.ISO8601.Compat (iso8601ParseM)
39+import Data.Time.LocalTime.Compat (CalendarDiffTime)
40+import qualified Data.ByteString.Char8 as B8
41+import qualified Data.Time.LocalTime.Compat as Local
42+
43+-- | Parse a date of the form @YYYY-MM-DD@.
44+day :: Parser Day
45+day = do
46+ y <- decimal <* char '-'
47+ m <- twoDigits <* char '-'
48+ d <- twoDigits
49+ maybe (fail "invalid date") return (fromGregorianValid y m d)
50+
51+-- | Parse a two-digit integer (e.g. day of month, hour).
52+twoDigits :: Parser Int
53+twoDigits = do
54+ a <- digit
55+ b <- digit
56+ let c2d c = ord c .&. 15
57+ return $! c2d a * 10 + c2d b
58+
59+-- | Parse a time of the form @HH:MM[:SS[.SSS]]@.
60+timeOfDay :: Parser Local.TimeOfDay
61+timeOfDay = do
62+ h <- twoDigits <* char ':'
63+ m <- twoDigits
64+ mc <- peekChar
65+ s <- case mc of
66+ Just ':' -> anyChar *> seconds
67+ _ -> return 0
68+ if h < 24 && m < 60 && s <= 60
69+ then return (Local.TimeOfDay h m s)
70+ else fail "invalid time"
71+
72+-- | Parse a count of seconds, with the integer part being two digits
73+-- long.
74+seconds :: Parser Pico
75+seconds = do
76+ real <- twoDigits
77+ mc <- peekChar
78+ case mc of
79+ Just '.' -> do
80+ t <- anyChar *> takeWhile1 isDigit
81+ return $! parsePicos (fromIntegral real) t
82+ _ -> return $! fromIntegral real
83+ where
84+ parsePicos :: Int64 -> B8.ByteString -> Pico
85+ parsePicos a0 t = toPico (fromIntegral (t' * 10^n))
86+ where n = max 0 (12 - B8.length t)
87+ t' = B8.foldl' (\a c -> 10 * a + fromIntegral (ord c .&. 15)) a0
88+ (B8.take 12 t)
89+
90+-- | Parse a time zone, and return 'Nothing' if the offset from UTC is
91+-- zero. (This makes some speedups possible.)
92+timeZone :: Parser (Maybe Local.TimeZone)
93+timeZone = do
94+ ch <- satisfy $ \c -> c == '+' || c == '-' || c == 'Z'
95+ if ch == 'Z'
96+ then return Nothing
97+ else do
98+ h <- twoDigits
99+ mm <- peekChar
100+ m <- case mm of
101+ Just ':' -> anyChar *> twoDigits
102+ _ -> return 0
103+ let off | ch == '-' = negate off0
104+ | otherwise = off0
105+ off0 = h * 60 + m
106+ case undefined of
107+ _ | off == 0 ->
108+ return Nothing
109+ | h > 23 || m > 59 ->
110+ fail "invalid time zone offset"
111+ | otherwise ->
112+ let !tz = Local.minutesToTimeZone off
113+ in return (Just tz)
114+
115+data UTCOffsetHMS = UTCOffsetHMS {-# UNPACK #-} !Int {-# UNPACK #-} !Int {-# UNPACK #-} !Int
116+
117+-- | Parse a time zone, and return 'Nothing' if the offset from UTC is
118+-- zero. (This makes some speedups possible.)
119+timeZoneHMS :: Parser (Maybe UTCOffsetHMS)
120+timeZoneHMS = do
121+ ch <- satisfy $ \c -> c == '+' || c == '-' || c == 'Z'
122+ if ch == 'Z'
123+ then return Nothing
124+ else do
125+ h <- twoDigits
126+ m <- maybeTwoDigits
127+ s <- maybeTwoDigits
128+ case undefined of
129+ _ | h == 0 && m == 0 && s == 0 ->
130+ return Nothing
131+ | h > 23 || m >= 60 || s >= 60 ->
132+ fail "invalid time zone offset"
133+ | otherwise ->
134+ if ch == '+'
135+ then let !tz = UTCOffsetHMS h m s
136+ in return (Just tz)
137+ else let !tz = UTCOffsetHMS (-h) (-m) (-s)
138+ in return (Just tz)
139+ where
140+ maybeTwoDigits = do
141+ ch <- peekChar
142+ case ch of
143+ Just ':' -> anyChar *> twoDigits
144+ _ -> return 0
145+
146+localToUTCTimeOfDayHMS :: UTCOffsetHMS -> Local.TimeOfDay -> (Integer, Local.TimeOfDay)
147+localToUTCTimeOfDayHMS (UTCOffsetHMS dh dm ds) (Local.TimeOfDay h m s) =
148+ (\ !a !b -> (a,b)) dday (Local.TimeOfDay h'' m'' s'')
149+ where
150+ s' = s - fromIntegral ds
151+ (!s'', m')
152+ | s' < 0 = (s' + 60, m - dm - 1)
153+ | s' >= 60 = (s' - 60, m - dm + 1)
154+ | otherwise = (s' , m - dm )
155+ (!m'', h')
156+ | m' < 0 = (m' + 60, h - dh - 1)
157+ | m' >= 60 = (m' - 60, h - dh + 1)
158+ | otherwise = (m' , h - dh )
159+ (!h'', dday)
160+ | h' < 0 = (h' + 24, -1)
161+ | h' >= 24 = (h' - 24, 1)
162+ | otherwise = (h' , 0)
163+
164+
165+-- | Parse a date and time, of the form @YYYY-MM-DD HH:MM:SS@.
166+-- The space may be replaced with a @T@. The number of seconds may be
167+-- followed by a fractional component.
168+localTime :: Parser Local.LocalTime
169+localTime = Local.LocalTime <$> day <* daySep <*> timeOfDay
170+ where daySep = satisfy (\c -> c == ' ' || c == 'T')
171+
172+-- | Behaves as 'zonedTime', but converts any time zone offset into a
173+-- UTC time.
174+utcTime :: Parser UTCTime
175+utcTime = do
176+ (Local.LocalTime d t) <- localTime
177+ mtz <- timeZoneHMS
178+ case mtz of
179+ Nothing -> let !tt = Local.timeOfDayToTime t
180+ in return (UTCTime d tt)
181+ Just tz -> let !(dd,t') = localToUTCTimeOfDayHMS tz t
182+ !d' = addDays dd d
183+ !tt = Local.timeOfDayToTime t'
184+ in return (UTCTime d' tt)
185+
186+-- | Parse a date with time zone info. Acceptable formats:
187+--
188+-- @YYYY-MM-DD HH:MM:SS Z@
189+--
190+-- The first space may instead be a @T@, and the second space is
191+-- optional. The @Z@ represents UTC. The @Z@ may be replaced with a
192+-- time zone offset of the form @+0000@ or @-08:00@, where the first
193+-- two digits are hours, the @:@ is optional and the second two digits
194+-- (also optional) are minutes.
195+zonedTime :: Parser Local.ZonedTime
196+zonedTime = Local.ZonedTime <$> localTime <*> (fromMaybe utc <$> timeZone)
197+
198+utc :: Local.TimeZone
199+utc = Local.TimeZone 0 False ""
200+
201+calendarDiffTime :: Parser CalendarDiffTime
202+calendarDiffTime = do
203+ contents <- takeByteString
204+ iso8601ParseM $ B8.unpack contents
src/Database/PostgreSQL/Simple/Time/Internal/Printer.hsnew file+135
@@ -0,0 +1,135 @@
1+{-# LANGUAGE BangPatterns, ViewPatterns #-}
2+
3+------------------------------------------------------------------------------
4+-- Module: Database.PostgreSQL.Simple.Time.Internal.Printer
5+-- Copyright: (c) 2012-2015 Leon P Smith
6+-- License: BSD3
7+-- Maintainer: Leon P Smith <leon@melding-monads.com>
8+-- Stability: experimental
9+------------------------------------------------------------------------------
10+
11+module Database.PostgreSQL.Simple.Time.Internal.Printer
12+ (
13+ day
14+ , timeOfDay
15+ , timeZone
16+ , utcTime
17+ , localTime
18+ , zonedTime
19+ , nominalDiffTime
20+ , calendarDiffTime
21+ ) where
22+
23+import Control.Arrow ((>>>))
24+import Data.ByteString.Builder (Builder, byteString, integerDec)
25+import Data.ByteString.Builder.Prim
26+ ( liftFixedToBounded, (>$<), (>*<)
27+ , BoundedPrim, primBounded, condB, emptyB, FixedPrim, char8, int32Dec)
28+import Data.Char ( chr )
29+import Data.Int ( Int32, Int64 )
30+import Data.String (fromString)
31+import Data.Time.Compat
32+ ( UTCTime(..), ZonedTime(..), LocalTime(..), NominalDiffTime
33+ , Day, toGregorian, TimeOfDay(..), timeToTimeOfDay
34+ , TimeZone, timeZoneMinutes )
35+import Data.Time.Format.ISO8601.Compat (iso8601Show)
36+import Data.Time.LocalTime.Compat (CalendarDiffTime)
37+import Database.PostgreSQL.Simple.Compat ((<>), fromPico)
38+import Unsafe.Coerce (unsafeCoerce)
39+
40+liftB :: FixedPrim a -> BoundedPrim a
41+liftB = liftFixedToBounded
42+
43+digit :: FixedPrim Int
44+digit = (\x -> chr (x + 48)) >$< char8
45+
46+digits2 :: FixedPrim Int
47+digits2 = (`quotRem` 10) >$< (digit >*< digit)
48+
49+digits3 :: FixedPrim Int
50+digits3 = (`quotRem` 10) >$< (digits2 >*< digit)
51+
52+digits4 :: FixedPrim Int
53+digits4 = (`quotRem` 10) >$< (digits3 >*< digit)
54+
55+frac :: BoundedPrim Int64
56+frac = condB (== 0) emptyB ((,) '.' >$< (liftB char8 >*< trunc12))
57+ where
58+ trunc12 :: BoundedPrim Int64
59+ trunc12 = (`quotRem` 1000000) >$<
60+ condB (\(_,y) -> y == 0)
61+ (fst >$< trunc6)
62+ (liftB digits6 >*< trunc6)
63+
64+ digitB = liftB digit
65+
66+ digits6 = (fromIntegral >>> (`quotRem` 10)) >$< (digits5 >*< digit)
67+ digits5 = (`quotRem` 10) >$< (digits4 >*< digit)
68+
69+ trunc6 = (fromIntegral >>> (`quotRem` 100000)) >$< (digitB >*< trunc5)
70+ trunc5 = condB (== 0) emptyB ((`quotRem` 10000) >$< (digitB >*< trunc4))
71+ trunc4 = condB (== 0) emptyB ((`quotRem` 1000) >$< (digitB >*< trunc3))
72+ trunc3 = condB (== 0) emptyB ((`quotRem` 100) >$< (digitB >*< trunc2))
73+ trunc2 = condB (== 0) emptyB ((`quotRem` 10) >$< (digitB >*< trunc1))
74+ trunc1 = condB (== 0) emptyB digitB
75+
76+
77+year :: BoundedPrim Int32
78+year = condB (>= 10000) int32Dec (checkBCE >$< liftB digits4)
79+ where
80+ checkBCE :: Int32 -> Int
81+ checkBCE y
82+ | y > 0 = fromIntegral y
83+ | otherwise = error msg
84+
85+ msg = "Database.PostgreSQL.Simple.Time.Printer.year: years BCE not supported"
86+
87+day :: BoundedPrim Day
88+day = toYMD >$< (year >*< liftB (char8 >*< digits2 >*< char8 >*< digits2))
89+ where
90+ toYMD (toGregorian -> (fromIntegral -> !y, !m,!d)) = (y,('-',(m,('-',d))))
91+
92+timeOfDay :: BoundedPrim TimeOfDay
93+timeOfDay = f >$< (hh_mm_ >*< ss)
94+ where
95+ f (TimeOfDay h m s) = ((h,(':',(m,':'))),s)
96+
97+ hh_mm_ = liftB (digits2 >*< char8 >*< digits2 >*< char8)
98+
99+ ss = (\s -> fromIntegral (fromPico s) `quotRem` 1000000000000) >$<
100+ (liftB (fromIntegral >$< digits2) >*< frac)
101+
102+timeZone :: BoundedPrim TimeZone
103+timeZone = timeZoneMinutes >$< tz
104+ where
105+ tz = condB (>= 0) ((,) '+' >$< tzh) ((,) '-' . negate >$< tzh)
106+
107+ tzh = liftB char8 >*< ((`quotRem` 60) >$< (liftB digits2 >*< tzm))
108+
109+ tzm = condB (==0) emptyB ((,) ':' >$< liftB (char8 >*< digits2))
110+
111+utcTime :: BoundedPrim UTCTime
112+utcTime = f >$< (day >*< liftB char8 >*< timeOfDay >*< liftB char8)
113+ where f (UTCTime d (timeToTimeOfDay -> tod)) = (d,(' ',(tod,'Z')))
114+
115+localTime :: BoundedPrim LocalTime
116+localTime = f >$< (day >*< liftB char8 >*< timeOfDay)
117+ where f (LocalTime d tod) = (d, (' ', tod))
118+
119+zonedTime :: BoundedPrim ZonedTime
120+zonedTime = f >$< (localTime >*< timeZone)
121+ where f (ZonedTime lt tz) = (lt, tz)
122+
123+
124+nominalDiffTime :: NominalDiffTime -> Builder
125+nominalDiffTime xy = integerDec x <> primBounded frac (abs (fromIntegral y))
126+ where
127+ (x,y) = fromPico (unsafeCoerce xy) `quotRem` 1000000000000
128+
129+calendarDiffTime :: CalendarDiffTime -> Builder
130+calendarDiffTime = byteString
131+ . fromString
132+ -- from the docs: "Beware: fromString truncates multi-byte characters to octets".
133+ -- However, I think this is a safe usage, because ISO8601-encoding seems restricted
134+ -- to ASCII output.
135+ . iso8601Show
src/Database/PostgreSQL/Simple/ToField.hs+89−54
@@ -1,5 +1,6 @@
11{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-}
22{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
3+{-# LANGUAGE PolyKinds #-}
34
45------------------------------------------------------------------------------
56-- |
@@ -22,38 +23,44 @@ module Database.PostgreSQL.Simple.ToField
2223 , inQuotes
2324 ) where
2425
25−import Blaze.ByteString.Builder (Builder, fromByteString, toByteString)
26−import Blaze.ByteString.Builder.Char8 (fromChar)
27−import Blaze.Text (integral, double, float)
26+import Control.Applicative (Const(Const))
2827import qualified Data.Aeson as JSON
29−import Data.ByteString (ByteString)
28+import Data.ByteString (ByteString)
29+import Data.ByteString.Builder
30+ ( Builder, byteString, char8, stringUtf8
31+ , intDec, int8Dec, int16Dec, int32Dec, int64Dec, integerDec
32+ , wordDec, word8Dec, word16Dec, word32Dec, word64Dec
33+ , floatDec, doubleDec
34+ )
35+import Data.Functor.Identity (Identity(Identity))
3036import Data.Int (Int8, Int16, Int32, Int64)
3137import Data.List (intersperse)
3238import Data.Monoid (mappend)
33−import Data.Time (Day, TimeOfDay, LocalTime, UTCTime, ZonedTime)
39+import Data.Time.Compat (Day, TimeOfDay, LocalTime, UTCTime, ZonedTime, NominalDiffTime)
40+import Data.Time.LocalTime.Compat (CalendarDiffTime)
3441import Data.Typeable (Typeable)
3542import Data.Word (Word, Word8, Word16, Word32, Word64)
3643import {-# SOURCE #-} Database.PostgreSQL.Simple.ToRow
3744import Database.PostgreSQL.Simple.Types
38−import qualified Blaze.ByteString.Builder.Char.Utf8 as Utf8
45+import Database.PostgreSQL.Simple.Compat (toByteString)
46+
3947import qualified Data.ByteString as SB
4048import qualified Data.ByteString.Lazy as LB
49+import Data.CaseInsensitive (CI)
50+import qualified Data.CaseInsensitive as CI
4151import qualified Data.Text as ST
4252import qualified Data.Text.Encoding as ST
4353import qualified Data.Text.Lazy as LT
4454import qualified Data.Text.Lazy.Builder as LT
45−import Data.UUID (UUID)
46−import qualified Data.UUID as UUID
55+import Data.UUID.Types (UUID)
56+import qualified Data.UUID.Types as UUID
4757import Data.Vector (Vector)
4858import qualified Data.Vector as V
4959import qualified Database.PostgreSQL.LibPQ as PQ
5060import Database.PostgreSQL.Simple.Time
5161import Data.Scientific (Scientific)
52−#if MIN_VERSION_scientific(0,3,0)
5362import Data.Text.Lazy.Builder.Scientific (scientificBuilder)
54−#else
55−import Data.Scientific (scientificBuilder)
56−#endif
63+import Foreign.C.Types (CUInt(..))
5764
5865-- | How to render an element when substituting it into a query.
5966data Action =
@@ -93,90 +100,98 @@ instance ToField Action where
93100 toField a = a
94101 {-# INLINE toField #-}
95102
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+
96111instance (ToField a) => ToField (Maybe a) where
97112 toField Nothing = renderNull
98113 toField (Just a) = toField a
99114 {-# INLINE toField #-}
100115
101116instance (ToField a) => ToField (In [a]) where
102− toField (In []) = Plain $ fromByteString "(null)"
117+ toField (In []) = Plain $ byteString "(null)"
103118 toField (In xs) = Many $
104− Plain (fromChar '(') :
105− (intersperse (Plain (fromChar ',')) . map toField $ xs) ++
106− [Plain (fromChar ')')]
119+ Plain (char8 '(') :
120+ (intersperse (Plain (char8 ',')) . map toField $ xs) ++
121+ [Plain (char8 ')')]
107122
108123renderNull :: Action
109−renderNull = Plain (fromByteString "null")
124+renderNull = Plain (byteString "null")
110125
111126instance ToField Null where
112127 toField _ = renderNull
113128 {-# INLINE toField #-}
114129
115130instance ToField Default where
116− toField _ = Plain (fromByteString "default")
131+ toField _ = Plain (byteString "default")
117132 {-# INLINE toField #-}
118133
119134instance ToField Bool where
120− toField True = Plain (fromByteString "true")
121− toField False = Plain (fromByteString "false")
135+ toField True = Plain (byteString "true")
136+ toField False = Plain (byteString "false")
122137 {-# INLINE toField #-}
123138
124139instance ToField Int8 where
125− toField = Plain . integral
140+ toField = Plain . int8Dec
126141 {-# INLINE toField #-}
127142
128143instance ToField Int16 where
129− toField = Plain . integral
144+ toField = Plain . int16Dec
130145 {-# INLINE toField #-}
131146
132147instance ToField Int32 where
133− toField = Plain . integral
148+ toField = Plain . int32Dec
134149 {-# INLINE toField #-}
135150
136151instance ToField Int where
137− toField = Plain . integral
152+ toField = Plain . intDec
138153 {-# INLINE toField #-}
139154
140155instance ToField Int64 where
141− toField = Plain . integral
156+ toField = Plain . int64Dec
142157 {-# INLINE toField #-}
143158
144159instance ToField Integer where
145− toField = Plain . integral
160+ toField = Plain . integerDec
146161 {-# INLINE toField #-}
147162
148163instance ToField Word8 where
149− toField = Plain . integral
164+ toField = Plain . word8Dec
150165 {-# INLINE toField #-}
151166
152167instance ToField Word16 where
153− toField = Plain . integral
168+ toField = Plain . word16Dec
154169 {-# INLINE toField #-}
155170
156171instance ToField Word32 where
157− toField = Plain . integral
172+ toField = Plain . word32Dec
158173 {-# INLINE toField #-}
159174
160175instance ToField Word where
161− toField = Plain . integral
176+ toField = Plain . wordDec
162177 {-# INLINE toField #-}
163178
164179instance ToField Word64 where
165− toField = Plain . integral
180+ toField = Plain . word64Dec
166181 {-# INLINE toField #-}
167182
168183instance ToField PQ.Oid where
169− toField = Plain . integral . \(PQ.Oid x) -> x
184+ toField = Plain . \(PQ.Oid (CUInt x)) -> word32Dec x
170185 {-# INLINE toField #-}
171186
172187instance ToField Float where
173− toField v | isNaN v || isInfinite v = Plain (inQuotes (float v))
174− | otherwise = Plain (float v)
188+ toField v | isNaN v || isInfinite v = Plain (inQuotes (floatDec v))
189+ | otherwise = Plain (floatDec v)
175190 {-# INLINE toField #-}
176191
177192instance ToField Double where
178− toField v | isNaN v || isInfinite v = Plain (inQuotes (double v))
179− | otherwise = Plain (double v)
193+ toField v | isNaN v || isInfinite v = Plain (inQuotes (doubleDec v))
194+ | otherwise = Plain (doubleDec v)
180195 {-# INLINE toField #-}
181196
182197instance ToField Scientific where
@@ -198,7 +213,7 @@ instance ToField Identifier where
198213instance ToField QualifiedIdentifier where
199214 toField (QualifiedIdentifier (Just s) t) =
200215 Many [ EscapeIdentifier (ST.encodeUtf8 s)
201− , Plain (fromChar '.')
216+ , Plain (char8 '.')
202217 , EscapeIdentifier (ST.encodeUtf8 t)
203218 ]
204219 toField (QualifiedIdentifier Nothing t) =
@@ -218,13 +233,23 @@ instance ToField ST.Text where
218233 {-# INLINE toField #-}
219234
220235instance ToField [Char] where
221− toField = Escape . toByteString . Utf8.fromString
236+ toField = Escape . toByteString . stringUtf8
222237 {-# INLINE toField #-}
223238
224239instance ToField LT.Text where
225240 toField = toField . LT.toStrict
226241 {-# INLINE toField #-}
227242
243+-- | citext
244+instance ToField (CI ST.Text) where
245+ toField = toField . CI.original
246+ {-# INLINE toField #-}
247+
248+-- | citext
249+instance ToField (CI LT.Text) where
250+ toField = toField . LT.toStrict . CI.original
251+ {-# INLINE toField #-}
252+
228253instance ToField UTCTime where
229254 toField = Plain . inQuotes . utcTimeToBuilder
230255 {-# INLINE toField #-}
@@ -261,41 +286,51 @@ instance ToField Date where
261286 toField = Plain . inQuotes . dateToBuilder
262287 {-# INLINE toField #-}
263288
289+instance ToField NominalDiffTime where
290+ toField = Plain . inQuotes . nominalDiffTimeToBuilder
291+ {-# INLINE toField #-}
292+
293+instance ToField CalendarDiffTime where
294+ toField = Plain . inQuotes . calendarDiffTimeToBuilder
295+ {-# INLINE toField #-}
296+
264297instance (ToField a) => ToField (PGArray a) where
265− toField xs = Many $
266− Plain (fromByteString "ARRAY[") :
267− (intersperse (Plain (fromChar ',')) . map toField $ fromPGArray xs) ++
268− [Plain (fromChar ']')]
269− -- Because the ARRAY[...] input syntax is being used, it is possible
270− -- 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.
271307
272308instance (ToField a) => ToField (Vector a) where
273309 toField = toField . PGArray . V.toList
274310
275311instance ToField UUID where
276− toField = Plain . inQuotes . fromByteString . UUID.toASCIIBytes
312+ toField = Plain . inQuotes . byteString . UUID.toASCIIBytes
277313
278314instance ToField JSON.Value where
279315 toField = toField . JSON.encode
280316
281−-- | Convert a Haskell value to a JSON 'JSON.Value' using
282−-- 'JSON.toJSON' and convert that to a field using 'toField'.
317+-- | Convert a Haskell value to JSON using 'JSON.toEncoding'.
283318--
284319-- This can be used as the default implementation for the 'toField'
285320-- method for Haskell types that have a JSON representation in
286321-- PostgreSQL.
287322toJSONField :: JSON.ToJSON a => a -> Action
288−toJSONField = toField . JSON.toJSON
323+toJSONField = toField . JSON.encode
289324
290325-- | Surround a string with single-quote characters: \"@'@\"
291326--
292327-- This function /does not/ perform any other escaping.
293328inQuotes :: Builder -> Builder
294329inQuotes b = quote `mappend` b `mappend` quote
295− where quote = Utf8.fromChar '\''
330+ where quote = char8 '\''
296331
297332interleaveFoldr :: (a -> [b] -> [b]) -> b -> [b] -> [a] -> [b]
298−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
299334{-# INLINE interleaveFoldr #-}
300335
301336instance ToRow a => ToField (Values a) where
@@ -313,8 +348,8 @@ instance ToRow a => ToField (Values a) where
313348 funcname = "Database.PostgreSQL.Simple.toField :: Values a -> Action"
314349 norows = funcname ++ " either values or types must be non-empty"
315350 emptyrow = funcname ++ " each row must contain at least one column"
316− lit = Plain . fromByteString
317− litC = Plain . fromChar
351+ lit = Plain . byteString
352+ litC = Plain . char8
318353 values x = Many (lit "(VALUES ": x)
319354
320355 typedField :: (Action, QualifiedIdentifier) -> [Action] -> [Action]
@@ -342,8 +377,8 @@ instance ToRow a => ToField (Values a) where
342377
343378 typedRows :: ToRow a => [a] -> [QualifiedIdentifier] -> [Action] -> [Action]
344379 typedRows [] _ _ = error funcname
345− typedRows (val:vals) types rest =
346− typedRow (toRow val) types (multiRows vals rest)
380+ typedRows (val:vals) typs rest =
381+ typedRow (toRow val) typs (multiRows vals rest)
347382
348383 untypedRows :: ToRow a => [a] -> [Action] -> [Action]
349384 untypedRows [] _ = error funcname
src/Database/PostgreSQL/Simple/ToField.hs-boot+1−1
@@ -1,7 +1,7 @@
11module Database.PostgreSQL.Simple.ToField where
22
33import Database.PostgreSQL.Simple.Types
4−import Blaze.ByteString.Builder(Builder)
4+import Data.ByteString.Builder(Builder)
55import Data.ByteString(ByteString)
66
77-- | How to render an element when substituting it into a query.
src/Database/PostgreSQL/Simple/ToRow.hs+128−1
@@ -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--
29−-- Instances should use the 'render' method of the 'Param' class
31+-- 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+1377−73
@@ -19,52 +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
44− , abstime
45− , reltime
46− , tinterval
66+ , float8Oid
4767 , unknown
68+ , unknownOid
4869 , circle
70+ , circleOid
4971 , money
72+ , moneyOid
5073 , macaddr
74+ , macaddrOid
5175 , inet
76+ , inetOid
5277 , bpchar
78+ , bpcharOid
5379 , varchar
80+ , varcharOid
5481 , date
82+ , dateOid
5583 , time
84+ , timeOid
5685 , timestamp
86+ , timestampOid
5787 , timestamptz
88+ , timestamptzOid
5889 , interval
90+ , intervalOid
5991 , timetz
92+ , timetzOid
6093 , bit
94+ , bitOid
6195 , varbit
96+ , varbitOid
6297 , numeric
98+ , numericOid
6399 , refcursor
100+ , refcursorOid
64101 , record
102+ , recordOid
65103 , void
104+ , voidOid
105+ , array_record
106+ , array_recordOid
107+ , regprocedure
108+ , regprocedureOid
109+ , regoper
110+ , regoperOid
111+ , regoperator
112+ , regoperatorOid
113+ , regclass
114+ , regclassOid
115+ , regtype
116+ , regtypeOid
66117 , uuid
118+ , uuidOid
67119 , json
120+ , jsonOid
121+ , jsonb
122+ , jsonbOid
123+ , int2vector
124+ , int2vectorOid
125+ , oidvector
126+ , oidvectorOid
127+ , array_xml
128+ , array_xmlOid
129+ , array_json
130+ , array_jsonOid
131+ , array_line
132+ , array_lineOid
133+ , array_cidr
134+ , array_cidrOid
135+ , array_circle
136+ , array_circleOid
137+ , array_money
138+ , array_moneyOid
139+ , array_bool
140+ , array_boolOid
141+ , array_bytea
142+ , array_byteaOid
143+ , array_char
144+ , array_charOid
145+ , array_name
146+ , array_nameOid
147+ , array_int2
148+ , array_int2Oid
149+ , array_int2vector
150+ , array_int2vectorOid
151+ , array_int4
152+ , array_int4Oid
153+ , array_regproc
154+ , array_regprocOid
155+ , array_text
156+ , array_textOid
157+ , array_tid
158+ , array_tidOid
159+ , array_xid
160+ , array_xidOid
161+ , array_cid
162+ , array_cidOid
163+ , array_oidvector
164+ , array_oidvectorOid
165+ , array_bpchar
166+ , array_bpcharOid
167+ , array_varchar
168+ , array_varcharOid
169+ , array_int8
170+ , array_int8Oid
171+ , array_point
172+ , array_pointOid
173+ , array_lseg
174+ , array_lsegOid
175+ , array_path
176+ , array_pathOid
177+ , array_box
178+ , array_boxOid
179+ , array_float4
180+ , array_float4Oid
181+ , array_float8
182+ , array_float8Oid
183+ , array_polygon
184+ , array_polygonOid
185+ , array_oid
186+ , array_oidOid
187+ , array_macaddr
188+ , array_macaddrOid
189+ , array_inet
190+ , array_inetOid
191+ , array_timestamp
192+ , array_timestampOid
193+ , array_date
194+ , array_dateOid
195+ , array_time
196+ , array_timeOid
197+ , array_timestamptz
198+ , array_timestamptzOid
199+ , array_interval
200+ , array_intervalOid
201+ , array_numeric
202+ , array_numericOid
203+ , array_timetz
204+ , array_timetzOid
205+ , array_bit
206+ , array_bitOid
207+ , array_varbit
208+ , array_varbitOid
209+ , array_refcursor
210+ , array_refcursorOid
211+ , array_regprocedure
212+ , array_regprocedureOid
213+ , array_regoper
214+ , array_regoperOid
215+ , array_regoperator
216+ , array_regoperatorOid
217+ , array_regclass
218+ , array_regclassOid
219+ , array_regtype
220+ , array_regtypeOid
221+ , array_uuid
222+ , array_uuidOid
223+ , array_jsonb
224+ , array_jsonbOid
225+ , int4range
226+ , int4rangeOid
227+ , _int4range
228+ , _int4rangeOid
229+ , numrange
230+ , numrangeOid
231+ , _numrange
232+ , _numrangeOid
233+ , tsrange
234+ , tsrangeOid
235+ , _tsrange
236+ , _tsrangeOid
237+ , tstzrange
238+ , tstzrangeOid
239+ , _tstzrange
240+ , _tstzrangeOid
241+ , daterange
242+ , daterangeOid
243+ , _daterange
244+ , _daterangeOid
245+ , int8range
246+ , int8rangeOid
247+ , _int8range
248+ , _int8rangeOid
68249 ) where
69250
70251import Database.PostgreSQL.LibPQ (Oid(..))
@@ -95,9 +276,6 @@ staticTypeInfo (Oid x) = case x of
95276 650 -> Just cidr
96277 700 -> Just float4
97278 701 -> Just float8
98− 702 -> Just abstime
99− 703 -> Just reltime
100− 704 -> Just tinterval
101279 705 -> Just unknown
102280 718 -> Just circle
103281 790 -> Just money
@@ -117,382 +295,1508 @@ staticTypeInfo (Oid x) = case x of
117295 1790 -> Just refcursor
118296 2249 -> Just record
119297 2278 -> Just void
298+ 2287 -> Just array_record
299+ 2202 -> Just regprocedure
300+ 2203 -> Just regoper
301+ 2204 -> Just regoperator
302+ 2205 -> Just regclass
303+ 2206 -> Just regtype
120304 2950 -> Just uuid
121305 114 -> Just json
306+ 3802 -> Just jsonb
307+ 22 -> Just int2vector
308+ 30 -> Just oidvector
309+ 143 -> Just array_xml
310+ 199 -> Just array_json
311+ 629 -> Just array_line
312+ 651 -> Just array_cidr
313+ 719 -> Just array_circle
314+ 791 -> Just array_money
315+ 1000 -> Just array_bool
316+ 1001 -> Just array_bytea
317+ 1002 -> Just array_char
318+ 1003 -> Just array_name
319+ 1005 -> Just array_int2
320+ 1006 -> Just array_int2vector
321+ 1007 -> Just array_int4
322+ 1008 -> Just array_regproc
323+ 1009 -> Just array_text
324+ 1010 -> Just array_tid
325+ 1011 -> Just array_xid
326+ 1012 -> Just array_cid
327+ 1013 -> Just array_oidvector
328+ 1014 -> Just array_bpchar
329+ 1015 -> Just array_varchar
330+ 1016 -> Just array_int8
331+ 1017 -> Just array_point
332+ 1018 -> Just array_lseg
333+ 1019 -> Just array_path
334+ 1020 -> Just array_box
335+ 1021 -> Just array_float4
336+ 1022 -> Just array_float8
337+ 1027 -> Just array_polygon
338+ 1028 -> Just array_oid
339+ 1040 -> Just array_macaddr
340+ 1041 -> Just array_inet
341+ 1115 -> Just array_timestamp
342+ 1182 -> Just array_date
343+ 1183 -> Just array_time
344+ 1185 -> Just array_timestamptz
345+ 1187 -> Just array_interval
346+ 1231 -> Just array_numeric
347+ 1270 -> Just array_timetz
348+ 1561 -> Just array_bit
349+ 1563 -> Just array_varbit
350+ 2201 -> Just array_refcursor
351+ 2207 -> Just array_regprocedure
352+ 2208 -> Just array_regoper
353+ 2209 -> Just array_regoperator
354+ 2210 -> Just array_regclass
355+ 2211 -> Just array_regtype
356+ 2951 -> Just array_uuid
357+ 3807 -> Just array_jsonb
358+ 3904 -> Just int4range
359+ 3905 -> Just _int4range
360+ 3906 -> Just numrange
361+ 3907 -> Just _numrange
362+ 3908 -> Just tsrange
363+ 3909 -> Just _tsrange
364+ 3910 -> Just tstzrange
365+ 3911 -> Just _tstzrange
366+ 3912 -> Just daterange
367+ 3913 -> Just _daterange
368+ 3926 -> Just int8range
369+ 3927 -> Just _int8range
122370 _ -> Nothing
123371
124372bool :: TypeInfo
125373bool = Basic {
126− typoid = Oid 16,
374+ typoid = boolOid,
127375 typcategory = 'B',
128376 typdelim = ',',
129377 typname = "bool"
130378 }
131379
380+boolOid :: Oid
381+boolOid = Oid 16
382+{-# INLINE boolOid #-}
383+
132384bytea :: TypeInfo
133385bytea = Basic {
134− typoid = Oid 17,
386+ typoid = byteaOid,
135387 typcategory = 'U',
136388 typdelim = ',',
137389 typname = "bytea"
138390 }
139391
392+byteaOid :: Oid
393+byteaOid = Oid 17
394+{-# INLINE byteaOid #-}
395+
140396char :: TypeInfo
141397char = Basic {
142− typoid = Oid 18,
398+ typoid = charOid,
143399 typcategory = 'S',
144400 typdelim = ',',
145401 typname = "char"
146402 }
147403
404+charOid :: Oid
405+charOid = Oid 18
406+{-# INLINE charOid #-}
407+
148408name :: TypeInfo
149409name = Basic {
150− typoid = Oid 19,
410+ typoid = nameOid,
151411 typcategory = 'S',
152412 typdelim = ',',
153413 typname = "name"
154414 }
155415
416+nameOid :: Oid
417+nameOid = Oid 19
418+{-# INLINE nameOid #-}
419+
156420int8 :: TypeInfo
157421int8 = Basic {
158− typoid = Oid 20,
422+ typoid = int8Oid,
159423 typcategory = 'N',
160424 typdelim = ',',
161425 typname = "int8"
162426 }
163427
428+int8Oid :: Oid
429+int8Oid = Oid 20
430+{-# INLINE int8Oid #-}
431+
164432int2 :: TypeInfo
165433int2 = Basic {
166− typoid = Oid 21,
434+ typoid = int2Oid,
167435 typcategory = 'N',
168436 typdelim = ',',
169437 typname = "int2"
170438 }
171439
440+int2Oid :: Oid
441+int2Oid = Oid 21
442+{-# INLINE int2Oid #-}
443+
172444int4 :: TypeInfo
173445int4 = Basic {
174− typoid = Oid 23,
446+ typoid = int4Oid,
175447 typcategory = 'N',
176448 typdelim = ',',
177449 typname = "int4"
178450 }
179451
452+int4Oid :: Oid
453+int4Oid = Oid 23
454+{-# INLINE int4Oid #-}
455+
180456regproc :: TypeInfo
181457regproc = Basic {
182− typoid = Oid 24,
458+ typoid = regprocOid,
183459 typcategory = 'N',
184460 typdelim = ',',
185461 typname = "regproc"
186462 }
187463
464+regprocOid :: Oid
465+regprocOid = Oid 24
466+{-# INLINE regprocOid #-}
467+
188468text :: TypeInfo
189469text = Basic {
190− typoid = Oid 25,
470+ typoid = textOid,
191471 typcategory = 'S',
192472 typdelim = ',',
193473 typname = "text"
194474 }
195475
476+textOid :: Oid
477+textOid = Oid 25
478+{-# INLINE textOid #-}
479+
196480oid :: TypeInfo
197481oid = Basic {
198− typoid = Oid 26,
482+ typoid = oidOid,
199483 typcategory = 'N',
200484 typdelim = ',',
201485 typname = "oid"
202486 }
203487
488+oidOid :: Oid
489+oidOid = Oid 26
490+{-# INLINE oidOid #-}
491+
204492tid :: TypeInfo
205493tid = Basic {
206− typoid = Oid 27,
494+ typoid = tidOid,
207495 typcategory = 'U',
208496 typdelim = ',',
209497 typname = "tid"
210498 }
211499
500+tidOid :: Oid
501+tidOid = Oid 27
502+{-# INLINE tidOid #-}
503+
212504xid :: TypeInfo
213505xid = Basic {
214− typoid = Oid 28,
506+ typoid = xidOid,
215507 typcategory = 'U',
216508 typdelim = ',',
217509 typname = "xid"
218510 }
219511
512+xidOid :: Oid
513+xidOid = Oid 28
514+{-# INLINE xidOid #-}
515+
220516cid :: TypeInfo
221517cid = Basic {
222− typoid = Oid 29,
518+ typoid = cidOid,
223519 typcategory = 'U',
224520 typdelim = ',',
225521 typname = "cid"
226522 }
227523
524+cidOid :: Oid
525+cidOid = Oid 29
526+{-# INLINE cidOid #-}
527+
228528xml :: TypeInfo
229529xml = Basic {
230− typoid = Oid 142,
530+ typoid = xmlOid,
231531 typcategory = 'U',
232532 typdelim = ',',
233533 typname = "xml"
234534 }
235535
536+xmlOid :: Oid
537+xmlOid = Oid 142
538+{-# INLINE xmlOid #-}
539+
236540point :: TypeInfo
237541point = Basic {
238− typoid = Oid 600,
542+ typoid = pointOid,
239543 typcategory = 'G',
240544 typdelim = ',',
241545 typname = "point"
242546 }
243547
548+pointOid :: Oid
549+pointOid = Oid 600
550+{-# INLINE pointOid #-}
551+
244552lseg :: TypeInfo
245553lseg = Basic {
246− typoid = Oid 601,
554+ typoid = lsegOid,
247555 typcategory = 'G',
248556 typdelim = ',',
249557 typname = "lseg"
250558 }
251559
560+lsegOid :: Oid
561+lsegOid = Oid 601
562+{-# INLINE lsegOid #-}
563+
252564path :: TypeInfo
253565path = Basic {
254− typoid = Oid 602,
566+ typoid = pathOid,
255567 typcategory = 'G',
256568 typdelim = ',',
257569 typname = "path"
258570 }
259571
572+pathOid :: Oid
573+pathOid = Oid 602
574+{-# INLINE pathOid #-}
575+
260576box :: TypeInfo
261577box = Basic {
262− typoid = Oid 603,
578+ typoid = boxOid,
263579 typcategory = 'G',
264580 typdelim = ';',
265581 typname = "box"
266582 }
267583
584+boxOid :: Oid
585+boxOid = Oid 603
586+{-# INLINE boxOid #-}
587+
268588polygon :: TypeInfo
269589polygon = Basic {
270− typoid = Oid 604,
590+ typoid = polygonOid,
271591 typcategory = 'G',
272592 typdelim = ',',
273593 typname = "polygon"
274594 }
275595
596+polygonOid :: Oid
597+polygonOid = Oid 604
598+{-# INLINE polygonOid #-}
599+
276600line :: TypeInfo
277601line = Basic {
278− typoid = Oid 628,
602+ typoid = lineOid,
279603 typcategory = 'G',
280604 typdelim = ',',
281605 typname = "line"
282606 }
283607
608+lineOid :: Oid
609+lineOid = Oid 628
610+{-# INLINE lineOid #-}
611+
284612cidr :: TypeInfo
285613cidr = Basic {
286− typoid = Oid 650,
614+ typoid = cidrOid,
287615 typcategory = 'I',
288616 typdelim = ',',
289617 typname = "cidr"
290618 }
291619
620+cidrOid :: Oid
621+cidrOid = Oid 650
622+{-# INLINE cidrOid #-}
623+
292624float4 :: TypeInfo
293625float4 = Basic {
294− typoid = Oid 700,
626+ typoid = float4Oid,
295627 typcategory = 'N',
296628 typdelim = ',',
297629 typname = "float4"
298630 }
299631
632+float4Oid :: Oid
633+float4Oid = Oid 700
634+{-# INLINE float4Oid #-}
635+
300636float8 :: TypeInfo
301637float8 = Basic {
302− typoid = Oid 701,
638+ typoid = float8Oid,
303639 typcategory = 'N',
304640 typdelim = ',',
305641 typname = "float8"
306642 }
307643
308−abstime :: TypeInfo
309−abstime = Basic {
310− typoid = Oid 702,
311− typcategory = 'D',
312− typdelim = ',',
313− typname = "abstime"
314− }
315−
316−reltime :: TypeInfo
317−reltime = Basic {
318− typoid = Oid 703,
319− typcategory = 'T',
320− typdelim = ',',
321− typname = "reltime"
322− }
323−
324−tinterval :: TypeInfo
325−tinterval = Basic {
326− typoid = Oid 704,
327− typcategory = 'T',
328− typdelim = ',',
329− typname = "tinterval"
330− }
644+float8Oid :: Oid
645+float8Oid = Oid 701
646+{-# INLINE float8Oid #-}
331647
332648unknown :: TypeInfo
333649unknown = Basic {
334− typoid = Oid 705,
650+ typoid = unknownOid,
335651 typcategory = 'X',
336652 typdelim = ',',
337653 typname = "unknown"
338654 }
339655
656+unknownOid :: Oid
657+unknownOid = Oid 705
658+{-# INLINE unknownOid #-}
659+
340660circle :: TypeInfo
341661circle = Basic {
342− typoid = Oid 718,
662+ typoid = circleOid,
343663 typcategory = 'G',
344664 typdelim = ',',
345665 typname = "circle"
346666 }
347667
668+circleOid :: Oid
669+circleOid = Oid 718
670+{-# INLINE circleOid #-}
671+
348672money :: TypeInfo
349673money = Basic {
350− typoid = Oid 790,
674+ typoid = moneyOid,
351675 typcategory = 'N',
352676 typdelim = ',',
353677 typname = "money"
354678 }
355679
680+moneyOid :: Oid
681+moneyOid = Oid 790
682+{-# INLINE moneyOid #-}
683+
356684macaddr :: TypeInfo
357685macaddr = Basic {
358− typoid = Oid 829,
686+ typoid = macaddrOid,
359687 typcategory = 'U',
360688 typdelim = ',',
361689 typname = "macaddr"
362690 }
363691
692+macaddrOid :: Oid
693+macaddrOid = Oid 829
694+{-# INLINE macaddrOid #-}
695+
364696inet :: TypeInfo
365697inet = Basic {
366− typoid = Oid 869,
698+ typoid = inetOid,
367699 typcategory = 'I',
368700 typdelim = ',',
369701 typname = "inet"
370702 }
371703
704+inetOid :: Oid
705+inetOid = Oid 869
706+{-# INLINE inetOid #-}
707+
372708bpchar :: TypeInfo
373709bpchar = Basic {
374− typoid = Oid 1042,
710+ typoid = bpcharOid,
375711 typcategory = 'S',
376712 typdelim = ',',
377713 typname = "bpchar"
378714 }
379715
716+bpcharOid :: Oid
717+bpcharOid = Oid 1042
718+{-# INLINE bpcharOid #-}
719+
380720varchar :: TypeInfo
381721varchar = Basic {
382− typoid = Oid 1043,
722+ typoid = varcharOid,
383723 typcategory = 'S',
384724 typdelim = ',',
385725 typname = "varchar"
386726 }
387727
728+varcharOid :: Oid
729+varcharOid = Oid 1043
730+{-# INLINE varcharOid #-}
731+
388732date :: TypeInfo
389733date = Basic {
390− typoid = Oid 1082,
734+ typoid = dateOid,
391735 typcategory = 'D',
392736 typdelim = ',',
393737 typname = "date"
394738 }
395739
740+dateOid :: Oid
741+dateOid = Oid 1082
742+{-# INLINE dateOid #-}
743+
396744time :: TypeInfo
397745time = Basic {
398− typoid = Oid 1083,
746+ typoid = timeOid,
399747 typcategory = 'D',
400748 typdelim = ',',
401749 typname = "time"
402750 }
403751
752+timeOid :: Oid
753+timeOid = Oid 1083
754+{-# INLINE timeOid #-}
755+
404756timestamp :: TypeInfo
405757timestamp = Basic {
406− typoid = Oid 1114,
758+ typoid = timestampOid,
407759 typcategory = 'D',
408760 typdelim = ',',
409761 typname = "timestamp"
410762 }
411763
764+timestampOid :: Oid
765+timestampOid = Oid 1114
766+{-# INLINE timestampOid #-}
767+
412768timestamptz :: TypeInfo
413769timestamptz = Basic {
414− typoid = Oid 1184,
770+ typoid = timestamptzOid,
415771 typcategory = 'D',
416772 typdelim = ',',
417773 typname = "timestamptz"
418774 }
419775
776+timestamptzOid :: Oid
777+timestamptzOid = Oid 1184
778+{-# INLINE timestamptzOid #-}
779+
420780interval :: TypeInfo
421781interval = Basic {
422− typoid = Oid 1186,
782+ typoid = intervalOid,
423783 typcategory = 'T',
424784 typdelim = ',',
425785 typname = "interval"
426786 }
427787
788+intervalOid :: Oid
789+intervalOid = Oid 1186
790+{-# INLINE intervalOid #-}
791+
428792timetz :: TypeInfo
429793timetz = Basic {
430− typoid = Oid 1266,
794+ typoid = timetzOid,
431795 typcategory = 'D',
432796 typdelim = ',',
433797 typname = "timetz"
434798 }
435799
800+timetzOid :: Oid
801+timetzOid = Oid 1266
802+{-# INLINE timetzOid #-}
803+
436804bit :: TypeInfo
437805bit = Basic {
438− typoid = Oid 1560,
806+ typoid = bitOid,
439807 typcategory = 'V',
440808 typdelim = ',',
441809 typname = "bit"
442810 }
443811
812+bitOid :: Oid
813+bitOid = Oid 1560
814+{-# INLINE bitOid #-}
815+
444816varbit :: TypeInfo
445817varbit = Basic {
446− typoid = Oid 1562,
818+ typoid = varbitOid,
447819 typcategory = 'V',
448820 typdelim = ',',
449821 typname = "varbit"
450822 }
451823
824+varbitOid :: Oid
825+varbitOid = Oid 1562
826+{-# INLINE varbitOid #-}
827+
452828numeric :: TypeInfo
453829numeric = Basic {
454− typoid = Oid 1700,
830+ typoid = numericOid,
455831 typcategory = 'N',
456832 typdelim = ',',
457833 typname = "numeric"
458834 }
459835
836+numericOid :: Oid
837+numericOid = Oid 1700
838+{-# INLINE numericOid #-}
839+
460840refcursor :: TypeInfo
461841refcursor = Basic {
462− typoid = Oid 1790,
842+ typoid = refcursorOid,
463843 typcategory = 'U',
464844 typdelim = ',',
465845 typname = "refcursor"
466846 }
467847
848+refcursorOid :: Oid
849+refcursorOid = Oid 1790
850+{-# INLINE refcursorOid #-}
851+
468852record :: TypeInfo
469853record = Basic {
470− typoid = Oid 2249,
854+ typoid = recordOid,
471855 typcategory = 'P',
472856 typdelim = ',',
473857 typname = "record"
474858 }
475859
860+recordOid :: Oid
861+recordOid = Oid 2249
862+{-# INLINE recordOid #-}
863+
476864void :: TypeInfo
477865void = Basic {
478− typoid = Oid 2278,
866+ typoid = voidOid,
479867 typcategory = 'P',
480868 typdelim = ',',
481869 typname = "void"
482870 }
483871
872+voidOid :: Oid
873+voidOid = Oid 2278
874+{-# INLINE voidOid #-}
875+
876+array_record :: TypeInfo
877+array_record = Array {
878+ typoid = array_recordOid,
879+ typcategory = 'P',
880+ typdelim = ',',
881+ typname = "_record",
882+ typelem = record
883+ }
884+
885+array_recordOid :: Oid
886+array_recordOid = Oid 2287
887+{-# INLINE array_recordOid #-}
888+
889+regprocedure :: TypeInfo
890+regprocedure = Basic {
891+ typoid = regprocedureOid,
892+ typcategory = 'N',
893+ typdelim = ',',
894+ typname = "regprocedure"
895+ }
896+
897+regprocedureOid :: Oid
898+regprocedureOid = Oid 2202
899+{-# INLINE regprocedureOid #-}
900+
901+regoper :: TypeInfo
902+regoper = Basic {
903+ typoid = regoperOid,
904+ typcategory = 'N',
905+ typdelim = ',',
906+ typname = "regoper"
907+ }
908+
909+regoperOid :: Oid
910+regoperOid = Oid 2203
911+{-# INLINE regoperOid #-}
912+
913+regoperator :: TypeInfo
914+regoperator = Basic {
915+ typoid = regoperatorOid,
916+ typcategory = 'N',
917+ typdelim = ',',
918+ typname = "regoperator"
919+ }
920+
921+regoperatorOid :: Oid
922+regoperatorOid = Oid 2204
923+{-# INLINE regoperatorOid #-}
924+
925+regclass :: TypeInfo
926+regclass = Basic {
927+ typoid = regclassOid,
928+ typcategory = 'N',
929+ typdelim = ',',
930+ typname = "regclass"
931+ }
932+
933+regclassOid :: Oid
934+regclassOid = Oid 2205
935+{-# INLINE regclassOid #-}
936+
937+regtype :: TypeInfo
938+regtype = Basic {
939+ typoid = regtypeOid,
940+ typcategory = 'N',
941+ typdelim = ',',
942+ typname = "regtype"
943+ }
944+
945+regtypeOid :: Oid
946+regtypeOid = Oid 2206
947+{-# INLINE regtypeOid #-}
948+
484949uuid :: TypeInfo
485950uuid = Basic {
486− typoid = Oid 2950,
951+ typoid = uuidOid,
487952 typcategory = 'U',
488953 typdelim = ',',
489954 typname = "uuid"
490955 }
491956
957+uuidOid :: Oid
958+uuidOid = Oid 2950
959+{-# INLINE uuidOid #-}
960+
492961json :: TypeInfo
493962json = Basic {
494− typoid = Oid 114,
963+ typoid = jsonOid,
495964 typcategory = 'U',
496965 typdelim = ',',
497966 typname = "json"
498967 }
968+
969+jsonOid :: Oid
970+jsonOid = Oid 114
971+{-# INLINE jsonOid #-}
972+
973+jsonb :: TypeInfo
974+jsonb = Basic {
975+ typoid = jsonbOid,
976+ typcategory = 'U',
977+ typdelim = ',',
978+ typname = "jsonb"
979+ }
980+
981+jsonbOid :: Oid
982+jsonbOid = Oid 3802
983+{-# INLINE jsonbOid #-}
984+
985+int2vector :: TypeInfo
986+int2vector = Array {
987+ typoid = int2vectorOid,
988+ typcategory = 'A',
989+ typdelim = ',',
990+ typname = "int2vector",
991+ typelem = int2
992+ }
993+
994+int2vectorOid :: Oid
995+int2vectorOid = Oid 22
996+{-# INLINE int2vectorOid #-}
997+
998+oidvector :: TypeInfo
999+oidvector = Array {
1000+ typoid = oidvectorOid,
1001+ typcategory = 'A',
1002+ typdelim = ',',
1003+ typname = "oidvector",
1004+ typelem = oid
1005+ }
1006+
1007+oidvectorOid :: Oid
1008+oidvectorOid = Oid 30
1009+{-# INLINE oidvectorOid #-}
1010+
1011+array_xml :: TypeInfo
1012+array_xml = Array {
1013+ typoid = array_xmlOid,
1014+ typcategory = 'A',
1015+ typdelim = ',',
1016+ typname = "_xml",
1017+ typelem = xml
1018+ }
1019+
1020+array_xmlOid :: Oid
1021+array_xmlOid = Oid 143
1022+{-# INLINE array_xmlOid #-}
1023+
1024+array_json :: TypeInfo
1025+array_json = Array {
1026+ typoid = array_jsonOid,
1027+ typcategory = 'A',
1028+ typdelim = ',',
1029+ typname = "_json",
1030+ typelem = json
1031+ }
1032+
1033+array_jsonOid :: Oid
1034+array_jsonOid = Oid 199
1035+{-# INLINE array_jsonOid #-}
1036+
1037+array_line :: TypeInfo
1038+array_line = Array {
1039+ typoid = array_lineOid,
1040+ typcategory = 'A',
1041+ typdelim = ',',
1042+ typname = "_line",
1043+ typelem = line
1044+ }
1045+
1046+array_lineOid :: Oid
1047+array_lineOid = Oid 629
1048+{-# INLINE array_lineOid #-}
1049+
1050+array_cidr :: TypeInfo
1051+array_cidr = Array {
1052+ typoid = array_cidrOid,
1053+ typcategory = 'A',
1054+ typdelim = ',',
1055+ typname = "_cidr",
1056+ typelem = cidr
1057+ }
1058+
1059+array_cidrOid :: Oid
1060+array_cidrOid = Oid 651
1061+{-# INLINE array_cidrOid #-}
1062+
1063+array_circle :: TypeInfo
1064+array_circle = Array {
1065+ typoid = array_circleOid,
1066+ typcategory = 'A',
1067+ typdelim = ',',
1068+ typname = "_circle",
1069+ typelem = circle
1070+ }
1071+
1072+array_circleOid :: Oid
1073+array_circleOid = Oid 719
1074+{-# INLINE array_circleOid #-}
1075+
1076+array_money :: TypeInfo
1077+array_money = Array {
1078+ typoid = array_moneyOid,
1079+ typcategory = 'A',
1080+ typdelim = ',',
1081+ typname = "_money",
1082+ typelem = money
1083+ }
1084+
1085+array_moneyOid :: Oid
1086+array_moneyOid = Oid 791
1087+{-# INLINE array_moneyOid #-}
1088+
1089+array_bool :: TypeInfo
1090+array_bool = Array {
1091+ typoid = array_boolOid,
1092+ typcategory = 'A',
1093+ typdelim = ',',
1094+ typname = "_bool",
1095+ typelem = bool
1096+ }
1097+
1098+array_boolOid :: Oid
1099+array_boolOid = Oid 1000
1100+{-# INLINE array_boolOid #-}
1101+
1102+array_bytea :: TypeInfo
1103+array_bytea = Array {
1104+ typoid = array_byteaOid,
1105+ typcategory = 'A',
1106+ typdelim = ',',
1107+ typname = "_bytea",
1108+ typelem = bytea
1109+ }
1110+
1111+array_byteaOid :: Oid
1112+array_byteaOid = Oid 1001
1113+{-# INLINE array_byteaOid #-}
1114+
1115+array_char :: TypeInfo
1116+array_char = Array {
1117+ typoid = array_charOid,
1118+ typcategory = 'A',
1119+ typdelim = ',',
1120+ typname = "_char",
1121+ typelem = char
1122+ }
1123+
1124+array_charOid :: Oid
1125+array_charOid = Oid 1002
1126+{-# INLINE array_charOid #-}
1127+
1128+array_name :: TypeInfo
1129+array_name = Array {
1130+ typoid = array_nameOid,
1131+ typcategory = 'A',
1132+ typdelim = ',',
1133+ typname = "_name",
1134+ typelem = name
1135+ }
1136+
1137+array_nameOid :: Oid
1138+array_nameOid = Oid 1003
1139+{-# INLINE array_nameOid #-}
1140+
1141+array_int2 :: TypeInfo
1142+array_int2 = Array {
1143+ typoid = array_int2Oid,
1144+ typcategory = 'A',
1145+ typdelim = ',',
1146+ typname = "_int2",
1147+ typelem = int2
1148+ }
1149+
1150+array_int2Oid :: Oid
1151+array_int2Oid = Oid 1005
1152+{-# INLINE array_int2Oid #-}
1153+
1154+array_int2vector :: TypeInfo
1155+array_int2vector = Array {
1156+ typoid = array_int2vectorOid,
1157+ typcategory = 'A',
1158+ typdelim = ',',
1159+ typname = "_int2vector",
1160+ typelem = int2vector
1161+ }
1162+
1163+array_int2vectorOid :: Oid
1164+array_int2vectorOid = Oid 1006
1165+{-# INLINE array_int2vectorOid #-}
1166+
1167+array_int4 :: TypeInfo
1168+array_int4 = Array {
1169+ typoid = array_int4Oid,
1170+ typcategory = 'A',
1171+ typdelim = ',',
1172+ typname = "_int4",
1173+ typelem = int4
1174+ }
1175+
1176+array_int4Oid :: Oid
1177+array_int4Oid = Oid 1007
1178+{-# INLINE array_int4Oid #-}
1179+
1180+array_regproc :: TypeInfo
1181+array_regproc = Array {
1182+ typoid = array_regprocOid,
1183+ typcategory = 'A',
1184+ typdelim = ',',
1185+ typname = "_regproc",
1186+ typelem = regproc
1187+ }
1188+
1189+array_regprocOid :: Oid
1190+array_regprocOid = Oid 1008
1191+{-# INLINE array_regprocOid #-}
1192+
1193+array_text :: TypeInfo
1194+array_text = Array {
1195+ typoid = array_textOid,
1196+ typcategory = 'A',
1197+ typdelim = ',',
1198+ typname = "_text",
1199+ typelem = text
1200+ }
1201+
1202+array_textOid :: Oid
1203+array_textOid = Oid 1009
1204+{-# INLINE array_textOid #-}
1205+
1206+array_tid :: TypeInfo
1207+array_tid = Array {
1208+ typoid = array_tidOid,
1209+ typcategory = 'A',
1210+ typdelim = ',',
1211+ typname = "_tid",
1212+ typelem = tid
1213+ }
1214+
1215+array_tidOid :: Oid
1216+array_tidOid = Oid 1010
1217+{-# INLINE array_tidOid #-}
1218+
1219+array_xid :: TypeInfo
1220+array_xid = Array {
1221+ typoid = array_xidOid,
1222+ typcategory = 'A',
1223+ typdelim = ',',
1224+ typname = "_xid",
1225+ typelem = xid
1226+ }
1227+
1228+array_xidOid :: Oid
1229+array_xidOid = Oid 1011
1230+{-# INLINE array_xidOid #-}
1231+
1232+array_cid :: TypeInfo
1233+array_cid = Array {
1234+ typoid = array_cidOid,
1235+ typcategory = 'A',
1236+ typdelim = ',',
1237+ typname = "_cid",
1238+ typelem = cid
1239+ }
1240+
1241+array_cidOid :: Oid
1242+array_cidOid = Oid 1012
1243+{-# INLINE array_cidOid #-}
1244+
1245+array_oidvector :: TypeInfo
1246+array_oidvector = Array {
1247+ typoid = array_oidvectorOid,
1248+ typcategory = 'A',
1249+ typdelim = ',',
1250+ typname = "_oidvector",
1251+ typelem = oidvector
1252+ }
1253+
1254+array_oidvectorOid :: Oid
1255+array_oidvectorOid = Oid 1013
1256+{-# INLINE array_oidvectorOid #-}
1257+
1258+array_bpchar :: TypeInfo
1259+array_bpchar = Array {
1260+ typoid = array_bpcharOid,
1261+ typcategory = 'A',
1262+ typdelim = ',',
1263+ typname = "_bpchar",
1264+ typelem = bpchar
1265+ }
1266+
1267+array_bpcharOid :: Oid
1268+array_bpcharOid = Oid 1014
1269+{-# INLINE array_bpcharOid #-}
1270+
1271+array_varchar :: TypeInfo
1272+array_varchar = Array {
1273+ typoid = array_varcharOid,
1274+ typcategory = 'A',
1275+ typdelim = ',',
1276+ typname = "_varchar",
1277+ typelem = varchar
1278+ }
1279+
1280+array_varcharOid :: Oid
1281+array_varcharOid = Oid 1015
1282+{-# INLINE array_varcharOid #-}
1283+
1284+array_int8 :: TypeInfo
1285+array_int8 = Array {
1286+ typoid = array_int8Oid,
1287+ typcategory = 'A',
1288+ typdelim = ',',
1289+ typname = "_int8",
1290+ typelem = int8
1291+ }
1292+
1293+array_int8Oid :: Oid
1294+array_int8Oid = Oid 1016
1295+{-# INLINE array_int8Oid #-}
1296+
1297+array_point :: TypeInfo
1298+array_point = Array {
1299+ typoid = array_pointOid,
1300+ typcategory = 'A',
1301+ typdelim = ',',
1302+ typname = "_point",
1303+ typelem = point
1304+ }
1305+
1306+array_pointOid :: Oid
1307+array_pointOid = Oid 1017
1308+{-# INLINE array_pointOid #-}
1309+
1310+array_lseg :: TypeInfo
1311+array_lseg = Array {
1312+ typoid = array_lsegOid,
1313+ typcategory = 'A',
1314+ typdelim = ',',
1315+ typname = "_lseg",
1316+ typelem = lseg
1317+ }
1318+
1319+array_lsegOid :: Oid
1320+array_lsegOid = Oid 1018
1321+{-# INLINE array_lsegOid #-}
1322+
1323+array_path :: TypeInfo
1324+array_path = Array {
1325+ typoid = array_pathOid,
1326+ typcategory = 'A',
1327+ typdelim = ',',
1328+ typname = "_path",
1329+ typelem = path
1330+ }
1331+
1332+array_pathOid :: Oid
1333+array_pathOid = Oid 1019
1334+{-# INLINE array_pathOid #-}
1335+
1336+array_box :: TypeInfo
1337+array_box = Array {
1338+ typoid = array_boxOid,
1339+ typcategory = 'A',
1340+ typdelim = ';',
1341+ typname = "_box",
1342+ typelem = box
1343+ }
1344+
1345+array_boxOid :: Oid
1346+array_boxOid = Oid 1020
1347+{-# INLINE array_boxOid #-}
1348+
1349+array_float4 :: TypeInfo
1350+array_float4 = Array {
1351+ typoid = array_float4Oid,
1352+ typcategory = 'A',
1353+ typdelim = ',',
1354+ typname = "_float4",
1355+ typelem = float4
1356+ }
1357+
1358+array_float4Oid :: Oid
1359+array_float4Oid = Oid 1021
1360+{-# INLINE array_float4Oid #-}
1361+
1362+array_float8 :: TypeInfo
1363+array_float8 = Array {
1364+ typoid = array_float8Oid,
1365+ typcategory = 'A',
1366+ typdelim = ',',
1367+ typname = "_float8",
1368+ typelem = float8
1369+ }
1370+
1371+array_float8Oid :: Oid
1372+array_float8Oid = Oid 1022
1373+{-# INLINE array_float8Oid #-}
1374+
1375+array_polygon :: TypeInfo
1376+array_polygon = Array {
1377+ typoid = array_polygonOid,
1378+ typcategory = 'A',
1379+ typdelim = ',',
1380+ typname = "_polygon",
1381+ typelem = polygon
1382+ }
1383+
1384+array_polygonOid :: Oid
1385+array_polygonOid = Oid 1027
1386+{-# INLINE array_polygonOid #-}
1387+
1388+array_oid :: TypeInfo
1389+array_oid = Array {
1390+ typoid = array_oidOid,
1391+ typcategory = 'A',
1392+ typdelim = ',',
1393+ typname = "_oid",
1394+ typelem = oid
1395+ }
1396+
1397+array_oidOid :: Oid
1398+array_oidOid = Oid 1028
1399+{-# INLINE array_oidOid #-}
1400+
1401+array_macaddr :: TypeInfo
1402+array_macaddr = Array {
1403+ typoid = array_macaddrOid,
1404+ typcategory = 'A',
1405+ typdelim = ',',
1406+ typname = "_macaddr",
1407+ typelem = macaddr
1408+ }
1409+
1410+array_macaddrOid :: Oid
1411+array_macaddrOid = Oid 1040
1412+{-# INLINE array_macaddrOid #-}
1413+
1414+array_inet :: TypeInfo
1415+array_inet = Array {
1416+ typoid = array_inetOid,
1417+ typcategory = 'A',
1418+ typdelim = ',',
1419+ typname = "_inet",
1420+ typelem = inet
1421+ }
1422+
1423+array_inetOid :: Oid
1424+array_inetOid = Oid 1041
1425+{-# INLINE array_inetOid #-}
1426+
1427+array_timestamp :: TypeInfo
1428+array_timestamp = Array {
1429+ typoid = array_timestampOid,
1430+ typcategory = 'A',
1431+ typdelim = ',',
1432+ typname = "_timestamp",
1433+ typelem = timestamp
1434+ }
1435+
1436+array_timestampOid :: Oid
1437+array_timestampOid = Oid 1115
1438+{-# INLINE array_timestampOid #-}
1439+
1440+array_date :: TypeInfo
1441+array_date = Array {
1442+ typoid = array_dateOid,
1443+ typcategory = 'A',
1444+ typdelim = ',',
1445+ typname = "_date",
1446+ typelem = date
1447+ }
1448+
1449+array_dateOid :: Oid
1450+array_dateOid = Oid 1182
1451+{-# INLINE array_dateOid #-}
1452+
1453+array_time :: TypeInfo
1454+array_time = Array {
1455+ typoid = array_timeOid,
1456+ typcategory = 'A',
1457+ typdelim = ',',
1458+ typname = "_time",
1459+ typelem = time
1460+ }
1461+
1462+array_timeOid :: Oid
1463+array_timeOid = Oid 1183
1464+{-# INLINE array_timeOid #-}
1465+
1466+array_timestamptz :: TypeInfo
1467+array_timestamptz = Array {
1468+ typoid = array_timestamptzOid,
1469+ typcategory = 'A',
1470+ typdelim = ',',
1471+ typname = "_timestamptz",
1472+ typelem = timestamptz
1473+ }
1474+
1475+array_timestamptzOid :: Oid
1476+array_timestamptzOid = Oid 1185
1477+{-# INLINE array_timestamptzOid #-}
1478+
1479+array_interval :: TypeInfo
1480+array_interval = Array {
1481+ typoid = array_intervalOid,
1482+ typcategory = 'A',
1483+ typdelim = ',',
1484+ typname = "_interval",
1485+ typelem = interval
1486+ }
1487+
1488+array_intervalOid :: Oid
1489+array_intervalOid = Oid 1187
1490+{-# INLINE array_intervalOid #-}
1491+
1492+array_numeric :: TypeInfo
1493+array_numeric = Array {
1494+ typoid = array_numericOid,
1495+ typcategory = 'A',
1496+ typdelim = ',',
1497+ typname = "_numeric",
1498+ typelem = numeric
1499+ }
1500+
1501+array_numericOid :: Oid
1502+array_numericOid = Oid 1231
1503+{-# INLINE array_numericOid #-}
1504+
1505+array_timetz :: TypeInfo
1506+array_timetz = Array {
1507+ typoid = array_timetzOid,
1508+ typcategory = 'A',
1509+ typdelim = ',',
1510+ typname = "_timetz",
1511+ typelem = timetz
1512+ }
1513+
1514+array_timetzOid :: Oid
1515+array_timetzOid = Oid 1270
1516+{-# INLINE array_timetzOid #-}
1517+
1518+array_bit :: TypeInfo
1519+array_bit = Array {
1520+ typoid = array_bitOid,
1521+ typcategory = 'A',
1522+ typdelim = ',',
1523+ typname = "_bit",
1524+ typelem = bit
1525+ }
1526+
1527+array_bitOid :: Oid
1528+array_bitOid = Oid 1561
1529+{-# INLINE array_bitOid #-}
1530+
1531+array_varbit :: TypeInfo
1532+array_varbit = Array {
1533+ typoid = array_varbitOid,
1534+ typcategory = 'A',
1535+ typdelim = ',',
1536+ typname = "_varbit",
1537+ typelem = varbit
1538+ }
1539+
1540+array_varbitOid :: Oid
1541+array_varbitOid = Oid 1563
1542+{-# INLINE array_varbitOid #-}
1543+
1544+array_refcursor :: TypeInfo
1545+array_refcursor = Array {
1546+ typoid = array_refcursorOid,
1547+ typcategory = 'A',
1548+ typdelim = ',',
1549+ typname = "_refcursor",
1550+ typelem = refcursor
1551+ }
1552+
1553+array_refcursorOid :: Oid
1554+array_refcursorOid = Oid 2201
1555+{-# INLINE array_refcursorOid #-}
1556+
1557+array_regprocedure :: TypeInfo
1558+array_regprocedure = Array {
1559+ typoid = array_regprocedureOid,
1560+ typcategory = 'A',
1561+ typdelim = ',',
1562+ typname = "_regprocedure",
1563+ typelem = regprocedure
1564+ }
1565+
1566+array_regprocedureOid :: Oid
1567+array_regprocedureOid = Oid 2207
1568+{-# INLINE array_regprocedureOid #-}
1569+
1570+array_regoper :: TypeInfo
1571+array_regoper = Array {
1572+ typoid = array_regoperOid,
1573+ typcategory = 'A',
1574+ typdelim = ',',
1575+ typname = "_regoper",
1576+ typelem = regoper
1577+ }
1578+
1579+array_regoperOid :: Oid
1580+array_regoperOid = Oid 2208
1581+{-# INLINE array_regoperOid #-}
1582+
1583+array_regoperator :: TypeInfo
1584+array_regoperator = Array {
1585+ typoid = array_regoperatorOid,
1586+ typcategory = 'A',
1587+ typdelim = ',',
1588+ typname = "_regoperator",
1589+ typelem = regoperator
1590+ }
1591+
1592+array_regoperatorOid :: Oid
1593+array_regoperatorOid = Oid 2209
1594+{-# INLINE array_regoperatorOid #-}
1595+
1596+array_regclass :: TypeInfo
1597+array_regclass = Array {
1598+ typoid = array_regclassOid,
1599+ typcategory = 'A',
1600+ typdelim = ',',
1601+ typname = "_regclass",
1602+ typelem = regclass
1603+ }
1604+
1605+array_regclassOid :: Oid
1606+array_regclassOid = Oid 2210
1607+{-# INLINE array_regclassOid #-}
1608+
1609+array_regtype :: TypeInfo
1610+array_regtype = Array {
1611+ typoid = array_regtypeOid,
1612+ typcategory = 'A',
1613+ typdelim = ',',
1614+ typname = "_regtype",
1615+ typelem = regtype
1616+ }
1617+
1618+array_regtypeOid :: Oid
1619+array_regtypeOid = Oid 2211
1620+{-# INLINE array_regtypeOid #-}
1621+
1622+array_uuid :: TypeInfo
1623+array_uuid = Array {
1624+ typoid = array_uuidOid,
1625+ typcategory = 'A',
1626+ typdelim = ',',
1627+ typname = "_uuid",
1628+ typelem = uuid
1629+ }
1630+
1631+array_uuidOid :: Oid
1632+array_uuidOid = Oid 2951
1633+{-# INLINE array_uuidOid #-}
1634+
1635+array_jsonb :: TypeInfo
1636+array_jsonb = Array {
1637+ typoid = array_jsonbOid,
1638+ typcategory = 'A',
1639+ typdelim = ',',
1640+ typname = "_jsonb",
1641+ typelem = jsonb
1642+ }
1643+
1644+array_jsonbOid :: Oid
1645+array_jsonbOid = Oid 3807
1646+{-# INLINE array_jsonbOid #-}
1647+
1648+int4range :: TypeInfo
1649+int4range = Range {
1650+ typoid = int4rangeOid,
1651+ typcategory = 'R',
1652+ typdelim = ',',
1653+ typname = "int4range",
1654+ rngsubtype = int4
1655+ }
1656+
1657+int4rangeOid :: Oid
1658+int4rangeOid = Oid 3904
1659+{-# INLINE int4rangeOid #-}
1660+
1661+_int4range :: TypeInfo
1662+_int4range = Array {
1663+ typoid = _int4rangeOid,
1664+ typcategory = 'A',
1665+ typdelim = ',',
1666+ typname = "_int4range",
1667+ typelem = int4range
1668+ }
1669+
1670+_int4rangeOid :: Oid
1671+_int4rangeOid = Oid 3905
1672+{-# INLINE _int4rangeOid #-}
1673+
1674+numrange :: TypeInfo
1675+numrange = Range {
1676+ typoid = numrangeOid,
1677+ typcategory = 'R',
1678+ typdelim = ',',
1679+ typname = "numrange",
1680+ rngsubtype = numeric
1681+ }
1682+
1683+numrangeOid :: Oid
1684+numrangeOid = Oid 3906
1685+{-# INLINE numrangeOid #-}
1686+
1687+_numrange :: TypeInfo
1688+_numrange = Array {
1689+ typoid = _numrangeOid,
1690+ typcategory = 'A',
1691+ typdelim = ',',
1692+ typname = "_numrange",
1693+ typelem = numrange
1694+ }
1695+
1696+_numrangeOid :: Oid
1697+_numrangeOid = Oid 3907
1698+{-# INLINE _numrangeOid #-}
1699+
1700+tsrange :: TypeInfo
1701+tsrange = Range {
1702+ typoid = tsrangeOid,
1703+ typcategory = 'R',
1704+ typdelim = ',',
1705+ typname = "tsrange",
1706+ rngsubtype = timestamp
1707+ }
1708+
1709+tsrangeOid :: Oid
1710+tsrangeOid = Oid 3908
1711+{-# INLINE tsrangeOid #-}
1712+
1713+_tsrange :: TypeInfo
1714+_tsrange = Array {
1715+ typoid = _tsrangeOid,
1716+ typcategory = 'A',
1717+ typdelim = ',',
1718+ typname = "_tsrange",
1719+ typelem = tsrange
1720+ }
1721+
1722+_tsrangeOid :: Oid
1723+_tsrangeOid = Oid 3909
1724+{-# INLINE _tsrangeOid #-}
1725+
1726+tstzrange :: TypeInfo
1727+tstzrange = Range {
1728+ typoid = tstzrangeOid,
1729+ typcategory = 'R',
1730+ typdelim = ',',
1731+ typname = "tstzrange",
1732+ rngsubtype = timestamptz
1733+ }
1734+
1735+tstzrangeOid :: Oid
1736+tstzrangeOid = Oid 3910
1737+{-# INLINE tstzrangeOid #-}
1738+
1739+_tstzrange :: TypeInfo
1740+_tstzrange = Array {
1741+ typoid = _tstzrangeOid,
1742+ typcategory = 'A',
1743+ typdelim = ',',
1744+ typname = "_tstzrange",
1745+ typelem = tstzrange
1746+ }
1747+
1748+_tstzrangeOid :: Oid
1749+_tstzrangeOid = Oid 3911
1750+{-# INLINE _tstzrangeOid #-}
1751+
1752+daterange :: TypeInfo
1753+daterange = Range {
1754+ typoid = daterangeOid,
1755+ typcategory = 'R',
1756+ typdelim = ',',
1757+ typname = "daterange",
1758+ rngsubtype = date
1759+ }
1760+
1761+daterangeOid :: Oid
1762+daterangeOid = Oid 3912
1763+{-# INLINE daterangeOid #-}
1764+
1765+_daterange :: TypeInfo
1766+_daterange = Array {
1767+ typoid = _daterangeOid,
1768+ typcategory = 'A',
1769+ typdelim = ',',
1770+ typname = "_daterange",
1771+ typelem = daterange
1772+ }
1773+
1774+_daterangeOid :: Oid
1775+_daterangeOid = Oid 3913
1776+{-# INLINE _daterangeOid #-}
1777+
1778+int8range :: TypeInfo
1779+int8range = Range {
1780+ typoid = int8rangeOid,
1781+ typcategory = 'R',
1782+ typdelim = ',',
1783+ typname = "int8range",
1784+ rngsubtype = int8
1785+ }
1786+
1787+int8rangeOid :: Oid
1788+int8rangeOid = Oid 3926
1789+{-# INLINE int8rangeOid #-}
1790+
1791+_int8range :: TypeInfo
1792+_int8range = Array {
1793+ typoid = _int8rangeOid,
1794+ typcategory = 'A',
1795+ typdelim = ',',
1796+ typname = "_int8range",
1797+ typelem = int8range
1798+ }
1799+
1800+_int8rangeOid :: Oid
1801+_int8rangeOid = Oid 3927
1802+{-# INLINE _int8rangeOid #-}
src/Database/PostgreSQL/Simple/Types.hs+57−33
@@ -1,4 +1,4 @@
1−{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, GeneralizedNewtypeDeriving #-}
1+{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, GeneralizedNewtypeDeriving #-}
22
33------------------------------------------------------------------------------
44-- |
@@ -30,27 +30,26 @@ module Database.PostgreSQL.Simple.Types
3030 , Values(..)
3131 ) where
3232
33−import Blaze.ByteString.Builder (toByteString)
3433import Control.Arrow (first)
3534import Data.ByteString (ByteString)
3635import Data.Hashable (Hashable(hashWithSalt))
36+import Data.Foldable (toList)
3737import Data.Monoid (Monoid(..))
38+import Data.Semigroup
3839import Data.String (IsString(..))
3940import Data.Typeable (Typeable)
40−import qualified Blaze.ByteString.Builder.Char.Utf8 as Utf8
41+import Data.ByteString.Builder ( stringUtf8 )
4142import qualified Data.ByteString as B
4243import Data.Text (Text)
4344import qualified Data.Text as T
45+import Data.Tuple.Only (Only(..))
4446import Database.PostgreSQL.LibPQ (Oid(..))
47+import Database.PostgreSQL.Simple.Compat (toByteString)
4548
4649-- | A placeholder for the SQL @NULL@ value.
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)
@@ -85,30 +84,15 @@ instance Read Query where
8584 readsPrec i = fmap (first Query) . readsPrec i
8685
8786instance IsString Query where
88− fromString = Query . toByteString . Utf8.fromString
87+ fromString = Query . toByteString . stringUtf8
88+
89+instance Semigroup Query where
90+ Query a <> Query b = Query (B.append a b)
91+ {-# INLINE (<>) #-}
92+ sconcat xs = Query (B.concat $ map fromQuery $ toList xs)
8993
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+381−52
@@ -1,50 +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
18+import Database.PostgreSQL.Simple.Newtypes
19+import Database.PostgreSQL.Simple.Internal (breakOnSingleQuestionMark)
20+import Database.PostgreSQL.Simple.Types(Query(..),Values(..), PGArray(..))
821import qualified Database.PostgreSQL.Simple.Transaction as ST
22+
923import Control.Applicative
1024import Control.Exception as E
1125import Control.Monad
12−import Data.ByteString (ByteString)
26+import Data.Char
27+import Data.Foldable (toList)
28+import Data.List (concat, sort)
1329import Data.IORef
30+import Data.Monoid ((<>))
31+import Data.String (fromString)
1432import Data.Typeable
33+import GHC.Generics (Generic)
34+
35+import Data.Aeson
36+import Data.ByteString (ByteString)
1537import 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
1642import Data.Map (Map)
17−import Data.List (sort)
1843import qualified Data.Map as Map
1944import Data.Text(Text)
2045import qualified Data.Text.Encoding as T
21−import System.Exit (exitFailure)
22−import System.IO
2346import qualified Data.Vector as V
24−import Data.Aeson
47+import System.FilePath
48+import System.Timeout(timeout)
49+import Data.Time.Compat (getCurrentTime, diffUTCTime)
50+import System.Environment (getEnvironment)
2551
52+import Test.Tasty
53+import Test.Tasty.Golden
2654import Notify
2755import Serializable
2856import Time
29−
30−tests :: [TestEnv -> Test]
31−tests =
32− [ TestLabel "Bytea" . testBytea
33− , TestLabel "ExecuteMany" . testExecuteMany
34− , TestLabel "Fold" . testFold
35− , TestLabel "Notify" . testNotify
36− , TestLabel "Serializable" . testSerializable
37− , TestLabel "Time" . testTime
38− , TestLabel "Array" . testArray
39− , TestLabel "HStore" . testHStore
40− , TestLabel "JSON" . testJSON
41− , TestLabel "Savepoint" . testSavepoint
42− , TestLabel "Unicode" . testUnicode
43− , TestLabel "Values" . testValues
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
4489 ]
4590
46−testBytea :: TestEnv -> Test
47−testBytea TestEnv{..} = TestList
91+testBytea :: TestEnv -> TestTree
92+testBytea TestEnv{..} = testGroup "Bytea"
4893 [ testStr "empty" []
4994 , testStr "\"hello\"" $ map (fromIntegral . fromEnum) ("hello" :: String)
5095 , testStr "ascending" [0..255]
@@ -53,7 +98,7 @@ testBytea TestEnv{..} = TestList
5398 , testStr "descending, doubled up" $ doubleUp [255,254..0]
5499 ]
55100 where
56− testStr label bytes = TestLabel label $ TestCase $ do
101+ testStr label bytes = testCase label $ do
57102 let bs = B.pack bytes
58103
59104 [Only h] <- query conn "SELECT md5(?::bytea)" [Binary bs]
@@ -64,8 +109,8 @@ testBytea TestEnv{..} = TestList
64109
65110 doubleUp = concatMap (\x -> [x, x])
66111
67−testExecuteMany :: TestEnv -> Test
68−testExecuteMany TestEnv{..} = TestCase $ do
112+testExecuteMany :: TestEnv -> Assertion
113+testExecuteMany TestEnv{..} = do
69114 execute_ conn "CREATE TEMPORARY TABLE tmp_executeMany (i INT, t TEXT, b BYTEA)"
70115
71116 let rows :: [(Int, String, Binary ByteString)]
@@ -82,8 +127,8 @@ testExecuteMany TestEnv{..} = TestCase $ do
82127
83128 return ()
84129
85−testFold :: TestEnv -> Test
86−testFold TestEnv{..} = TestCase $ do
130+testFold :: TestEnv -> Assertion
131+testFold TestEnv{..} = do
87132 xs <- fold_ conn "SELECT generate_series(1,10000)"
88133 [] $ \xs (Only x) -> return (x:xs)
89134 reverse xs @?= ([1..10000] :: [Int])
@@ -94,7 +139,7 @@ testFold TestEnv{..} = TestCase $ do
94139 xs <- readIORef ref
95140 writeIORef ref $! (a,b):xs
96141 xs <- readIORef ref
97− reverse xs @?= [(a,b) | a <- [1..100], b <- [1..50]]
142+ reverse xs @?= [(a,b) | b <- [1..50], a <- [1..100]]
98143
99144 -- Make sure fold propagates our exception.
100145 ref <- newIORef []
@@ -152,8 +197,8 @@ queryFailure conn q resultType = do
152197 ++ show (typeOf resultType)
153198 ++ " -> " ++ show val)
154199
155−testArray :: TestEnv -> Test
156−testArray TestEnv{..} = TestCase $ do
200+testArray :: TestEnv -> Assertion
201+testArray TestEnv{..} = do
157202 xs <- query_ conn "SELECT '{1,2,3,4}'::_int4"
158203 xs @?= [Only (V.fromList [1,2,3,4 :: Int])]
159204 xs <- query_ conn "SELECT '{{1,2},{3,4}}'::_int4"
@@ -162,8 +207,17 @@ testArray TestEnv{..} = TestCase $ do
162207 queryFailure conn "SELECT '{1,2,3,4}'::_int4" (undefined :: V.Vector Bool)
163208 queryFailure conn "SELECT '{{1,2},{3,4}}'::_int4" (undefined :: V.Vector Int)
164209
165−testHStore :: TestEnv -> Test
166−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
220+ execute_ conn "CREATE EXTENSION IF NOT EXISTS hstore"
167221 roundTrip []
168222 roundTrip [("foo","bar"),("bar","baz"),("baz","hello")]
169223 roundTrip [("fo\"o","bar"),("b\\ar","baz"),("baz","\"value\\with\"escapes")]
@@ -174,12 +228,27 @@ testHStore TestEnv{..} = TestCase $ do
174228 m' <- query conn "SELECT ?::hstore" m
175229 [m] @?= m'
176230
177−testJSON :: TestEnv -> Test
178−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
179246 roundTrip (Map.fromList [] :: Map Text Text)
180247 roundTrip (Map.fromList [("foo","bar"),("bar","baz"),("baz","hello")] :: Map Text Text)
181248 roundTrip (Map.fromList [("fo\"o","bar"),("b\\ar","baz"),("baz","\"value\\with\"escapes")] :: Map Text Text)
182249 roundTrip (V.fromList [1,2,3,4,5::Int])
250+ roundTrip ("foo" :: Text)
251+ roundTrip (42 :: Int)
183252 where
184253 roundTrip :: ToJSON a => a -> Assertion
185254 roundTrip a = do
@@ -187,8 +256,92 @@ testJSON TestEnv{..} = TestCase $ do
187256 js' <- query conn "SELECT ?::json" js
188257 [js] @?= js'
189258
190−testSavepoint :: TestEnv -> Test
191−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
192345 True <- expectError ST.isNoActiveTransactionError $
193346 withSavepoint conn $ return ()
194347
@@ -248,8 +401,8 @@ testSavepoint TestEnv{..} = TestCase $ do
248401
249402 return ()
250403
251−testUnicode :: TestEnv -> Test
252−testUnicode TestEnv{..} = TestCase $ do
404+testUnicode :: TestEnv -> Assertion
405+testUnicode TestEnv{..} = do
253406 let q = Query . T.encodeUtf8 -- Handle encoding ourselves to ensure
254407 -- the table gets created correctly.
255408 let messages = map Only ["привет","мир"] :: [Only Text]
@@ -258,8 +411,8 @@ testUnicode TestEnv{..} = TestCase $ do
258411 messages' <- query_ conn "SELECT сообщение FROM ру́сский"
259412 sort messages @?= sort messages'
260413
261−testValues :: TestEnv -> Test
262−testValues TestEnv{..} = TestCase $ do
414+testValues :: TestEnv -> Assertion
415+testValues TestEnv{..} = do
263416 execute_ conn "CREATE TEMPORARY TABLE values_test (x int, y text)"
264417 test (Values ["int4","text"] [])
265418 test (Values ["int4","text"] [(1,"hello")])
@@ -275,6 +428,154 @@ testValues TestEnv{..} = TestCase $ do
275428 vals' <- query_ conn "DELETE FROM values_test RETURNING *"
276429 sort vals @?= sort vals'
277430
431+
432+testCopy :: TestEnv -> Assertion
433+testCopy TestEnv{..} = do
434+ execute_ conn "CREATE TEMPORARY TABLE copy_test (x int, y text)"
435+ copy_ conn "COPY copy_test FROM STDIN (FORMAT CSV)"
436+ mapM_ (putCopyData conn) copyRows
437+ putCopyEnd conn
438+ copy_ conn "COPY copy_test FROM STDIN (FORMAT CSV)"
439+ mapM_ (putCopyData conn) abortRows
440+ putCopyError conn "aborted"
441+ -- Hmm, does postgres always produce \n as an end-of-line here, or
442+ -- are there cases where it will use a \r\n as well?
443+ copy_ conn "COPY copy_test TO STDOUT (FORMAT CSV)"
444+ rows <- loop []
445+ sort rows @?= sort copyRows
446+ -- Now, let's just verify that the connection state is back to ready,
447+ -- so that we can issue more queries:
448+ [Only (x::Int)] <- query_ conn "SELECT 2 + 2"
449+ x @?= 4
450+ -- foldCopyData
451+ copy_ conn "COPY copy_test TO STDOUT (FORMAT CSV)"
452+ (acc, count) <- foldCopyData conn
453+ (\acc row -> return (row:acc))
454+ (\acc count -> return (acc, count))
455+ []
456+ sort acc @?= sort copyRows
457+ count @?= 2
458+ where
459+ copyRows = ["1,foo\n"
460+ ,"2,bar\n"]
461+ abortRows = ["3,baz\n"]
462+ loop rows = do
463+ mrow <- getCopyData conn
464+ case mrow of
465+ CopyOutDone _ -> return rows
466+ CopyOutRow row -> loop (row:rows)
467+
468+testCopyFailures :: TestEnv -> TestTree
469+testCopyFailures env = testGroup "Copy failures"
470+ $ map ($ env)
471+ [ testCopyUniqueConstraintError
472+ , testCopyMalformedError
473+ ]
474+
475+goldenTest :: TestName -> IO BL.ByteString -> TestTree
476+goldenTest testName =
477+ goldenVsStringDiff testName diff (resultsDir </> fileName<.>"expected")
478+ where
479+ resultsDir = "test" </> "results"
480+ fileName = map normalize testName
481+ normalize c | not (isAlpha c) = '-'
482+ | otherwise = c
483+ diff ref new = ["diff", "-u", ref, new]
484+
485+-- | Test that we provide a sensible error message on failure
486+testCopyUniqueConstraintError :: TestEnv -> TestTree
487+testCopyUniqueConstraintError TestEnv{..} =
488+ goldenTest "unique constraint violation"
489+ $ handle (\(SomeException exc) -> return $ BL.pack $ show exc) $ do
490+ execute_ conn "CREATE TEMPORARY TABLE copy_unique_constraint_error_test (x int PRIMARY KEY, y text)"
491+ copy_ conn "COPY copy_unique_constraint_error_test FROM STDIN (FORMAT CSV)"
492+ mapM_ (putCopyData conn) copyRows
493+ _n <- putCopyEnd conn
494+ return BL.empty
495+ where
496+ copyRows = ["1,foo\n"
497+ ,"2,bar\n"
498+ ,"1,baz\n"]
499+
500+testCopyMalformedError :: TestEnv -> TestTree
501+testCopyMalformedError TestEnv{..} =
502+ goldenTest "malformed input"
503+ $ handle (\(SomeException exc) -> return $ BL.pack $ show exc) $ do
504+ execute_ conn "CREATE TEMPORARY TABLE copy_malformed_input_error_test (x int PRIMARY KEY, y text)"
505+ copy_ conn "COPY copy_unique_constraint_error_test FROM STDIN (FORMAT CSV)"
506+ mapM_ (putCopyData conn) copyRows
507+ _n <- putCopyEnd conn
508+ return BL.empty
509+ where
510+ copyRows = ["1,foo\n"
511+ ,"2,bar\n"
512+ ,"z,baz\n"]
513+
514+testTimeout :: TestEnv -> Assertion
515+testTimeout TestEnv{..} =
516+ withConn $ \c -> do
517+ start_t <- getCurrentTime
518+ res <- timeout 200000 $ do
519+ withTransaction c $ do
520+ query_ c "SELECT pg_sleep(1)" :: IO [Only ()]
521+ end_t <- getCurrentTime
522+ assertBool "Timeout did not occur" (res == Nothing)
523+#if !defined(mingw32_HOST_OS)
524+-- At the moment, you cannot timely abandon queries with async exceptions on
525+-- Windows.
526+ let d = end_t `diffUTCTime` start_t
527+ assertBool "Timeout didn't work in a timely fashion" (0.1 < d && d < 0.6)
528+#endif
529+
530+testDouble :: TestEnv -> Assertion
531+testDouble TestEnv{..} = do
532+ [Only (x :: Double)] <- query_ conn "SELECT 'NaN'::float8"
533+ assertBool "expected NaN" (isNaN x)
534+ [Only (x :: Double)] <- query_ conn "SELECT 'Infinity'::float8"
535+ x @?= (1 / 0)
536+ [Only (x :: Double)] <- query_ conn "SELECT '-Infinity'::float8"
537+ x @?= (-1 / 0)
538+
539+
540+testGeneric1 :: TestEnv -> Assertion
541+testGeneric1 TestEnv{..} = do
542+ roundTrip conn (Gen1 123)
543+ where
544+ roundTrip conn x0 = do
545+ r <- query conn "SELECT ?::int" (x0 :: Gen1)
546+ r @?= [x0]
547+
548+testGeneric2 :: TestEnv -> Assertion
549+testGeneric2 TestEnv{..} = do
550+ roundTrip conn (Gen2 123 "asdf")
551+ where
552+ roundTrip conn x0 = do
553+ r <- query conn "SELECT ?::int, ?::text" x0
554+ r @?= [x0]
555+
556+testGeneric3 :: TestEnv -> Assertion
557+testGeneric3 TestEnv{..} = do
558+ roundTrip conn (Gen3 123 "asdf" True)
559+ where
560+ roundTrip conn x0 = do
561+ r <- query conn "SELECT ?::int, ?::text, ?::bool" x0
562+ r @?= [x0]
563+
564+data Gen1 = Gen1 Int
565+ deriving (Show,Eq,Generic)
566+instance FromRow Gen1
567+instance ToRow Gen1
568+
569+data Gen2 = Gen2 Int Text
570+ deriving (Show,Eq,Generic)
571+instance FromRow Gen2
572+instance ToRow Gen2
573+
574+data Gen3 = Gen3 Int Text Bool
575+ deriving (Show,Eq,Generic)
576+instance FromRow Gen3
577+instance ToRow Gen3
578+
278579data TestException
279580 = TestException
280581 deriving (Eq, Show, Typeable)
@@ -292,28 +593,56 @@ isUniqueViolation SqlError{..} = sqlState == "23505"
292593isSyntaxError :: SqlError -> Bool
293594isSyntaxError SqlError{..} = sqlState == "42601"
294595
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+ ]
295604------------------------------------------------------------------------
296605
297606-- | Action for connecting to the database that will be used for testing.
298607--
299608-- Note that some tests, such as Notify, use multiple connections, and assume
300609-- that 'testConnect' connects to the same database every time it is called.
301−testConnect :: IO Connection
302−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'"
303616
304−withTestEnv :: (TestEnv -> IO a) -> IO a
305−withTestEnv cb =
306− withConn $ \conn ->
307617 cb TestEnv
308618 { conn = conn
309619 , withConn = withConn
310620 }
311621 where
312− withConn = bracket testConnect close
622+ withConn = bracket (connectPostgreSQL connstr) close
313623
314624main :: IO ()
315−main = do
316− mapM_ (`hSetBuffering` LineBuffering) [stdout, stderr]
317− Counts{cases, tried, errors, failures} <-
318− withTestEnv $ \env -> runTestTT $ TestList $ map ($ env) tests
319− 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+63−15
@@ -17,42 +17,82 @@ correspond; for example, a conversion that consistently added hour
1717when printed to a string and subtracted an hour when parsed from string
1818would still pass these tests.
1919
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+
2033-}
2134
2235module Time (testTime) where
2336
2437import Common
2538import Control.Monad(forM_, replicateM_)
26−import Data.Time
39+import Data.Time.Compat
2740import Data.ByteString(ByteString)
2841import Database.PostgreSQL.Simple.SqlQQ
2942
3043numTests :: Int
3144numTests = 200
3245
33−testTime :: TestEnv -> Test
34−testTime env@TestEnv{..} = TestCase $ do
46+testTime :: TestEnv -> Assertion
47+testTime env@TestEnv{..} = do
3548 initializeTable env
3649 execute_ conn "SET timezone TO 'UTC'"
37− checkRoundTrips env
38− execute_ conn "SET timezone TO 'America/Chicago'"
39− checkRoundTrips env
40− execute_ conn "SET timezone TO 'Asia/Tokyo'"
41− checkRoundTrips env
42− execute_ conn "SET timezone TO 'Asia/Kathmandu'"
43− checkRoundTrips env
44− execute_ conn "SET timezone TO 'America/St_Johns'"
45− checkRoundTrips env
50+ checkRoundTrips env "1860-01-01 00:00:00+00"
51+ execute_ conn "SET timezone TO 'America/Chicago'" -- -5:00
52+ checkRoundTrips env "1883-11-18 12:00:00-06"
53+ execute_ conn "SET timezone TO 'Asia/Tokyo'" -- +9:00
54+ checkRoundTrips env "1888-01-01 00:00:00+09"
55+ execute_ conn "SET timezone TO 'Asia/Kathmandu'" -- +5:45
56+ checkRoundTrips env "1919-12-31 23:48:44+05:30"
57+ execute_ conn "SET timezone TO 'America/St_Johns'" -- -3:30
58+ checkRoundTrips env "1935-03-30 00:00:52-03:30"
4659
4760initializeTable :: TestEnv -> IO ()
4861initializeTable TestEnv{..} = withTransaction conn $ do
4962 execute_ conn
5063 [sql| CREATE TEMPORARY TABLE testtime
5164 ( x serial, y timestamptz, PRIMARY KEY(x) ) |]
65+
66+ let test :: ByteString -> IO () = \x -> do
67+ execute conn [sql|
68+ INSERT INTO testtime (y) VALUES (?)
69+ |] (Only x)
70+ return ()
71+ -- America/Chicago
72+ test "1883-11-18 11:59:59-05:50:36"
73+ test "1883-11-18 12:09:23-05:50:36"
74+ test "1883-11-18 12:00:00-06"
75+ -- Asia/Tokyo
76+ test "1887-12-31 23:59:59+09:18:59"
77+ test "1888-01-01 00:18:58+09:18:59"
78+ test "1888-01-01 00:00:00+09"
79+ -- Asia/Kathmandu
80+ test "1919-12-31 23:59:59+05:41:16"
81+ test "1919-12-31 23:48:44+05:30"
82+ test "1985-12-31 23:59:59+05:30"
83+ test "1986-01-01 00:15:00+05:45"
84+ -- America/St_Johns
85+ test "1935-03-29 23:59:59-03:30:52"
86+ test "1935-03-30 00:00:52-03:30"
87+
88+ -- While the above special cases are probably a decent start, there
89+ -- are probably more that are well worth adding to ensure better
90+ -- coverage.
91+
5292 let pop :: ByteString -> Double -> IO () = \x y ->
5393 replicateM_ numTests $ execute conn
5494 [sql| INSERT INTO testtime (y) VALUES
55− ('1936-01-01 00:00:00+00'::timestamptz
95+ ('1860-01-01 00:00:00+00'::timestamptz
5696 + ?::interval * ROUND(RANDOM() * ?)) |] (x,y)
5797 pop "1 microsecond" 6.3113904e15
5898 pop "10 microseconds" 6.3113904e14
@@ -62,10 +102,18 @@ initializeTable TestEnv{..} = withTransaction conn $ do
62102 pop "100 milliseconds" 6.3113904e10
63103 pop "1 second" 6.3113904e9
64104
65−checkRoundTrips :: TestEnv -> IO ()
66−checkRoundTrips TestEnv{..} = do
105+checkRoundTrips :: TestEnv -> ByteString -> IO ()
106+checkRoundTrips TestEnv{..} limit = do
67107 yxs :: [(UTCTime, Int)] <- query_ conn [sql| SELECT y, x FROM testtime |]
68108 forM_ yxs $ \yx -> do
69109 res <- query conn [sql| SELECT y=? FROM testtime WHERE x=? |] yx
70110 assertBool "UTCTime did not round-trip from SQL to Haskell and back" $
71111 res == [Only True]
112+
113+ yxs :: [(ZonedTime, Int)] <- query conn [sql|
114+ SELECT y, x FROM testtime WHERE y > ?
115+ |] (Only limit)
116+ forM_ yxs $ \yx -> do
117+ res <- query conn [sql| SELECT y=? FROM testtime WHERE x=? |] yx
118+ assertBool "ZonedTime did not round-trip from SQL to Haskell and back" $
119+ res == [Only True]
test/results/malformed-input.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/GenBuiltinTypes.hsdeleted−182
@@ -1,182 +0,0 @@
1−------------------------------------------------------------------------------
2−-- |
3−-- Module: GenBuiltinTypes
4−-- Copyright: (c) 2011-2012 Leon P Smith
5−-- License: BSD3
6−-- Maintainer: Leon P Smith <leon@melding-monads.com>
7−-- Stability: experimental
8−--
9−-- Queries a PostgreSQL for the Object IDs associated with built-in typenames,
10−-- and generates Haskell boilerplate to handle this mapping. The subset
11−-- of types handled this way is easily modifiable, but note that
12−-- user-defined types do not have stable oids, and can differ between
13−-- databases or dumps/reloads.
14−------------------------------------------------------------------------------
15−
16−{-# LANGUAGE OverloadedStrings, QuasiQuotes, ViewPatterns #-}
17−module GenBuiltinTypes where
18−
19−import Prelude hiding ((++))
20−
21−import StringsQQ
22−import Database.PostgreSQL.Simple
23−import qualified Data.ByteString.Char8 as B
24−import qualified Data.ByteString.Lazy as L
25−import qualified Blaze.ByteString.Builder as Blaze
26−import qualified Blaze.ByteString.Builder.ByteString as Blaze
27−import qualified Blaze.ByteString.Builder.Char8 as Blaze
28−import Data.String
29−import Data.List ( sort, intersperse )
30−import qualified Data.Map as Map
31−
32−import Data.Monoid
33−
34−(++) :: Monoid a => a -> a -> a
35−(++) = mappend
36−infixr 5 ++
37−
38−type Map = Map.Map B.ByteString Int
39−builtins :: [(B.ByteString, B.ByteString)]
40−builtins = [strings|
41−bool
42−bytea ByteA
43−char
44−name
45−int8
46−int2
47−int4
48−regproc RegProc
49−text
50−oid
51−tid
52−xid
53−cid
54−xml
55−point
56−lseg LSeg
57−path
58−box
59−polygon
60−line
61−cidr
62−float4
63−float8
64−abstime AbsTime
65−reltime RelTime
66−tinterval TInterval
67−unknown
68−circle
69−money
70−macaddr MacAddr
71−inet
72−bpchar BpChar
73−varchar VarChar
74−date
75−time
76−timestamp
77−timestamptz TimestampTZ
78−interval
79−timetz TimeTZ
80−bit
81−varbit VarBit
82−numeric
83−refcursor RefCursor
84−record
85−void
86−uuid UUID
87−json JSON
88−|]
89−
90−instance IsString Blaze.Builder where
91− fromString = Blaze.fromByteString . fromString
92−
93−main = do
94− conn <- connectPostgreSQL ""
95− xs <- query conn "SELECT typname::text, oid::int\
96− \ FROM pg_type\
97− \ WHERE typname IN ?"
98− (Only (In (sort (map fst builtins))))
99− close conn
100− let oidmap = Map.fromList xs :: Map
101− L.writeFile "../src/Database/PostgreSQL/Simple/BuiltinTypes.hs"
102− (Blaze.toLazyByteString (renderFile oidmap builtins))
103−
104−padCons str = fromString (replicate (len - B.length str) ' ')
105− where
106− len = maximum (map (B.length . snd) builtins)
107−
108−renderOid oidmap x
109− = case Map.lookup x oidmap of
110− Nothing -> error (B.unpack x)
111− Just (show -> n) -> fromString (replicate (4 - length n) ' ')
112− ++ fromString n
113−
114−renderOid' oidmap x
115− = case Map.lookup x oidmap of
116− Nothing -> error (B.unpack x)
117− Just (show -> n) -> fromString n
118− ++ fromString (replicate (4 - length n) ' ')
119−
120−bs = Blaze.fromByteString
121−
122−renderFile :: Map -> [(B.ByteString,B.ByteString)] -> Blaze.Builder
123−renderFile oidmap builtins = ([longstring|
124−{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}
125−
126−------------------------------------------------------------------------------
127−-- |
128−-- Module: Database.PostgreSQL.Simple.BuiltinTypes
129−-- Copyright: (c) 2011-2012 Leon P Smith
130−-- License: BSD3
131−-- Maintainer: Leon P Smith <leon@melding-monads.com>
132−-- Stability: experimental
133−--
134−------------------------------------------------------------------------------
135−
136−-- Note that this file is generated by tools/GenBuiltinTypes.hs, and should
137−-- not be edited directly
138−
139−module Database.PostgreSQL.Simple.BuiltinTypes
140− {-# DEPRECATED "Use TypeInfo instead" #-}
141− ( BuiltinType (..)
142− , builtin2oid
143− , oid2builtin
144− , builtin2typname
145− , oid2typname
146− ) where
147−
148−import Data.Typeable
149−import Data.ByteString (ByteString)
150−import qualified Database.PostgreSQL.LibPQ as PQ
151−
152−data BuiltinType
153− = |] ++ mconcat (intersperse "\n | " (map (Blaze.fromByteString . snd) builtins)) ++ [longstring|
154−
155− deriving (Eq, Ord, Enum, Bounded, Read, Show, Typeable)
156−
157−builtin2oid :: BuiltinType -> PQ.Oid
158−builtin2oid typ = PQ.Oid $ case typ of
159−|] ++ mconcat [mconcat [ " ", bs y, padCons y, " -> "
160− , renderOid oidmap x, "\n" ]
161− | (x,y) <- builtins ] ++ [longstring|
162−
163−oid2builtin :: PQ.Oid -> Maybe BuiltinType
164−oid2builtin (PQ.Oid x) = case x of
165−|] ++ mconcat [mconcat [ " ", renderOid' oidmap x, " -> Just ", bs y, "\n" ]
166− | (x,y) <- builtins ] ++ [longstring|
167− _ -> Nothing
168−
169−builtin2typname :: BuiltinType -> ByteString
170−builtin2typname typ = case typ of
171−|] ++ mconcat [mconcat [ " ", bs y, padCons y, " -> ", bs x, "\n"]
172− | (x,y) <- builtins] ++ [longstring|
173−
174−oid2typname :: PQ.Oid -> Maybe ByteString
175−oid2typname (PQ.Oid x) = case x of
176−|] ++ mconcat [mconcat [ " ", renderOid' oidmap x, " -> Just ", bs x, "\n" ]
177− | (x,y) <- builtins ]
178− ++ " _ -> Nothing\n"
179− ++ mconcat [mconcat [ "\n"
180− , bs x, " :: ByteString\n"
181− , bs x, " = \"", bs x, "\"\n"]
182− | (x,_y) <- builtins ])
tools/GenTypeInfo.hs+170−39
@@ -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
@@ -63,16 +64,17 @@ data TypeInfo = TypeInfo
6364 , typdelim :: Char
6465 , typname :: ByteString
6566 , typelem :: Oid
67+ , rngsubtype :: Maybe Oid
6668 }
6769
68−instance FromRow TypeInfo where
69− fromRow = TypeInfo <$> field <*> field <*> field <*> field <*> field
70+instance FromRow TypeInfo where
71+ fromRow = TypeInfo <$> field <*> field <*> field <*> field <*> field <*> field
7072
71−type NameMap = Map.Map B.ByteString TypeInfo
73+type NameMap = Map.Map B8.ByteString TypeInfo
7274
7375type OidMap = Map.Map Oid TypeInfo
7476
75−type TypeName = (B.ByteString, B.ByteString)
77+type TypeName = (B8.ByteString, B8.ByteString)
7678
7779type TypeNames = [TypeName]
7880
@@ -103,9 +105,6 @@ line
103105cidr
104106float4
105107float8
106−abstime
107−reltime
108−tinterval
109108unknown
110109circle
111110money
@@ -125,48 +124,118 @@ numeric
125124refcursor
126125record
127126void
127+_record array_record
128+regprocedure
129+regoper
130+regoperator
131+regclass
132+regtype
128133uuid
129134json
135+jsonb
136+int2vector
137+oidvector
138+_xml array_xml
139+_json array_json
140+_line array_line
141+_cidr array_cidr
142+_circle array_circle
143+_money array_money
144+_bool array_bool
145+_bytea array_bytea
146+_char array_char
147+_name array_name
148+_int2 array_int2
149+_int2vector array_int2vector
150+_int4 array_int4
151+_regproc array_regproc
152+_text array_text
153+_tid array_tid
154+_xid array_xid
155+_cid array_cid
156+_oidvector array_oidvector
157+_bpchar array_bpchar
158+_varchar array_varchar
159+_int8 array_int8
160+_point array_point
161+_lseg array_lseg
162+_path array_path
163+_box array_box
164+_float4 array_float4
165+_float8 array_float8
166+_polygon array_polygon
167+_oid array_oid
168+_macaddr array_macaddr
169+_inet array_inet
170+_timestamp array_timestamp
171+_date array_date
172+_time array_time
173+_timestamptz array_timestamptz
174+_interval array_interval
175+_numeric array_numeric
176+_timetz array_timetz
177+_bit array_bit
178+_varbit array_varbit
179+_refcursor array_refcursor
180+_regprocedure array_regprocedure
181+_regoper array_regoper
182+_regoperator array_regoperator
183+_regclass array_regclass
184+_regtype array_regtype
185+_uuid array_uuid
186+_jsonb array_jsonb
187+int4range
188+_int4range
189+numrange
190+_numrange
191+tsrange
192+_tsrange
193+tstzrange
194+_tstzrange
195+daterange
196+_daterange
197+int8range
198+_int8range
130199|]
131200
132−instance IsString Blaze.Builder where
133− fromString = Blaze.fromByteString . fromString
134−
135201connectionString = "dbname=postgres"
136202
137203withPostgreSQL = bracket (connectPostgreSQL connectionString) close
138204
139205getTypeInfos :: TypeNames -> IO (OidMap, NameMap)
140206getTypeInfos typnames = withPostgreSQL $ \conn -> do
141− infos <- query conn [sql|
142− SELECT oid, typcategory, typdelim, typname, typelem
143− FROM pg_type
144− WHERE typname IN ?
145− |]
146− (Only (In (sort (map pg typnames))))
207+ infos <- query conn [sql|
208+ WITH types AS
209+ (SELECT oid, typcategory, typdelim, typname, typelem
210+ FROM pg_type WHERE typname IN ?)
211+ SELECT types.*, rngsubtype FROM types LEFT JOIN pg_range ON oid = rngtypid
212+ |] (Only (In (sort (map pg typnames))))
147213 loop conn (oidMap infos) (nameMap infos) infos
148214 where
149215 oidMap = Map.fromList . map (typoid &&& id)
150216 nameMap = Map.fromList . map (typname &&& id)
151217 loop conn oids names infos = do
152− let unknowns = [ x | x <- map typelem infos,
218+ let unknowns = [ x | x <- map typelem infos ++
219+ [ x | Just x <- map rngsubtype infos ],
153220 x /= Oid 0,
154221 not (Map.member x oids) ]
155222 case unknowns of
156223 [] -> return (oids, names)
157224 (_:_) -> do
158225 infos' <- query conn [sql|
159− SELECT oid, typcategory, typdelim, typname, typelem
160− FROM pg_type
161− WHERE oid IN ?
162− |] (Only (In (sort unknowns)))
226+ WITH types AS
227+ (SELECT oid, typcategory, typdelim, typname, typelem
228+ FROM pg_type WHERE oid IN ?)
229+ SELECT types.*, rngsubtype
230+ FROM types LEFT JOIN pg_range ON oid = rngtypid
231+ |] (Only (In (sort unknowns)))
163232 let oids' = oids `Map.union` oidMap infos'
164233 names' = names `Map.union` nameMap infos'
165234 loop conn oids' names' infos'
166235
167236main = do
168237 (oidmap, namemap) <- getTypeInfos typeNames
169− L.writeFile "../src/Database/PostgreSQL/Simple/TypeInfo/Static.hs"
238+ L.writeFile "src/Database/PostgreSQL/Simple/TypeInfo/Static.hs"
170239 (Blaze.toLazyByteString (renderFile oidmap namemap typeNames))
171240
172241
@@ -175,7 +244,7 @@ showOid (Oid n) = show n
175244renderOid :: NameMap -> TypeName -> Blaze.Builder
176245renderOid byName name
177246 = case Map.lookup (pg name) byName of
178− Nothing -> error (B.unpack (pg name))
247+ Nothing -> error (B8.unpack (pg name))
179248 Just (showOid . typoid -> n) -> fromString n
180249 ++ fromString (replicate (4 - length n) ' ')
181250
@@ -186,13 +255,83 @@ renderElem byOid elemOid
186255 Nothing -> error ("oid not found: " ++ show elemOid)
187256 Just x -> "Just " ++ bs (typname x)
188257
258+renderTypeInfo :: OidMap -> TypeInfo -> TypeName -> Blaze.Builder
259+renderTypeInfo byOid info name
260+ | typcategory info == 'A' || typname info == "_record" =
261+ let (Just typelem_info) = Map.lookup (typelem info) byOid
262+ typelem_hs_name =
263+ case lookup (typname typelem_info) typeNames of
264+ Nothing -> error ( "type not found: "
265+ ++ B8.unpack( typname typelem_info)
266+ ++ " (typelem of " ++ B8.unpack (typname info)
267+ ++ ")")
268+ Just x -> x
269+ in concat
270+ [ "\n"
271+ , bs (hs name), " :: TypeInfo\n"
272+ , bs (hs name), " = Array {\n"
273+ , " typoid = ", bs (hs name), "Oid,\n"
274+ , " typcategory = '", bs $ B8.singleton (typcategory info), "',\n"
275+ , " typdelim = '", bs $ B8.singleton (typdelim info), "',\n"
276+ , " typname = \"", bs (typname info), "\",\n"
277+ , " typelem = ", bs typelem_hs_name, "\n"
278+ , " }\n"
279+ , "\n"
280+ , bs (hs name), "Oid :: Oid\n"
281+ , bs (hs name), "Oid = ", fromString (show (typoid info)), "\n"
282+ , "{-# INLINE ", bs (hs name), "Oid #-}"
283+ , "\n"
284+ ]
285+ | typcategory info == 'R' =
286+ let (Just rngsubtype_oid) = rngsubtype info
287+ (Just rngsubtype_info) = Map.lookup rngsubtype_oid byOid
288+ rngsubtype_hs_name =
289+ case lookup (typname rngsubtype_info) typeNames of
290+ Nothing -> error ( "type not found: "
291+ ++ B8.unpack (typname rngsubtype_info)
292+ ++ " (rngsubtype of "
293+ ++ B8.unpack (typname info) ++ ")")
294+ Just x -> x
295+ in concat
296+ [ "\n"
297+ , bs (hs name), " :: TypeInfo\n"
298+ , bs (hs name), " = Range {\n"
299+ , " typoid = ", bs (hs name), "Oid,\n"
300+ , " typcategory = '", bs $ B8.singleton (typcategory info), "',\n"
301+ , " typdelim = '", bs $ B8.singleton (typdelim info), "',\n"
302+ , " typname = \"", bs (typname info), "\",\n"
303+ , " rngsubtype = ", bs rngsubtype_hs_name, "\n"
304+ , " }\n"
305+ , "\n"
306+ , bs (hs name), "Oid :: Oid\n"
307+ , bs (hs name), "Oid = ", fromString (show (typoid info)), "\n"
308+ , "{-# INLINE ", bs (hs name), "Oid #-}"
309+ , "\n"
310+ ]
311+ | otherwise =
312+ concat
313+ [ "\n"
314+ , bs (hs name), " :: TypeInfo\n"
315+ , bs (hs name), " = Basic {\n"
316+ , " typoid = ", bs (hs name), "Oid,\n"
317+ , " typcategory = '", bs $ B8.singleton (typcategory info), "',\n"
318+ , " typdelim = '", bs $ B8.singleton (typdelim info), "',\n"
319+ , " typname = \"", bs (typname info), "\"\n"
320+ , " }\n"
321+ , "\n"
322+ , bs (hs name), "Oid :: Oid\n"
323+ , bs (hs name), "Oid = ", fromString (show (typoid info)), "\n"
324+ , "{-# INLINE ", bs (hs name), "Oid #-}"
325+ , "\n"
326+ ]
327+
189328-- FIXME: add in any names that we need that we didn't specify, (i.e.
190329-- the "unknowns" in getTypeInfos
191330-- and munge them into a valid haskell identifier if needed.
192331getNames :: NameMap -> TypeNames -> TypeNames
193332getNames _ x = x
194333
195−bs = Blaze.fromByteString
334+bs = Blaze.byteString
196335
197336pg = fst
198337
@@ -221,6 +360,7 @@ module Database.PostgreSQL.Simple.TypeInfo.Static
221360 ( TypeInfo(..)
222361 , staticTypeInfo
223362|] ++ concat [ " , " ++ bs (hs name) ++ "\n"
363+ ++ " , " ++ bs (hs name) ++ "Oid\n"
224364 | name <- names ] ++ [longstring|
225365 ) where
226366
@@ -236,15 +376,6 @@ staticTypeInfo (Oid x) = case x of
236376 ++ [longstring|
237377 _ -> Nothing
238378|]
239− ++ concat [concat
240− [ "\n"
241− , bs (hs name), " :: TypeInfo\n"
242− , bs (hs name), " = Basic {\n"
243− , " typoid = ", fromString (show typoid), ",\n"
244− , " typcategory = '", Blaze.fromChar typcategory, "',\n"
245− , " typdelim = '", Blaze.fromChar typdelim, "',\n"
246− , " typname = \"", bs typname, "\"\n"
247− , " }\n"
248− ]
379+ ++ concat [ renderTypeInfo byOid typeInfo name
249380 | name <- getNames byName names
250− , let (Just (TypeInfo{..})) = Map.lookup (pg name) byName])
381+ , let (Just typeInfo) = Map.lookup (pg name) byName])