git.iko.soy/typeable/postgresql-simple
on e178c6f help sign in
3ac2949
swap
0 ahead, 524 behind
65 files changed+1922−8149
since splitsnapshots
unifiedsplit
.github/workflows/haskell-ci.yml−256 .github/workflows/simple.yml−58 .gitignore+1−8 CHANGES+139 CHANGES.md−746 CONTRIBUTING.md−13 CONTRIBUTORS−26 README.md−4 bench/Select.hs−32 cabal.haskell-ci−5 cabal.project−4 cabal.project.local.win−4 postgresql-simple.cabal+80−153 sdist.sh−25 src/Database/PostgreSQL/Simple.hs+173−244 src/Database/PostgreSQL/Simple/Arrays.hs+5−3 src/Database/PostgreSQL/Simple/BuiltinTypes.hs+411 src/Database/PostgreSQL/Simple/Compat.hs+21−17 src/Database/PostgreSQL/Simple/Copy.hs−269 src/Database/PostgreSQL/Simple/Cursor.hs−98 src/Database/PostgreSQL/Simple/Errors.hs+20−50 src/Database/PostgreSQL/Simple/FromField.hs+152−437 src/Database/PostgreSQL/Simple/FromField.hs-boot−1 src/Database/PostgreSQL/Simple/FromRow.hs+22−333 src/Database/PostgreSQL/Simple/FromRow.hs-boot+1−11 src/Database/PostgreSQL/Simple/HStore.hs−36 src/Database/PostgreSQL/Simple/HStore/Implementation.hs−210 src/Database/PostgreSQL/Simple/HStore/Internal.hs−19 src/Database/PostgreSQL/Simple/Internal.hs+41−343 src/Database/PostgreSQL/Simple/Internal/PQResultUtils.hs−123 src/Database/PostgreSQL/Simple/LargeObjects.hs+3−6 src/Database/PostgreSQL/Simple/Newtypes.hs−49 src/Database/PostgreSQL/Simple/Notification.hs+29−90 src/Database/PostgreSQL/Simple/Ok.hs+4−10 src/Database/PostgreSQL/Simple/Range.hs−317 src/Database/PostgreSQL/Simple/SqlQQ.hs+22−36 src/Database/PostgreSQL/Simple/Time.hs+50−216 src/Database/PostgreSQL/Simple/Time/Implementation.hs+157−51 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+44−198 src/Database/PostgreSQL/Simple/ToField.hs-boot−23 src/Database/PostgreSQL/Simple/ToRow.hs+3−129 src/Database/PostgreSQL/Simple/ToRow.hs-boot+2−12 src/Database/PostgreSQL/Simple/Transaction.hs+28−103 src/Database/PostgreSQL/Simple/TypeInfo.hs+29−94 src/Database/PostgreSQL/Simple/TypeInfo/Macro.hs−53 src/Database/PostgreSQL/Simple/TypeInfo/Static.hs+170−1434 src/Database/PostgreSQL/Simple/TypeInfo/Types.hs−56 src/Database/PostgreSQL/Simple/Types.hs+34−160 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+28−574 test/Notify.hs+2−1 test/Serializable.hs+2−2 test/Time.hs+15−63 test/results/malformed-input.expected−4 test/results/unique-constraint-violation.expected−5 tools/GenBuiltinTypes.hs+180 tools/GenTypeInfo.hs+52−177
.github/workflows/haskell-ci.ymldeleted−256
@@ -1,256 +0,0 @@
1−# This GitHub workflow config has been generated by a script via
2−#
3−# haskell-ci 'github' 'cabal.project'
4−#
5−# To regenerate the script (for example after adjusting tested-with) run
6−#
7−# haskell-ci regenerate
8−#
9−# For more information, see https://github.com/haskell-CI/haskell-ci
10−#
11−# version: 0.17.20231110
12−#
13−# REGENDATA ("0.17.20231110",["github","cabal.project"])
14−#
15−name: Haskell-CI
16−on:
17− push:
18− branches:
19− - master
20− pull_request:
21− branches:
22− - master
23−jobs:
24− linux:
25− name: Haskell-CI - Linux - ${{ matrix.compiler }}
26− runs-on: ubuntu-20.04
27− timeout-minutes:
28− 60
29− container:
30− image: buildpack-deps:bionic
31− services:
32− postgres:
33− image: postgres:14
34− env:
35− POSTGRES_PASSWORD: postgres
36− options: --health-cmd pg_isready --health-interval 10s --health-timeout 5s --health-retries 5
37− continue-on-error: ${{ matrix.allow-failure }}
38− strategy:
39− matrix:
40− include:
41− - compiler: ghc-9.8.1
42− compilerKind: ghc
43− compilerVersion: 9.8.1
44− setup-method: ghcup
45− allow-failure: false
46− - compiler: ghc-9.6.3
47− compilerKind: ghc
48− compilerVersion: 9.6.3
49− setup-method: ghcup
50− allow-failure: false
51− - compiler: ghc-9.4.8
52− compilerKind: ghc
53− compilerVersion: 9.4.8
54− setup-method: ghcup
55− allow-failure: false
56− - compiler: ghc-9.2.8
57− compilerKind: ghc
58− compilerVersion: 9.2.8
59− setup-method: ghcup
60− allow-failure: false
61− - compiler: ghc-9.0.2
62− compilerKind: ghc
63− compilerVersion: 9.0.2
64− setup-method: ghcup
65− allow-failure: false
66− - compiler: ghc-8.10.7
67− compilerKind: ghc
68− compilerVersion: 8.10.7
69− setup-method: ghcup
70− allow-failure: false
71− - compiler: ghc-8.8.4
72− compilerKind: ghc
73− compilerVersion: 8.8.4
74− setup-method: hvr-ppa
75− allow-failure: false
76− - compiler: ghc-8.6.5
77− compilerKind: ghc
78− compilerVersion: 8.6.5
79− setup-method: hvr-ppa
80− allow-failure: false
81− fail-fast: false
82− steps:
83− - name: apt
84− run: |
85− apt-get update
86− apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5
87− if [ "${{ matrix.setup-method }}" = ghcup ]; then
88− mkdir -p "$HOME/.ghcup/bin"
89− curl -sL https://downloads.haskell.org/ghcup/0.1.20.0/x86_64-linux-ghcup-0.1.20.0 > "$HOME/.ghcup/bin/ghcup"
90− chmod a+x "$HOME/.ghcup/bin/ghcup"
91− "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false)
92− "$HOME/.ghcup/bin/ghcup" install cabal 3.10.2.0 || (cat "$HOME"/.ghcup/logs/*.* && false)
93− else
94− apt-add-repository -y 'ppa:hvr/ghc'
95− apt-get update
96− apt-get install -y "$HCNAME"
97− mkdir -p "$HOME/.ghcup/bin"
98− curl -sL https://downloads.haskell.org/ghcup/0.1.20.0/x86_64-linux-ghcup-0.1.20.0 > "$HOME/.ghcup/bin/ghcup"
99− chmod a+x "$HOME/.ghcup/bin/ghcup"
100− "$HOME/.ghcup/bin/ghcup" install cabal 3.10.2.0 || (cat "$HOME"/.ghcup/logs/*.* && false)
101− fi
102− env:
103− HCKIND: ${{ matrix.compilerKind }}
104− HCNAME: ${{ matrix.compiler }}
105− HCVER: ${{ matrix.compilerVersion }}
106− - name: Set PATH and environment variables
107− run: |
108− echo "$HOME/.cabal/bin" >> $GITHUB_PATH
109− echo "LANG=C.UTF-8" >> "$GITHUB_ENV"
110− echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV"
111− echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV"
112− HCDIR=/opt/$HCKIND/$HCVER
113− if [ "${{ matrix.setup-method }}" = ghcup ]; then
114− HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER")
115− HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#')
116− HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#')
117− echo "HC=$HC" >> "$GITHUB_ENV"
118− echo "HCPKG=$HCPKG" >> "$GITHUB_ENV"
119− echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV"
120− echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.2.0 -vnormal+nowrap" >> "$GITHUB_ENV"
121− else
122− HC=$HCDIR/bin/$HCKIND
123− echo "HC=$HC" >> "$GITHUB_ENV"
124− echo "HCPKG=$HCDIR/bin/$HCKIND-pkg" >> "$GITHUB_ENV"
125− echo "HADDOCK=$HCDIR/bin/haddock" >> "$GITHUB_ENV"
126− echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.2.0 -vnormal+nowrap" >> "$GITHUB_ENV"
127− fi
128−
129− HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')
130− echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV"
131− echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV"
132− echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV"
133− echo "HEADHACKAGE=false" >> "$GITHUB_ENV"
134− echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV"
135− echo "GHCJSARITH=0" >> "$GITHUB_ENV"
136− env:
137− HCKIND: ${{ matrix.compilerKind }}
138− HCNAME: ${{ matrix.compiler }}
139− HCVER: ${{ matrix.compilerVersion }}
140− - name: env
141− run: |
142− env
143− - name: write cabal config
144− run: |
145− mkdir -p $CABAL_DIR
146− cat >> $CABAL_CONFIG <<EOF
147− remote-build-reporting: anonymous
148− write-ghc-environment-files: never
149− remote-repo-cache: $CABAL_DIR/packages
150− logs-dir: $CABAL_DIR/logs
151− world-file: $CABAL_DIR/world
152− extra-prog-path: $CABAL_DIR/bin
153− symlink-bindir: $CABAL_DIR/bin
154− installdir: $CABAL_DIR/bin
155− build-summary: $CABAL_DIR/logs/build.log
156− store-dir: $CABAL_DIR/store
157− install-dirs user
158− prefix: $CABAL_DIR
159− repository hackage.haskell.org
160− url: http://hackage.haskell.org/
161− EOF
162− cat >> $CABAL_CONFIG <<EOF
163− program-default-options
164− ghc-options: $GHCJOBS +RTS -M3G -RTS
165− EOF
166− cat $CABAL_CONFIG
167− - name: versions
168− run: |
169− $HC --version || true
170− $HC --print-project-git-commit-id || true
171− $CABAL --version || true
172− - name: update cabal index
173− run: |
174− $CABAL v2-update -v
175− - name: install cabal-plan
176− run: |
177− mkdir -p $HOME/.cabal/bin
178− curl -sL https://github.com/haskell-hvr/cabal-plan/releases/download/v0.7.3.0/cabal-plan-0.7.3.0-x86_64-linux.xz > cabal-plan.xz
179− echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c -
180− xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan
181− rm -f cabal-plan.xz
182− chmod a+x $HOME/.cabal/bin/cabal-plan
183− cabal-plan --version
184− - name: checkout
185− uses: actions/checkout@v3
186− with:
187− path: source
188− - name: initial cabal.project for sdist
189− run: |
190− touch cabal.project
191− echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project
192− cat cabal.project
193− - name: sdist
194− run: |
195− mkdir -p sdist
196− $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist
197− - name: unpack
198− run: |
199− mkdir -p unpacked
200− find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \;
201− - name: generate cabal.project
202− run: |
203− PKGDIR_postgresql_simple="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/postgresql-simple-[0-9.]*')"
204− echo "PKGDIR_postgresql_simple=${PKGDIR_postgresql_simple}" >> "$GITHUB_ENV"
205− rm -f cabal.project cabal.project.local
206− touch cabal.project
207− touch cabal.project.local
208− echo "packages: ${PKGDIR_postgresql_simple}" >> cabal.project
209− echo "package postgresql-simple" >> cabal.project
210− echo " ghc-options: -Werror=missing-methods" >> cabal.project
211− cat >> cabal.project <<EOF
212− allow-newer: cryptohash-md5-0.11.100.1:base
213− EOF
214− $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: $_ installed\n" unless /^(postgresql-simple)$/; }' >> cabal.project.local
215− cat cabal.project
216− cat cabal.project.local
217− - name: dump install plan
218− run: |
219− $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all
220− cabal-plan
221− - name: restore cache
222− uses: actions/cache/restore@v3
223− with:
224− key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }}
225− path: ~/.cabal/store
226− restore-keys: ${{ runner.os }}-${{ matrix.compiler }}-
227− - name: install dependencies
228− run: |
229− $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all
230− $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all
231− - name: build w/o tests
232− run: |
233− $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all
234− - name: build
235− run: |
236− $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always
237− - name: tests
238− run: |
239− $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct
240− - name: cabal check
241− run: |
242− cd ${PKGDIR_postgresql_simple} || false
243− ${CABAL} -vnormal check
244− - name: haddock
245− run: |
246− $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all
247− - name: unconstrained build
248− run: |
249− rm -f cabal.project.local
250− $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all
251− - name: save cache
252− uses: actions/cache/save@v3
253− if: always()
254− with:
255− key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }}
256− path: ~/.cabal/store
.github/workflows/simple.ymldeleted−58
@@ -1,58 +0,0 @@
1−name: Simple
2−on:
3− push:
4− branches:
5− - master
6− pull_request:
7− branches:
8− - master
9−
10−jobs:
11− native:
12− name: "Simple: GHC ${{ matrix.ghc }} on ${{ matrix.os }}"
13− runs-on: ${{ matrix.os }}
14− strategy:
15− matrix:
16− os: [macos-latest, windows-latest]
17− ghc: ['8.10','9.0','9.2','9.4.8','9.6.3','9.8.1']
18− fail-fast: false
19− timeout-minutes:
20− 60
21− steps:
22− - name: Set git to use LF
23− run: |
24− git config --global core.autocrlf false
25− git config --global core.eol lf
26−
27− - name: Set up Haskell
28− id: setup-haskell
29− uses: haskell/actions/setup@v2
30− with:
31− ghc-version: ${{ matrix.ghc }}
32− cabal-version: '3.10.2.0'
33−
34− - name: Set up PostgreSQL
35− uses: ikalnytskyi/action-setup-postgres@v3
36− id: postgres
37− with:
38− username: ci
39− password: sw0rdfish
40− database: test
41−
42− - name: Checkout
43− uses: actions/checkout@v3.0.2
44−
45− - name: Cache
46− uses: actions/cache@v2.1.3
47− with:
48− path: ${{ steps.setup-haskell.outputs.cabal-store }}
49− key: ${{ runner.os }}-${{ matrix.ghc }}-${{ github.sha }}
50− restore-keys: ${{ runner.os }}-${{ matrix.ghc }}-
51−
52− - name: Build
53− run: cabal build all --enable-tests
54−
55− - name: Test
56− run: cabal test all --enable-tests --test-show-details=direct
57− env:
58− DATABASE_CONNSTRING: ${{ steps.postgres.outputs.connection-uri }}
.gitignore+1−8
@@ -7,11 +7,4 @@ dist/
77*.o
88\#*\#
99.#*
10−/CHANGELOG.md
11−.cabal-sandbox/
12−.stack-work/
13−cabal.sandbox.config
14−/dist-newstyle
15−.ghc.environment.*
16−cabal.project.local
17−dump-core
10+postgresql-simple-*.tar.gz
CHANGESnew file+139
@@ -0,0 +1,139 @@
1+Version 0.2.4.1 (2012-08-29)
2+ * Fixed the documentation of `In`. Thanks to rekado and dstcruz for
3+ pointing this out.
4+
5+Version 0.2.4.0 (2012-08-23)
6+ * Added the `withTransactionSerializable` and `withTransactionModeRetry`
7+ operators, thanks to Joey Adams.
8+
9+Version 0.2.3.0 (2012-08-09)
10+ * Added the `returning` operator, thanks to Jason Dusek
11+
12+Version 0.2.2.0 (2012-07-26)
13+ * Added a ToRow instance for the (:.) type, courtesy of Leonid Onokhov
14+
15+ * Added the type oid for PostgreSQL's `uuid` type to BuiltinTypes
16+
17+Version 0.2.1.0 (2012-07-23)
18+ * Added the FromRow.fieldWith operator, thanks to Leonid Onokhov
19+
20+ * Added a type synonym for FieldParser
21+
22+Version 0.2.0.1 (2012-06-21)
23+ * Fixed a compatibility problem with PostgreSQL 8.1, which does not allow
24+ clients to set their own value for `standard_conforming_strings`. This
25+ connection variable is still set to `on` for PostgreSQL 8.2 and later.
26+
27+Version 0.2: (2012-06-19)
28+ * Removed the conversion from `timestamp` to `UTCTime`. Some code will be
29+ broken even though it will still compile.
30+
31+ * Renamed a number of data constructors, mostly in the BuiltinTypes module.
32+
33+ * Exported ToRow/FromRow from Database.PostgreSQL.Simple
34+
35+
36+Version 0.1.4.3: (2012-06-10)
37+ * Fix language extensions for compatibility with GHC 7.0
38+
39+Version 0.1.4.2: (2012-06-10)
40+ * Fix a wayward dependency on Text.
41+
42+Version 0.1.4.1: (2012-06-10)
43+ * Added support for timezones with minutes in their UTC offset.
44+
45+Version 0.1.4: (2012-06-10)
46+ * Removed pcre-light dependency, courtesy of Joey Adams.
47+
48+ * Reworked support for the Time types.
49+
50+ * The conversion from PostgreSQL's `timestamp` (without time zone) type
51+ to Haskell's `UTCTime` type is deprecated and will be removed in 0.2.
52+
53+ * `Data.Time.LocalTime` now has `FromField`/`ToField` instances. It is
54+ now the preferred way of dealing with `timestamp` (without time zone).
55+
56+ * `Database.PostgreSQL.Simple.Time` is a new module that offers types
57+ that accomodate PostgreSQL's infinities.
58+
59+ * All time-related `FromField`/`ToField` instances are now based on new,
60+ higher-speed parsers and printers instead of those provided by the
61+ time package included in GHC.
62+
63+ * Planned breaking changes for 0.2:
64+
65+ * Removing the conversion from `timestamp` to `UTCTime`.
66+
67+ * Renaming some of the type names in `BuiltinTypes`.
68+
69+
70+Version 0.1.3: (2012-05-30)
71+ * Made ZonedTime an instance of FromField and ToField
72+
73+ * Added getNotificationNonBlocking
74+
75+
76+Version 0.1.2: (2012-05-09)
77+ * Switched to libpq-based escaping for bytea types; Binary now works with
78+ PostgreSQL 8 courtesy of Joey Adams.
79+
80+ * postgresql-simple now sets standard_conforming_strings to "on". This
81+ per-connection variable is initialized according to the server
82+ configuration, which defaults to "off" for PostgreSQL < 9, and "on"
83+ for PostgreSQL >= 9. You may need to adjust any string literals in
84+ your SQL queries, or set the variable yourself.
85+
86+ * Exported (:.) from Database.PostgreSQL.Simple
87+
88+
89+Version 0.1.1: (2012-05-06)
90+ * Added some preliminary documentation for the Ok, Notification, and
91+ LargeObjects modules
92+
93+ * Implemented the `fail` method for the monad instance for `Ok`.
94+
95+ * Fixed a bug relating to handling the transaction level
96+
97+
98+Version 0.1: (2012-05-04)
99+ * Renamed several modules, typeclasses, and functions:
100+
101+ QueryParams (renderParams) -> ToRow (toRow)
102+ QueryResults (convertResults) -> FromRow (fromRow)
103+ Param (render) -> ToField (toField)
104+ Result (convert) -> FromField (fromField)
105+
106+ * Added the `Database.PostgreSQL.Simple.Ok` module, a variation of
107+ `Either SomeException` that has an instance for `Alternative` and also
108+ uses a list of exceptions to track the ways it has failed.
109+
110+ * Changed the return type of `fromField` and `fromRow` from
111+ `Either SomeException` to `Ok`.
112+
113+ * Thanks to suggestions from Ozgun Ataman, the `FromRow` typeclass has been
114+ massively improved. The result is simpler definitions and better
115+ compositionality. Also, user-defined instances need not be to be
116+ concerned about forcing the converted results to WHNF. Here is an
117+ example comparing the old to the new:
118+
119+ instance (Result a, Result b) => QueryResults (a,b) where
120+ convertResults [fa,fb] [va,vb] = do
121+ !a <- convert fa va
122+ !b <- convert fb vb
123+ return (a,b)
124+ convertResults fs vs = convertError fs vs 2
125+
126+ instance (FromField a, FromField b) => FromRow (a,b) where
127+ fromRow = (,) <$> field <*> field
128+
129+ * Added `(:.)`, a pair that allows one to compose `FromRow` instances:
130+
131+ instance (FromRow a, FromRow b) => FromRow (a :. b) where
132+ fromRow = (:.) <$> fromRow <*> fromRow
133+
134+ * Moved the contents `Field` module into the `FromField` module.
135+
136+ * Removed the `RawResult` type.
137+
138+ * Added `DefaultIsolationLevel` as a distinct `IsolationLevel` option
139+ and `DefaultReadWriteMode` as a distinct `ReadWriteMode`.
CHANGES.mddeleted−746
@@ -1,746 +0,0 @@
1−### Version 0.7.0.0 (2023-07-31)
2−
3− * Remove Eq Null instance. (Future `base` may break it, we remove it profilacticly).
4− * Use `postgresql-libpq >=0.10.0.0`. It includes critical fixes,
5− by using `postgresql-simple >=0.7` you won't get older `postgresql-libpq`.
6− * Drop support for GHC prior 8.6
7− * Added a class for `postgresql-simple` exceptions: `SomePostgreSqlException`.
8− This allows to catch all `postgresql-simple` exceptions at once.
9− (c.f. `AsyncException` in `base).
10−
11−### Version 0.6.5.1 (2023-07-09)
12−
13− * Support `aeson-2.2.0.0`
14−
15−### Version 0.6.5 (2022-10-30)
16−
17− * Add `withConnect`
18−
19−### Version 0.6.4 (2021-01-06)
20−
21− * Add foldCopyData helper function
22− Thanks to Sebastián Estrella for the implementation
23− https://github.com/haskellari/postgresql-simple/pull/56
24− * Implement support for postgresql 'interval' type
25− Thanks to Andre Marques Lee for the implementation
26− https://github.com/haskellari/postgresql-simple/pull/60
27− * Depend on `time-compat` to provide uniform `time` related interface.
28−
29−### Version 0.6.3 (2020-11-15)
30−
31− * Add `fromFieldJSONByteString`
32− Thanks to tomjaguarpaw for the implementation
33− https://github.com/haskellari/postgresql-simple/pull/47
34− * Add `attoFieldParser`
35− Thanks to Victor Nawothnig for the implementation
36− https://github.com/haskellari/postgresql-simple/pull/45
37− * Add `Identity` and `Const` instance
38− Thanks to Cary Robbins for the implementation
39− https://github.com/haskellari/postgresql-simple/pull/46
40− * Add `withTransactionModeRetry'`, a variant of `withTransactionModeRetry`
41− for all exception types.
42− Thanks to Elliot Cameron for the implementation
43− https://github.com/haskellari/postgresql-simple/pull/42
44− * Fix spurious aborts when retrying transactions
45− Thanks to Elliot Cameron for the implementation
46− https://github.com/haskellari/postgresql-simple/pull/34
47− * Add `Database.PostgreSQL.Simple.Newtypes` module
48− with `Aeson` newtype.
49− https://github.com/haskellari/postgresql-simple/pull/55
50−
51−### Version 0.6.2 (2019-04-26)
52−
53− * Define `MonadFail Ok`.
54−
55−### Version 0.6.1 (2019-03-04)
56−
57− * Escape double '??' to a literal '?
58− Thanks to Felix Paulusma for the implementation.
59− https://github.com/phadej/postgresql-simple/pull/5
60−
61− * Mention GHC Generics support in the documentation.
62− Thanks to Gabriel Gonzalez for the implementation.
63− https://github.com/phadej/postgresql-simple/pull/6
64−
65− * Better error message for "Query resulted in a command response
66− Thanks to Max Amanshauser for the implementation.
67− https://github.com/phadej/postgresql-simple/pull/7
68−
69− * fromJSONField: Include JSONPath on JSON parse errors
70− Thanks to Simon Hengel for the implementation.
71− https://github.com/phadej/postgresql-simple/pull/2
72−
73− * No TH in implementation
74− https://github.com/phadej/postgresql-simple/pull/4
75−
76−### Version 0.6 (2018-10-16)
77−
78− * *Breaking change*: Use `Only` package's `Only` for a common 1-tuple.
79−
80− Consider a downstream library depending already both on
81− `Only` and `postgresql-simple` package. This library my define
82− a `MyClass` with instances for `Only.Only` and `PostgreSQL.Only`.
83− As now these types are the same, a library would break.
84− Therefore I consider "merging" types a breaking change.
85−
86− There are two ways for adopting this change in that scenario:
87−
88− - Either CPP-guard `PostgreSQL.Only` instance with
89−
90− ```haskell
91− #if !MIN_VERSION_postgresql_simple(0,6,0)
92− instance MyClass (PostgreSQL.Only a) where ...
93− #endif
94− ```
95−
96− - or simply remove it and add `postgresql-simple >=0.6` lower bound,
97− making sure that there's only single `Only`.
98−
99− * Add `ToField` instances for case-insensitive strict and lazy text.
100− Thanks to Max Tagher for the implementation.
101− https://github.com/lpsmith/postgresql-simple/pull/232
102−
103− * Add support to CockroachDB.
104− Thanks to Georte Steel.
105− https://github.com/lpsmith/postgresql-simple/pull/245
106−
107− * Add Generic ConnectInfo instance
108− Thanks to Dmitry Dzhus.
109− https://github.com/lpsmith/postgresql-simple/pull/235
110−
111− * Add `fromFieldRange :: Typeable a => FieldParser a -> FieldParser (PGRange a)`
112− https://github.com/lpsmith/postgresql-simple/pull/221
113−
114− * Add `fromFieldJSONByteString :: FieldParser ByteString`
115− https://github.com/lpsmith/postgresql-simple/pull/222/files
116−
117− * Fix off-by-one error in year builder.
118− Thanks to Nathan Ferris Hunter.
119− https://github.com/lpsmith/postgresql-simple/pull/230
120−
121− * Extend ToRow and FromRow to tuples of size 18
122− Thanks to Bardur Arantsson.
123− https://github.com/lpsmith/postgresql-simple/pull/229
124−
125− * Add `Vector` and `Vector.Unboxed` `query` variants.
126− These are more memory efficient
127− (especially, if you anyway will convert to some vector)
128− https://github.com/phadej/1
129−
130− * Documentation improvements
131− https://github.com/lpsmith/postgresql-simple/pull/227
132− https://github.com/lpsmith/postgresql-simple/pull/236
133−
134−### Version 0.5.4.0 (2018-05-23)
135− * Support GHC-8.4 (Semigroup/Monoid)
136−
137−### Version 0.5.3.0 (2017-05-15)
138− * Refactored some rudimentary cursor handling code out of the
139− implementation of the fold operators, into a new
140− `Database.PostgreSQL.Simple.Cursor` module, thanks to Bardur Arantsson.
141−
142− * Made the `FromField` instance for `Char` compatible with
143− postgresql's `bpchar` type. Thanks to Ivan Lazar Miljenovic for
144− reporting the issue.
145−
146− * Added `Show` and `Eq` instances for `Notification`, thanks to
147− Matvey Aksenov.
148−
149− * Fixed some example code, thanks to Matvey Aksenov.
150−
151− * Fixed a problem with using `conversionError` to throw exceptions
152− of type `SomeException`. Previously, the exception would be
153− wrapped in a second `SomeException` dynamic constructor which
154− would cause normal GHC typecase idioms over `SomeException` to fail.
155−
156−### Version 0.5.2.1 (2016-06-29)
157− * Bumped the lower bound for `base` to 4.6. Thanks to Herbert
158− Valerio Riedel for reporting the issue.
159−
160− * Added an `Eq` instance for `SqlError`, thanks to Chris Allen
161−
162− * Fixed a bug where a all-caps `"NULL"` text value inside a
163− postgresql array would get parsed as the SQL null value. Thanks
164− goes to Edgar Gomes and Silk for finding and fixing this mistake.
165−
166− * Modified `withTransaction` and friends to ignore `IOError`s when
167− attempting to roll back the transaction. This fixes a buggy
168− interaction between `withTransaction` and async exceptions (e.g.
169− `System.Timeout`) on unix platforms. Thanks goes to Erik
170− Hesselink and Silk for providing the test case that exposed this
171− issue.
172−
173− * Added the `testTimeout` regression test for the problem above.
174−
175−### Version 0.5.2.0 (2016-05-25)
176− * Significantly improved the error reporting from
177− `Copy.putCopyData`, thanks to Ben Gamari.
178−
179− * Moved the test suite to use `tasty`, with a big thanks
180− to Ben Gamari.
181−
182− * Added `FromField.optionalField`, and updated the documentation
183− of `FromField.fromJSONField`, as inspired by an email conversation
184− with Ian Wagner.
185−
186− * Updated all links in the haddocks to use https, and added a link
187− to the documentation of `connectPostgreSQL`.
188−
189− * Added a truncated changelog to the source distribution.
190−
191−### Version 0.5.1.3 (2016-04-30)
192− * Implemented the Monad of No Return proposal, future-proofing
193− postgresql-simple against future releases of GHC.
194−
195− * Fixed a rare and usually benign race condition where
196− `getNotification` could end up waiting on a newly reallocated
197− file descriptor index, potentially leading to deadlock if the
198− descriptor does not become readable promptly. This fix only
199− applies to GHC 7.8 or later, as it depends on `threadWaitReadSTM`.
200−
201− * Tweaked the time parsers to accept times of day of the form `hh:mm`,
202− omitting seconds, following changes made to aeson.
203−
204− * Updated the documentation of the `In` type to point out a gotcha
205− when using the SQL fragment `... NOT IN ?` with `In []`. Thanks
206− goes to Simon Michael and Dan Haraj for bringing this issue to
207− my attention.
208−
209−### Version 0.5.1.2 (2015-12-14)
210− * The syntax generated for empty arrays was changed so that
211− postgresql's type inference would work better, thanks to
212− Amit Levy.
213−
214− * Further revision and expansion of the new Time documentation.
215−
216−### Version 0.5.1.1 (2015-12-02)
217− * This is a documentation-only release
218−
219− * The documentation of the `Time` module has been completely
220− rewritten, and is far longer and more informative. It contains
221− a brief overview of civil time, the semantics of postgresql's
222− time types, and their relation to Haskell's time types via
223− postgresql-simple.
224−
225− * The documentation of `connectPostgreSQL` has been modified to
226− mention the effects of environment variables on the connection
227− string parameters.
228−
229− * The documentation of `HStore.Internal` has been unhidden from
230− haddock.
231−
232− * A typo in example code was fixed courtesy of Levi Notik.
233−
234−### Version 0.5.1.0 (2015-10-22)
235− * Optimized the implementation of the streaming operators to avoid
236− creating intermediate lists of rows, thanks to Timo von Holtz.
237−
238− * Added default instances for `ToRow` and `FromRow` that depend on
239− Generics, thanks to Alexey Khudyakov.
240−
241− * Fixed support for bytestring-0.9 and GHC 7.4.
242−
243−### Version 0.5.0.1 (2015-09-21)
244− * Fixed a bug when printing a `ZonedTime` with a negative offset
245− that is not a whole number of hours.
246−
247−### Version 0.5.0.0 (2015-09-19)
248− * Removed the deprecated `BuiltinTypes` module.
249−
250− * Modified the SQL quasiquoter so that it returns a `Query`, not
251− an overloaded string, and so that the `OverloadedStrings` language
252− extension is no longer necessary, thanks to Mike Ledger.
253−
254− * Moved away from `blaze-builder` in favor of `bytestring-builder`. This
255− shouldn't affect very many people, but does reduce the transitive
256− dependencies.
257−
258− * Rewrote the timestamp printers to use the new `Prim`
259− infrastructure in `bytestring-builder`. The new printers should
260− be a fair bit faster.
261−
262− * Added support for exclusion violations to the `ConstraintViolation`
263− type in the Errors module, thanks to João Cristóvão.
264−
265− * Moved away from the `uuid` package in favor of the `uuid-types` package,
266− thanks to Bardur Arantsson. This shouldn't affect anybody, but does
267− reduce the transitive dependencies.
268−
269− * Postgresql-simple now explicitly assumes the UTF8 character encoding
270− for communication between the client and server. All database encodings
271− support UTF8 except for Mule Internal Code, the Multilingual
272− Extensions for Emacs. An exception should be raised upon
273− connecting to a database by the backend if the backend cannot
274− accommodate this requirement.
275−
276− * Added `Eq` and `Typeable` instances for `Connection`.
277−
278− * Added the `foldWith`, `forEachWith`, and `returningWith` families
279− of functions courtesy of Travis Staton.
280−
281− * Support for Ranged types, with thanks to Leonid Onokhov for his
282− contributions.
283−
284− * The `FromField` instance for JSON now allows for top-level values that
285− are not objects or arrays, thanks to Sam Rijs.
286−
287− * The timestamp parsers have been replaced with those now in Aeson.
288− Janne Hellsten adapted the old parsers from postgresql-simple for
289− inclusion in Aeson; Bryan O'Sullivan rewrote those parsers to be
290− faster, with some tweaks contributed by myself. And now to
291− bring the effort full circle, the result has been brought back to
292− postgresql-simple, with some adaptations.
293−
294− * Fixed a bug in the typeinfo system where postgresql's `_record` type
295− was being reported as a basic type and not an array type. Thanks to
296− Nickolay Kolev for helping to expose this issue.
297−
298− * Fixed a bug with the `typeInfo` operator, thanks to Timmy Tofu. In the
299− case of parsing subfields of arrays and composites, it would fetch the
300− `TypeInfo` of the array or composite type and not the subtype.
301−
302−### Version 0.4.10.0 (2015-02-26)
303− * Added a blurb about SSL/TLS in the documentation for connectPostgreSQL
304−
305− * Moved some functions into the Internal module, courtesy of Aleksey
306− Uimanov.
307−
308−### Version 0.4.9.0 (2014-12-27)
309− * Made the fromField method for PGArray available as pgArrayFieldParser,
310− outside of the typeclass courtesy of Tom Ellis.
311−
312− * Fixed a missing OverloadedStrings pragma in the documentation of SqlQQ.
313−
314− * Fixed deprecation warnings, courtesy of Simon Hengel.
315−
316−### Version 0.4.8.0 (2014-11-24)
317− * Added support for postgresql's citext type extension via the
318− case-insensitive package.
319−
320− * Added the function parseHStoreList to the HStore module.
321−
322−### Version 0.4.7.0 (2014-10-27)
323− * Added support for very old timestamps to UTCTime. Depending on time
324− zone, very old timestamps can be returned with a offset from UTC that
325− contains seconds.
326−
327− All timezones in the TZ database moved to a time standard offset an
328− integer number of minutes from UTC before 1973, almost all locations
329− moved before 1938, and a solid majority moved before 1921.
330−
331− ZonedTime assumes offsets are a whole number of minutes, and thus the
332− conversion to ZonedTime does not support these timestamps and will
333− still throw a conversion error.
334−
335− Note that PostgreSQL's "timestamp with time zone" (or "timestamptz")
336− type is nearly universally misunderstood. For an explanation, see:
337−
338− https://github.com/lpsmith/postgresql-simple/issues/69
339−
340− Thanks to Michael Snoyman for his assistance with this issue.
341−
342−### Version 0.4.6.0 (2014-10-07)
343− * Added an instance ToField NominalDiffTime.
344−
345−### Version 0.4.5.0 (2014-09-26)
346− * Added support for retrieving NaN and ±Infinity floating point values
347− from postgres to the FromField instances for Float, Double, and Rational.
348− The instance for Scientific is unchanged due to the fact it has no
349− way of representing these special values. Thanks goes to Tom Nielsen
350− for reporting the issue.
351−
352−### Version 0.4.4.1 (2014-09-07)
353− * Fixed a rather serious bug that prevented the COPY module from working
354− at all on unix clients since version 0.4.3.0. Thanks goes to
355− Dmitry Dzhus for reporting the issue.
356−
357− * Added a regression test for the COPY module to the test suite.
358−
359−### Version 0.4.4.0 (2014-08-26)
360− * Added the jsonb type debuting in PostgreSQL 9.4 to the TypeInfo.Static
361− and Builtin tables, and extended the out-of-box json instances to
362− be compatible with the new type. Thanks to Tobias Florek for the
363− patch.
364−
365− * Ported some expanded documentation from mysql-simple, and fixed
366− a documentation typo.
367−
368−### Version 0.4.3.0 (2014-07-10)
369− * connect and exec now use libpq asynchronously on non-Windows platforms.
370− This means we are using threadWaitRead and threadWaitWrite to
371− have GHC's IO manager schedule non-blocking C calls to libpq,
372− instead of using blocking C calls and having the OS kernel do the
373− scheduling. Among other things, this now means that System.Timeout
374− will work with connect and exec on unix platforms.
375−
376− * connect and exec now throw IOErrors instead of SQLErrors in
377− some cases. The intention is for SQLErrors to represent
378− an error returned by the server, and to use IOErrors for errors
379− that originate from client-side code. However, this goal
380− isn't perfectly achieved as of yet.
381−
382−### Version 0.4.2.3 (2014-06-04)
383− * This is strictly a documentation release, with no code changes.
384−
385− * Fixed several documentation typos, thanks to Chris Allen and remdezx.
386−
387− * Expanded the documentation of connectPostgreSQL, including a short
388− overview of common use cases and two new links to the official Postgres
389− documentation about the authentication process.
390−
391− * De-emphasized connect and ConnectInfo in favor of connectPostgreSQL.
392−
393−### Version 0.4.2.2 (2014-05-15)
394− * Fixed compatibility with scientific-0.3.\*, thanks to Adam Bergmark
395−
396− * Improved documentation of the FromField module, as well as the fold,
397− foldWithOptions, executeMany, and returning operators.
398−
399−### Version 0.4.2.1 (2014-03-27)
400− * Fixed bug in Values syntax generation
401−
402− * Improved documentation, including examples of multi-row update,
403− a better example for Values, documenting the inaccuracies in reading
404− floating point numbers from the database, and the IsString instance
405− for QualifiedIdentifier.
406−
407−### Version 0.4.2.0 (2014-03-22)
408− * Added ToField and FromField instances for the scientific package
409−
410− * Changed the Identifier and QualifiedIdentifier to use Text in
411− order to avoid encoding errors. Technically this requires a
412− major version bump, but let's pretend 0.4.1.0 didn't happen.
413−
414− * Removed non-exhaustive cases in the ToField instance for Values,
415− and tweaked error messages.
416−
417−### Version 0.4.1.0 (2014-03-22)
418− * Fixed the parsing of arrays containing null values, courtesy of
419− Francesco Mazzoli
420−
421− * Added support for properly escaped identifiers, courtesy of
422− Tobias Florek. See the new Identifier and QualifiedIdentifier
423− types inside Database.PostgreSQL.Simple.Types.
424−
425− * Added support for parameterized VALUES expressions. This is
426− more general than executeMany and returning. See the
427− Database.PostgreSQL.Simple.Types.Values data type.
428−
429−### Version 0.4.0.2 (2014-01-12)
430− * Tweaked C preprocessor directive to be more portable
431−
432− * Tweaked testsuite for compatibility with aeson-0.7
433−
434−### Version 0.4.0.1 (2013-12-21)
435− * Relaxed dependency on aeson to >= 0.6
436−
437− * Update the documentation of `fromField`
438−
439−### Version 0.4.0.0 (2013-12-21)
440− * Changed the calling code of `fromField` so that it always sends
441− a copy of the raw data. This should be a small but significant
442− performance bump for most people most of the time; however it
443− may slow down retrieval of large values not converted directly
444− to ByteString, such as large json, hstore, and array values.
445− See commit 8635f8 for more information.
446−
447− * Added the PGArray type. Thanks to Joey Adams for the suggestion
448−
449− * Fixed JSON decoding, which was almost entirely broken up until now,
450− due to bugs in the version of aeson currently available on Hackage.
451− Thanks to Amit Levy for the report.
452−
453− * Added FromField instances for IORef, MVar, and IOVector.
454−
455−### Version 0.3.10.0 (2013-12-17)
456− * Added the queryWith function, courtesy of Leonid Onokhov
457−
458− * Added the Default type, for representing postgresql's default values
459−
460−### Version 0.3.9.1 (2013-10-28)
461− * Removed dependency on hashable
462−
463−### Version 0.3.9.0 (2013-10-27)
464− * Added FromField and ToField instances for the `uuid` package,
465− courtesy of Bas van Dijk.
466−
467− * Added instance FromRow (Maybe a) for most pre-packaged FromRow
468− instances. See issue #64 for some discussion.
469−
470− * Added the fromBinary, fromHStoreMap, and fromHStoreList newtype
471− unwrapper functions, courtesy of Bas van Dijk.
472−
473−### Version 0.3.8.0 (2013-10-11)
474− * Fixed the example code in `FromField`, thanks to Adam Bergmark.
475−
476− * Added `Notification.getBackendPID`.
477−
478−### Version 0.3.7.1 (2013-09-12)
479− * Relaxed the dependency on bytestring-0.10 back to bytestring-0.9,
480− courtesy of Michael Snoyman
481−
482−### Version 0.3.7.0 (2013-09-11)
483− * Added `aeson` as a dependency.
484−
485− * Added ToField and FromField instances for aeson's JSON.Value type,
486− courtesy of Bas van Dijk.
487−
488− * Added toJSONField and fromJSONField helper functions for declaring
489− FromField/ToField JSON instances to other Haskell types, courtesy
490− of Bas van Dijk.
491−
492− * Added a FromField instance for (), corresponding to postgresql's void
493− type.
494−
495− * Added liftConversion and liftRowParser functions to the Internal
496− module, for lifting IO actions into the respective monads.
497−
498− * The SqlError predicates available in the Transaction module are now
499− also exported from the Errors module.
500−
501− * Various documentation fixes.
502−
503−### Version 0.3.6.0 (2013-08-19)
504− * Added the json type to BuiltinTypes and TypeInfo.Static, courtesy of
505− Manuel Gómez.
506−
507− * Removed the remaining internal dependencies on BuiltinTypes from
508− FromField. Added the TypeInfo.Macro module as a result.
509−
510− * Deprecated the BuiltinTypes module, which will be removed several
511− months from now. Fixed the example code in FromField to reflect
512− this change.
513−
514−### Version 0.3.5.0 (2013-08-09)
515− * Added an FromRow instance for Vector, semantically identical to the
516− existing FromRow instance for [], courtesy of Doug Beardsley
517−
518− * Reworked the documentation for the Copy module, and tweaked the
519− documentation for the LargeObjects module.
520−
521−### Version 0.3.4.0 (2013-07-23)
522− * Added direct support for COPY IN and COPY OUT, without having
523− to use raw postgresql-libpq calls and postgresql-simple's Internal
524− module.
525−
526− * Changed `getNotification` so that it throws a IOError (resource vanished)
527− exception instead of an ErrorCall exception when it fails to fetch
528− the connection's file descriptor from libpq.
529−
530−### Version 0.3.3.2 (2013-06-18)
531− * Optimized the definition of `mconcat` in the Monoid instance for
532− the Query type, courtesy of Joey Adams.
533−
534−### Version 0.3.3.1 (2013-06-06)
535− * `getNotification` now works on Windows, albeit using a one-second
536− polling loop, courtesy of Joey Adams.
537−
538−### Version 0.3.3.0 (2013-05-29)
539− * Fixed two issues with the fold operator: fold would raise the wrong
540− exception, and gave the database cursor a static name preventing
541− folds from being nested. Thanks to Joey Adams for his
542− work on these issues.
543−
544−### Version 0.3.2.0 (2013-05-20)
545− * Added a savepoint abstraction to the Transaction module, courtesy
546− of Joey Adams
547−
548−### Version 0.3.1.2 (2013-04-29)
549− * Fixed hstore parser to not unnecessarily reverse the key-value pairs
550−
551−### Version 0.3.1.1 (2013-04-29)
552− * Fixed hstore parser to recognize empty hstores, courtesy of Simon
553− Meier
554−
555−### Version 0.3.1.0 (2013-04-26)
556− * Added support for Range and Composite types to the TypeInfo system.
557−
558− * Added support for hstore types in the Simple.HStore module.
559−
560− * Improved documentation of the FromField module.
561−
562−### Version 0.3.0.1 (2013-03-26)
563− * A large chunk of the documentation inside the FromField module had
564− silently failed to render in Haddock.
565−
566−### Version 0.3.0.0 (2013-03-25)
567− * Added support for PostgreSQL's Array Types. Thanks to Jason Dusek
568− for his work on this feature.
569−
570− * Added a brand new TypeInfo system that gives FromField instances
571− convenient and efficient access to the pg_type metatable. This
572− replaced the older typename cache, and was necessary to properly
573− support postgres array types. Thanks to Bas van Dijk for his
574− work on this feature.
575−
576− * Changed the type of the `fromField` and `fromRow` methods to allow
577− a restricted set of IO actions, and stopped pre-calculating the type
578− name of every column. As a result, the type of the `typename`
579− operator changed from `Field -> ByteString` to
580− `Field -> Conversion ByteString`, where Conversion is the new monad
581− that conversion computations run inside.
582−
583− * Improved the documentation of the FromField module.
584−
585− * Added the Database.PostgreSQL.Simple.Errors module, which offers
586− some predicates and functions for interpreting SqlError values, courtesy
587− of Leonid Onokhov.
588−
589− * Added a the name of a column and the associated table's object identifier
590− to ResultError exceptions, courtesy of Jeff Chu.
591−
592− * Moved most of the more detailed transaction operators into the
593− Database.PostgreSQL.Simple.Transaction module.
594−
595− * Changed withTransactionModeRetry to accept a predicate of which
596− SqlErrors to retry, due to the fact that serialization errors can
597− sometimes manifest themselves as constraint violations. Thanks
598− to Oliver Charles for pointing this out and implementing the change.
599−
600− * Added simple tests of the fold operator, thanks to Joey Adams.
601−
602− * Added simple tests of the array conversion code.
603−
604− * Added recognition of -- comments in the quasiquoter, which are
605− now stripped out.
606−
607−
608−### Version 0.2.4.1 (2012-08-29)
609− * Fixed the documentation of `In`. Thanks to rekado and dstcruz for
610− pointing this out.
611−
612−### Version 0.2.4.0 (2012-08-23)
613− * Added the `withTransactionSerializable` and `withTransactionModeRetry`
614− operators, thanks to Joey Adams.
615−
616−### Version 0.2.3.0 (2012-08-09)
617− * Added the `returning` operator, thanks to Jason Dusek
618−
619−### Version 0.2.2.0 (2012-07-26)
620− * Added a ToRow instance for the (:.) type, courtesy of Leonid Onokhov
621−
622− * Added the type oid for PostgreSQL's `uuid` type to BuiltinTypes
623−
624−### Version 0.2.1.0 (2012-07-23)
625− * Added the FromRow.fieldWith operator, thanks to Leonid Onokhov
626−
627− * Added a type synonym for FieldParser
628−
629−### Version 0.2.0.1 (2012-06-21)
630− * Fixed a compatibility problem with PostgreSQL 8.1, which does not allow
631− clients to set their own value for `standard_conforming_strings`. This
632− connection variable is still set to `on` for PostgreSQL 8.2 and later.
633−
634−### Version 0.2: (2012-06-19)
635− * Removed the conversion from `timestamp` to `UTCTime`. Some code will be
636− broken even though it will still compile.
637−
638− * Renamed a number of data constructors, mostly in the BuiltinTypes module.
639−
640− * Exported ToRow/FromRow from Database.PostgreSQL.Simple
641−
642−
643−### Version 0.1.4.3: (2012-06-10)
644− * Fix language extensions for compatibility with GHC 7.0
645−
646−### Version 0.1.4.2: (2012-06-10)
647− * Fix a wayward dependency on Text.
648−
649−### Version 0.1.4.1: (2012-06-10)
650− * Added support for timezones with minutes in their UTC offset.
651−
652−### Version 0.1.4: (2012-06-10)
653− * Removed pcre-light dependency, courtesy of Joey Adams.
654−
655− * Reworked support for the Time types.
656−
657− * The conversion from PostgreSQL's `timestamp` (without time zone) type
658− to Haskell's `UTCTime` type is deprecated and will be removed in 0.2.
659−
660− * `Data.Time.LocalTime` now has `FromField`/`ToField` instances. It is
661− now the preferred way of dealing with `timestamp` (without time zone).
662−
663− * `Database.PostgreSQL.Simple.Time` is a new module that offers types
664− that accommodate PostgreSQL's infinities.
665−
666− * All time-related `FromField`/`ToField` instances are now based on new,
667− higher-speed parsers and printers instead of those provided by the
668− time package included in GHC.
669−
670− * Planned breaking changes for 0.2:
671−
672− * Removing the conversion from `timestamp` to `UTCTime`.
673−
674− * Renaming some of the type names in `BuiltinTypes`.
675−
676−
677−### Version 0.1.3: (2012-05-30)
678− * Made ZonedTime an instance of FromField and ToField
679−
680− * Added getNotificationNonBlocking
681−
682−
683−### Version 0.1.2: (2012-05-09)
684− * Switched to libpq-based escaping for bytea types; Binary now works with
685− PostgreSQL 8 courtesy of Joey Adams.
686−
687− * postgresql-simple now sets standard_conforming_strings to "on". This
688− per-connection variable is initialized according to the server
689− configuration, which defaults to "off" for PostgreSQL < 9, and "on"
690− for PostgreSQL >= 9. You may need to adjust any string literals in
691− your SQL queries, or set the variable yourself.
692−
693− * Exported (:.) from Database.PostgreSQL.Simple
694−
695−
696−### Version 0.1.1: (2012-05-06)
697− * Added some preliminary documentation for the Ok, Notification, and
698− LargeObjects modules
699−
700− * Implemented the `fail` method for the monad instance for `Ok`.
701−
702− * Fixed a bug relating to handling the transaction level
703−
704−
705−### Version 0.1: (2012-05-04)
706− * Renamed several modules, typeclasses, and functions:
707−
708− QueryParams (renderParams) -> ToRow (toRow)
709− QueryResults (convertResults) -> FromRow (fromRow)
710− Param (render) -> ToField (toField)
711− Result (convert) -> FromField (fromField)
712−
713− * Added the `Database.PostgreSQL.Simple.Ok` module, a variation of
714− `Either SomeException` that has an instance for `Alternative` and also
715− uses a list of exceptions to track the ways it has failed.
716−
717− * Changed the return type of `fromField` and `fromRow` from
718− `Either SomeException` to `Ok`.
719−
720− * Thanks to suggestions from Ozgun Ataman, the `FromRow` typeclass has been
721− massively improved. The result is simpler definitions and better
722− compositionality. Also, user-defined instances need not be to be
723− concerned about forcing the converted results to WHNF. Here is an
724− example comparing the old to the new:
725−
726− instance (Result a, Result b) => QueryResults (a,b) where
727− convertResults [fa,fb] [va,vb] = do
728− !a <- convert fa va
729− !b <- convert fb vb
730− return (a,b)
731− convertResults fs vs = convertError fs vs 2
732−
733− instance (FromField a, FromField b) => FromRow (a,b) where
734− fromRow = (,) <$> field <*> field
735−
736− * Added `(:.)`, a pair that allows one to compose `FromRow` instances:
737−
738− instance (FromRow a, FromRow b) => FromRow (a :. b) where
739− fromRow = (:.) <$> fromRow <*> fromRow
740−
741− * Moved the contents `Field` module into the `FromField` module.
742−
743− * Removed the `RawResult` type.
744−
745− * Added `DefaultIsolationLevel` as a distinct `IsolationLevel` option
746− and `DefaultReadWriteMode` as a distinct `ReadWriteMode`.
CONTRIBUTING.mddeleted−13
@@ -1,13 +0,0 @@
1−Patches welcome!
2−
3−- If you are only going to bump bounds:
4− - If it's really **only bounds**, please simply open an issue (so you'll have a URL to refer to). I have a semi-automated process to make revisions, pull requests only disturb it.
5− - If patch includes **source code change** (i.e. I'll need to make a release), and it's a patch to support **newer base/GHC version**:
6− - Amend `tested-with` to include that GHC
7− - Regenerate `.github/workflows/haskell-ci.yml` with `haskell-ci regenerate` (get the latest from [GitHub haskell-ci/haskell-ci](https://github.com/haskell-ci/haskell-ci))
8−
9−- Don't edit `CHANGELOG.md`, rather include a copyable entry in your pull request description. I often process pull requests in bulk, and everyone editing the `CHANGELOG.md` causes unnecessary conflicts.
10−- For the same reason, do not edit `version` or `x-revision`
11−
12−- I use [`stylish-haskell`](https://github.com/jaspervdj/stylish-haskell) to format imports. I encourage you to use it too, when contributing.
13−- General code style is 4 spaces, just look around how it looks, it's not so strict.
CONTRIBUTORS−26
@@ -8,29 +8,3 @@ Leonid Onokhov <sopvop@gmail.com>
88Bas van Dijk <v.dijk.bas@gmail.com>
99Jason Dusek <jason.dusek@gmail.com>
1010Jeff Chu <jeff@kiteedu.com>
11−Oliver Charles <oliver.g.charles@gmail.com>
12−Simon Meier <iridcode@gmail.com>
13−Alexey Uimanov <s9gf4ult@gmail.com>
14−Doug Beardsley <mightybyte@gmail.com>
15−Manuel Gómez <targen@gmail.com>
16−Michael Snoyman <michael@snoyman.com>
17−Adam Bergmark <adam@edea.se>
18−Tobias Florek <tob@butter.sh>
19−Francesco Mazzoli <francesco.mazzoli@erudify.com>
20−Chris Allen <cma@bitemyapp.com>
21−Simon Hengel <sol@typeful.net>
22−Tom Ellis <tom-2013@purelyagile.com>
23−Mike Ledger <mike@quasimal.com>
24−João Cristóvão <jmacristovao@gmail.com>
25−Bardur Arantsson <bardur@scientician.net>
26−Travis Staton <hello@travisstaton.com>
27−Sam Rijs <srijs@airpost.net>
28−Janne Hellsten <jjhellst@gmail.com>
29−Timmy Tofu <timmytofu@users.noreply.github.com>
30−Alexey Khudyakov <alexey.skladnoy@gmail.com>
31−Timo von Holtz <tvh@anchor.com.au>
32−Amit Levy <amit@amitlevy.com>
33−Ben Gamari <ben@smart-cactus.org>
34−Edgar Gomes Araujo <talktoedgar@gmail.com>
35−Erik Hesselink <hesselink@gmail.com>
36−Matvey Aksenov <matvey.aksenov@gmail.com>
README.mddeleted−4
@@ -1,4 +0,0 @@
1−[![Hackage page (downloads and API reference)][hackage-png]][hackage]
2−
3− [hackage-png]: http://img.shields.io/hackage/v/postgresql-simple.svg
4− [hackage]: http://hackage.haskell.org/package/postgresql-simple
bench/Select.hsdeleted−32
@@ -1,32 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−module Main where
3−
4−import Database.PostgreSQL.Simple
5−import qualified Database.PostgreSQL.Simple.Vector as V
6−import qualified Database.PostgreSQL.Simple.Vector.Unboxed as VU
7−
8−import System.Environment (getArgs)
9−import Data.Foldable (Foldable, foldl')
10−import qualified Data.Vector.Unboxed as VU
11−
12−main :: IO ()
13−main = do
14− args <- getArgs
15− conn <- connectPostgreSQL ""
16− case args of
17− ("vector":_) -> do
18− result <- V.query_ conn "SELECT * FROM generate_series(1, 10000000);"
19− print (process result)
20− ("unboxed":_) -> do
21− -- dummy column
22− result <- VU.query_ conn "SELECT (NULL :: VOID), * FROM generate_series(1, 10000000);"
23− print (process' result)
24− _ -> do
25− result <- query_ conn "SELECT * FROM generate_series(1, 10000000);"
26− print (process result)
27−
28−process :: Foldable f => f (Only Int) -> Int
29−process = foldl' (\x (Only y) -> max x y) 0
30−
31−process' :: VU.Vector ((), Int) -> Int
32−process' = VU.foldl' (\x (_, y) -> max x y) 0
cabal.haskell-cideleted−5
@@ -1,5 +0,0 @@
1−branches: master
2−postgresql: True
3−
4−-- services aren't supported on Travis on macOS
5−-- osx: 8.4.4
cabal.projectdeleted−4
@@ -1,4 +0,0 @@
1−packages: .
2−tests: true
3−
4−allow-newer: cryptohash-md5-0.11.100.1:base
cabal.project.local.windeleted−4
@@ -1,4 +0,0 @@
1−constraints: these -assoc
2−
3−package postgresql-libpq
4− flags: -use-pkg-config
postgresql-simple.cabal+80−153
@@ -1,175 +1,102 @@
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.
1+Name: postgresql-simple
2+Version: 0.3.0.0
3+Synopsis: Mid-Level PostgreSQL client library
4+Description:
5+ Mid-Level PostgreSQL client library, forked from mysql-simple.
6+License: BSD3
7+License-file: LICENSE
8+Author: Bryan O'Sullivan, Leon P Smith
9+Maintainer: Leon P Smith <leon@melding-monads.com>
10+Copyright: (c) 2011 MailRank, Inc.
11+ (c) 2011-2012 Leon P Smith
12+Category: Database
13+Build-type: Simple
814
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
15+Cabal-version: >= 1.9.2
1716
18−category: Database
19−build-type: Simple
2017extra-source-files:
21− CHANGES.md
22− CONTRIBUTORS
23− test/results/malformed-input.expected
24− test/results/unique-constraint-violation.expected
18+ CONTRIBUTORS
2519
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
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.FromField
27+ Database.PostgreSQL.Simple.FromRow
28+ Database.PostgreSQL.Simple.LargeObjects
29+ Database.PostgreSQL.Simple.Notification
30+ Database.PostgreSQL.Simple.Ok
31+ Database.PostgreSQL.Simple.SqlQQ
32+ Database.PostgreSQL.Simple.Time
33+ Database.PostgreSQL.Simple.Time.Internal
34+ Database.PostgreSQL.Simple.ToField
35+ Database.PostgreSQL.Simple.ToRow
36+ Database.PostgreSQL.Simple.Transaction
37+ Database.PostgreSQL.Simple.TypeInfo
38+ Database.PostgreSQL.Simple.Types
39+ Database.PostgreSQL.Simple.Errors
40+-- Other-modules:
41+ Database.PostgreSQL.Simple.Internal
3542
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
43+ Other-modules:
44+ Database.PostgreSQL.Simple.Compat
45+ Database.PostgreSQL.Simple.Time.Implementation
6746
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
47+ Build-depends:
48+ attoparsec >= 0.8.5.3,
49+ base < 5,
50+ blaze-builder,
51+ blaze-textual,
52+ bytestring >= 0.9,
53+ containers,
54+ postgresql-libpq >= 0.6.2,
55+ template-haskell,
56+ text >= 0.11.1,
57+ time,
58+ transformers,
59+ vector
9960
100− default-extensions:
101− BangPatterns
102− DoAndIfThenElse
103− OverloadedStrings
104− TypeOperators
105− ViewPatterns
61+ extensions: DoAndIfThenElse, OverloadedStrings, BangPatterns, ViewPatterns
62+ TypeOperators
10663
107− ghc-options: -Wall -fno-warn-name-shadowing
64+ ghc-options: -Wall -fno-warn-name-shadowing
10865
10966source-repository head
11067 type: git
111− location: http://github.com/haskellari/postgresql-simple
68+ location: http://github.com/lpsmith/postgresql-simple
11269
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
70+source-repository this
71+ type: git
72+ location: http://github.com/lpsmith/postgresql-simple
73+ tag: v0.3.0.0
12574
12675test-suite test
127− default-language: Haskell2010
128− type: exitcode-stdio-1.0
129− hs-source-dirs: test
130− main-is: Main.hs
76+ type: exitcode-stdio-1.0
77+
78+ hs-source-dirs: test
79+ main-is: Main.hs
13180 other-modules:
13281 Common
133− Exception
134− Interval
13582 Notify
13683 Serializable
13784 Time
13885
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
86+ ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind
14887
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
88+ extensions: NamedFieldPuns
89+ , OverloadedStrings
90+ , Rank2Types
91+ , RecordWildCards
92+ , PatternGuards
93+ , ScopedTypeVariables
16694
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
95+ build-depends: base
96+ , base16-bytestring
97+ , bytestring
98+ , cryptohash
99+ , HUnit
100+ , postgresql-simple
101+ , text
102+ , time
sdist.shdeleted−25
@@ -1,25 +0,0 @@
1−#!/bin/bash
2−
3−echo "Generating CHANGELOG.md"
4−echo
5−
6−cat <<HEADER > CHANGELOG.md
7−For the full changelog, see
8−<https://github.com/lpsmith/postgresql-simple/blob/master/CHANGES.md>
9−
10−HEADER
11−
12−perl -ne '$n++ if /^###/; exit if $n==2; print' CHANGES.md >> CHANGELOG.md
13−
14−cat CHANGELOG.md
15−rm -f ./dist/*.tar
16−rm -f ./dist/*.tar.gz
17−cabal sdist
18−cd dist
19−wc *.tar.gz
20−gunzip *.gz
21−wc *.tar
22−zopfli *.tar
23−wc *.tar.gz
24−cd ..
25−rm -f ./dist/*.tar
src/Database/PostgreSQL/Simple.hs+173−244
@@ -13,6 +13,7 @@
1313-- License: BSD3
1414-- Maintainer: Leon P Smith <leon@melding-monads.com>
1515-- Stability: experimental
16+-- Portability: portable
1617--
1718-- A mid-level client library for the PostgreSQL database, aimed at ease of
1819-- use and high performance.
@@ -42,7 +43,7 @@ module Database.PostgreSQL.Simple
4243 -- ** Modifying multiple rows at once
4344 -- $many
4445
45− -- ** @RETURNING@: modifications that return results
46+ -- ** @RETURNING@: modifications that returns results
4647 -- $returning
4748
4849 -- * Extracting results
@@ -55,7 +56,8 @@ module Database.PostgreSQL.Simple
5556 -- $types
5657
5758 -- * Types
58− Connection
59+ Base.ConnectInfo(..)
60+ , Connection
5961 , Query
6062 , ToRow
6163 , FromRow
@@ -64,26 +66,20 @@ module Database.PostgreSQL.Simple
6466 , Only(..)
6567 , (:.)(..)
6668 -- ** Exceptions
67− , SomePostgreSqlException(..)
6869 , SqlError(..)
6970 , PQ.ExecStatus(..)
70− , FormatError(..)
71− , QueryError(..)
72− , ResultError(..)
71+ , FormatError(fmtMessage, fmtQuery, fmtParams)
72+ , QueryError(qeMessage, qeQuery)
73+ , ResultError(errSQLType, errHaskellType, errMessage)
7374 -- * Connection management
74− , Base.connectPostgreSQL
75− , Base.close
7675 , Base.connect
77− , Base.withConnect
78− , Base.ConnectInfo(..)
79− , Base.defaultConnectInfo
76+ , Base.connectPostgreSQL
8077 , Base.postgreSQLConnectionString
78+ , Base.defaultConnectInfo
79+ , Base.close
8180 -- * Queries that return results
8281 , query
8382 , query_
84− -- ** Queries taking parser as argument
85− , queryWith
86− , queryWith_
8783 -- * Queries that stream results
8884 , FoldOptions(..)
8985 , FetchQuantity(..)
@@ -95,14 +91,6 @@ module Database.PostgreSQL.Simple
9591 , forEach
9692 , forEach_
9793 , 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
10694 -- * Statements that do not return results
10795 , execute
10896 , execute_
@@ -110,7 +98,6 @@ module Database.PostgreSQL.Simple
11098-- , Base.insertID
11199 -- * Transaction handling
112100 , withTransaction
113− , withSavepoint
114101-- , Base.autocommit
115102 , begin
116103 , commit
@@ -120,27 +107,46 @@ module Database.PostgreSQL.Simple
120107 , formatQuery
121108 ) where
122109
123−import Data.ByteString.Builder (Builder, byteString, char8)
124−import Control.Applicative ((<$>))
125−import Control.Exception as E
110+import Blaze.ByteString.Builder
111+ ( Builder, fromByteString, toByteString )
112+import Blaze.ByteString.Builder.Char8 (fromChar)
113+import Control.Applicative ((<$>), pure)
114+import Control.Exception
115+ ( Exception, throw, throwIO, finally )
116+import Control.Monad (foldM)
126117import Data.ByteString (ByteString)
127118import Data.Int (Int64)
128119import Data.List (intersperse)
129120import Data.Monoid (mconcat)
130−import Database.PostgreSQL.Simple.Compat ((<>), toByteString)
131−import Database.PostgreSQL.Simple.Cursor
121+import Data.Typeable (Typeable)
122+import Database.PostgreSQL.Simple.Compat ( (<>) )
132123import Database.PostgreSQL.Simple.FromField (ResultError(..))
133124import Database.PostgreSQL.Simple.FromRow (FromRow(..))
134−import Database.PostgreSQL.Simple.ToField (Action(..))
125+import Database.PostgreSQL.Simple.Ok
126+import Database.PostgreSQL.Simple.ToField (Action(..), inQuotes)
135127import Database.PostgreSQL.Simple.ToRow (ToRow(..))
136128import Database.PostgreSQL.Simple.Types
137129 ( Binary(..), In(..), Only(..), Query(..), (:.)(..) )
138130import Database.PostgreSQL.Simple.Internal as Base
139−import Database.PostgreSQL.Simple.Internal.PQResultUtils
140131import Database.PostgreSQL.Simple.Transaction
132+import Database.PostgreSQL.Simple.TypeInfo
141133import qualified Database.PostgreSQL.LibPQ as PQ
142134import qualified Data.ByteString.Char8 as B
143−
135+import qualified Data.Text as T
136+import qualified Data.Text.Encoding as TE
137+import Control.Monad.Trans.Reader
138+import Control.Monad.Trans.State.Strict
139+
140+-- | Exception thrown if a 'Query' could not be formatted correctly.
141+-- This may occur if the number of \'@?@\' characters in the query
142+-- string does not match the number of parameters provided.
143+data FormatError = FormatError {
144+ fmtMessage :: String
145+ , fmtQuery :: Query
146+ , fmtParams :: [ByteString]
147+ } deriving (Eq, Show, Typeable)
148+
149+instance Exception FormatError
144150
145151-- | Format a query string.
146152--
@@ -177,9 +183,9 @@ formatMany conn q@(Query template) qs = do
177183 case parseTemplate template of
178184 Just (before, qbits, after) -> do
179185 bs <- mapM (buildQuery conn q qbits . toRow) qs
180− return . toByteString . mconcat $ byteString before :
181− intersperse (char8 ',') bs ++
182− [byteString after]
186+ return . toByteString . mconcat $ fromByteString before :
187+ intersperse (fromChar ',') bs ++
188+ [fromByteString after]
183189 Nothing -> fmtError "syntax error in multi-row template" q []
184190
185191-- Split the input string into three pieces, @before@, @qbits@, and @after@,
@@ -277,40 +283,43 @@ parseTemplate template =
277283
278284 skipSpace = B.dropWhile isSpace_ascii
279285
286+escapeStringConn :: Connection -> ByteString -> IO (Either ByteString ByteString)
287+escapeStringConn conn s =
288+ withConnection conn $ \c ->
289+ PQ.escapeStringConn c s >>= checkError c
290+
291+escapeByteaConn :: Connection -> ByteString -> IO (Either ByteString ByteString)
292+escapeByteaConn conn s =
293+ withConnection conn $ \c ->
294+ PQ.escapeByteaConn c s >>= checkError c
295+
296+checkError :: PQ.Connection -> Maybe a -> IO (Either ByteString a)
297+checkError _ (Just x) = return $ Right x
298+checkError c Nothing = Left . maybe "" id <$> PQ.errorMessage c
280299
281300buildQuery :: Connection -> Query -> ByteString -> [Action] -> IO Builder
282−buildQuery conn q template xs =
283− zipParams (split template) <$> mapM (buildAction conn q xs) xs
284− where split s =
285− -- This part escapes double '??'s to make literal '?'s possible
286− -- in PostgreSQL queries using the JSON operators: @?@, @?|@ and @?&@
287− let (h,t) = breakOnSingleQuestionMark s
288− in byteString h
289− : if B.null t
290− then []
291− else split (B.tail t)
301+buildQuery conn q template xs = zipParams (split template) <$> mapM sub xs
302+ where quote = either (\msg -> fmtError (utf8ToString msg) q xs)
303+ (inQuotes . fromByteString)
304+ utf8ToString = T.unpack . TE.decodeUtf8
305+ sub (Plain b) = pure b
306+ sub (Escape s) = quote <$> escapeStringConn conn s
307+ sub (EscapeByteA s) = quote <$> escapeByteaConn conn s
308+ sub (Many ys) = mconcat <$> mapM sub ys
309+ split s = fromByteString h : if B.null t then [] else split (B.tail t)
310+ where (h,t) = B.break (=='?') s
292311 zipParams (t:ts) (p:ps) = t <> p <> zipParams ts ps
293312 zipParams [t] [] = t
294− zipParams _ _ = fmtError (show countSingleQs ++
295− " single '?' characters, but " ++
313+ zipParams _ _ = fmtError (show (B.count '?' template) ++
314+ " '?' characters, but " ++
296315 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
306316
307317-- | Execute an @INSERT@, @UPDATE@, or other SQL query that is not
308318-- expected to return results.
309319--
310320-- Returns the number of rows affected.
311321--
312−-- Throws 'FormatError' if the query could not be formatted correctly, or
313−-- a 'SqlError' exception if the backend returns an error.
322+-- Throws 'FormatError' if the query could not be formatted correctly.
314323execute :: (ToRow q) => Connection -> Query -> q -> IO Int64
315324execute conn template qs = do
316325 result <- exec conn =<< formatQuery conn template qs
@@ -319,33 +328,9 @@ execute conn template qs = do
319328-- | Execute a multi-row @INSERT@, @UPDATE@, or other SQL query that is not
320329-- expected to return results.
321330--
322−-- Returns the number of rows affected. If the list of parameters is empty,
323−-- this function will simply return 0 without issuing the query to the backend.
324−-- If this is not desired, consider using the 'Values' constructor instead.
325−--
326−-- Throws 'FormatError' if the query could not be formatted correctly, or
327−-- a 'SqlError' exception if the backend returns an error.
328−--
329−-- For example, here's a command that inserts two rows into a table
330−-- with two columns:
331−--
332−-- @
333−-- executeMany c [sql|
334−-- INSERT INTO sometable VALUES (?,?)
335−-- |] [(1, \"hello\"),(2, \"world\")]
336−-- @
337−--
338−-- Here's an canonical example of a multi-row update command:
331+-- Returns the number of rows affected.
339332--
340−-- @
341−-- executeMany c [sql|
342−-- UPDATE sometable
343−-- SET y = upd.y
344−-- FROM (VALUES (?,?)) as upd(x,y)
345−-- WHERE sometable.x = upd.x
346−-- |] [(1, \"hello\"),(2, \"world\")]
347−-- @
348−
333+-- Throws 'FormatError' if the query could not be formatted correctly.
349334executeMany :: (ToRow q) => Connection -> Query -> [q] -> IO Int64
350335executeMany _ _ [] = return 0
351336executeMany conn q qs = do
@@ -359,20 +344,12 @@ executeMany conn q qs = do
359344-- in cases where you are only inserting a single row, and do not need
360345-- functionality analogous to 'executeMany'.
361346--
362−-- If the list of parameters is empty, this function will simply return @[]@
363−-- without issuing the query to the backend. If this is not desired,
364−-- consider using the 'Values' constructor instead.
365−--
366347-- Throws 'FormatError' if the query could not be formatted correctly.
367348returning :: (ToRow q, FromRow r) => Connection -> Query -> [q] -> IO [r]
368−returning = returningWith fromRow
369−
370−-- | A version of 'returning' taking parser as argument
371−returningWith :: (ToRow q) => RowParser r -> Connection -> Query -> [q] -> IO [r]
372−returningWith _ _ _ [] = return []
373−returningWith parser conn q qs = do
349+returning _ _ [] = return []
350+returning conn q qs = do
374351 result <- exec conn =<< formatMany conn q qs
375− finishQueryWith parser conn q result
352+ finishQuery conn q result
376353
377354-- | Perform a @SELECT@ or other SQL query that is expected to return
378355-- results. All results are retrieved and converted before this
@@ -389,27 +366,17 @@ returningWith parser conn q qs = do
389366-- using 'execute' instead of 'query').
390367--
391368-- * 'ResultError': result conversion failed.
392−--
393−-- * 'SqlError': the postgresql backend returned an error, e.g.
394−-- a syntax or type error, or an incorrect table or column name.
395−query :: (ToRow q, FromRow r) => Connection -> Query -> q -> IO [r]
396−query = queryWith fromRow
369+query :: (ToRow q, FromRow r)
370+ => Connection -> Query -> q -> IO [r]
371+query conn template qs = do
372+ result <- exec conn =<< formatQuery conn template qs
373+ finishQuery conn template result
397374
398375-- | A version of 'query' that does not perform query substitution.
399376query_ :: (FromRow r) => Connection -> Query -> IO [r]
400−query_ = queryWith_ fromRow
401−
402−-- | A version of 'query' taking parser as argument
403−queryWith :: ToRow q => RowParser r -> Connection -> Query -> q -> IO [r]
404−queryWith parser conn template qs = do
405− result <- exec conn =<< formatQuery conn template qs
406− finishQueryWith parser conn template result
407−
408−-- | A version of 'query_' taking parser as argument
409−queryWith_ :: RowParser r -> Connection -> Query -> IO [r]
410−queryWith_ parser conn q@(Query que) = do
377+query_ conn q@(Query que) = do
411378 result <- exec conn que
412− finishQueryWith parser conn q result
379+ finishQuery conn q result
413380
414381-- | Perform a @SELECT@ or other SQL query that is expected to return
415382-- results. Results are streamed incrementally from the server, and
@@ -421,12 +388,6 @@ queryWith_ parser conn q@(Query que) = do
421388-- This fold is /not/ strict. The stream consumer is responsible for
422389-- forcing the evaluation of its result to avoid space leaks.
423390--
424−-- This is implemented using a database cursor. As such, this requires
425−-- a transaction. This function will detect whether or not there is a
426−-- transaction in progress, and will create a 'ReadCommitted' 'ReadOnly'
427−-- transaction if needed. The cursor is given a unique temporary name,
428−-- so the consumer may itself call fold.
429−--
430391-- Exceptions that may be thrown:
431392--
432393-- * 'FormatError': the query string could not be formatted correctly.
@@ -435,9 +396,7 @@ queryWith_ parser conn q@(Query que) = do
435396-- using 'execute' instead of 'query').
436397--
437398-- * 'ResultError': result conversion failed.
438−--
439−-- * 'SqlError': the postgresql backend returned an error, e.g.
440−-- a syntax or type error, or an incorrect table or column name.
399+
441400fold :: ( FromRow row, ToRow params )
442401 => Connection
443402 -> Query
@@ -447,20 +406,6 @@ fold :: ( FromRow row, ToRow params )
447406 -> IO a
448407fold = foldWithOptions defaultFoldOptions
449408
450−-- | A version of 'fold' taking a parser as an argument
451−foldWith :: ( ToRow params )
452− => RowParser row
453− -> Connection
454− -> Query
455− -> params
456− -> a
457− -> (a -> row -> IO a)
458− -> IO a
459−foldWith = foldWithOptionsAndParser defaultFoldOptions
460−
461−-- | Number of rows to fetch at a time. 'Automatic' currently defaults
462−-- to 256 rows, although it might be nice to make this more intelligent
463−-- based on e.g. the average size of the rows.
464409data FetchQuantity
465410 = Automatic
466411 | Fixed !Int
@@ -471,19 +416,12 @@ data FoldOptions
471416 transactionMode :: !TransactionMode
472417 }
473418
474−-- | defaults to 'Automatic', and 'TransactionMode' 'ReadCommitted' 'ReadOnly'
475419defaultFoldOptions :: FoldOptions
476420defaultFoldOptions = FoldOptions {
477421 fetchQuantity = Automatic,
478422 transactionMode = TransactionMode ReadCommitted ReadOnly
479423 }
480424
481−-- | The same as 'fold', but this provides a bit more control over
482−-- lower-level details. Currently, the number of rows fetched per
483−-- round-trip to the server and the transaction mode may be adjusted
484−-- accordingly. If the connection is already in a transaction,
485−-- then the existing transaction is used and thus the 'transactionMode'
486−-- option is ignored.
487425foldWithOptions :: ( FromRow row, ToRow params )
488426 => FoldOptions
489427 -> Connection
@@ -492,21 +430,9 @@ foldWithOptions :: ( FromRow row, ToRow params )
492430 -> a
493431 -> (a -> row -> IO a)
494432 -> IO a
495−foldWithOptions opts = foldWithOptionsAndParser opts fromRow
496−
497−-- | A version of 'foldWithOptions' taking a parser as an argument
498−foldWithOptionsAndParser :: (ToRow params)
499− => FoldOptions
500− -> RowParser row
501− -> Connection
502− -> Query
503− -> params
504− -> a
505− -> (a -> row -> IO a)
506− -> IO a
507−foldWithOptionsAndParser opts parser conn template qs a f = do
433+foldWithOptions opts conn template qs a f = do
508434 q <- formatQuery conn template qs
509− doFold opts parser conn template (Query q) a f
435+ doFold opts conn template (Query q) a f
510436
511437-- | A version of 'fold' that does not perform query substitution.
512438fold_ :: (FromRow r) =>
@@ -517,14 +443,6 @@ fold_ :: (FromRow r) =>
517443 -> IO a
518444fold_ = foldWithOptions_ defaultFoldOptions
519445
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
528446
529447foldWithOptions_ :: (FromRow r) =>
530448 FoldOptions
@@ -533,27 +451,18 @@ foldWithOptions_ :: (FromRow r) =>
533451 -> a -- ^ Initial state for result consumer.
534452 -> (a -> r -> IO a) -- ^ Result consumer.
535453 -> IO a
536−foldWithOptions_ opts conn query' a f = doFold opts fromRow conn query' query' a f
537−
538−-- | A version of 'foldWithOptions_' taking a parser as an argument
539−foldWithOptionsAndParser_ :: FoldOptions
540− -> RowParser r
541− -> Connection
542− -> Query -- ^ Query.
543− -> a -- ^ Initial state for result consumer.
544− -> (a -> r -> IO a) -- ^ Result consumer.
545− -> IO a
546−foldWithOptionsAndParser_ opts parser conn query' a f = doFold opts parser conn query' query' a f
547−
548−doFold :: FoldOptions
549− -> RowParser row
454+foldWithOptions_ opts conn query a f = doFold opts conn query query a f
455+
456+
457+doFold :: ( FromRow row )
458+ => FoldOptions
550459 -> Connection
551460 -> Query
552461 -> Query
553462 -> a
554463 -> (a -> row -> IO a)
555464 -> IO a
556−doFold FoldOptions{..} parser conn _template q a0 f = do
465+doFold FoldOptions{..} conn _template q a f = do
557466 stat <- withConnection conn PQ.transactionStatus
558467 case stat of
559468 PQ.TransIdle -> withTransactionMode transactionMode conn go
@@ -571,17 +480,10 @@ doFold FoldOptions{..} parser conn _template q a0 f = do
571480 PQ.TransUnknown -> fail "foldWithOpts FIXME: PQ.TransUnknown"
572481 -- Not sure what this means.
573482 where
574− declare =
575− declareCursor conn q
576− fetch cursor a =
577− foldForwardWithParser cursor parser chunkSize f a
578−
579− go = bracket declare closeCursor $ \cursor ->
580− let loop a = fetch cursor a >>=
581− \r -> case r of
582− Left x -> return x
583− Right x -> loop x
584− in loop a0
483+ go = do
484+ -- FIXME: what about name clashes with already-declared cursors?
485+ _ <- execute_ conn ("DECLARE fold NO SCROLL CURSOR FOR " <> q)
486+ loop a `finally` execute_ conn "CLOSE fold"
585487
586488-- FIXME: choose the Automatic chunkSize more intelligently
587489-- One possibility is to use the type of the results, although this
@@ -592,6 +494,9 @@ doFold FoldOptions{..} parser conn _template q a0 f = do
592494 chunkSize = case fetchQuantity of
593495 Automatic -> 256
594496 Fixed n -> n
497+ loop a = do
498+ rs <- query conn "FETCH FORWARD ? FROM fold" (Only chunkSize)
499+ if null rs then return a else foldM f a rs >>= loop
595500
596501-- | A version of 'fold' that does not transform a state value.
597502forEach :: (ToRow q, FromRow r) =>
@@ -600,37 +505,83 @@ forEach :: (ToRow q, FromRow r) =>
600505 -> q -- ^ Query parameters.
601506 -> (r -> IO ()) -- ^ Result consumer.
602507 -> IO ()
603−forEach = forEachWith fromRow
508+forEach conn template qs = fold conn template qs () . const
604509{-# INLINE forEach #-}
605510
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−
617511-- | A version of 'forEach' that does not perform query substitution.
618512forEach_ :: (FromRow r) =>
619513 Connection
620514 -> Query -- ^ Query template.
621515 -> (r -> IO ()) -- ^ Result consumer.
622516 -> IO ()
623−forEach_ = forEachWith_ fromRow
517+forEach_ conn template = fold_ conn template () . const
624518{-# INLINE forEach_ #-}
625519
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−
520+forM' :: (Ord n, Num n) => n -> n -> (n -> IO a) -> IO [a]
521+forM' lo hi m = loop hi []
522+ where
523+ loop !n !as
524+ | n < lo = return as
525+ | otherwise = do
526+ a <- m n
527+ loop (n-1) (a:as)
528+
529+finishQuery :: (FromRow r) => Connection -> Query -> PQ.Result -> IO [r]
530+finishQuery conn q result = do
531+ status <- PQ.resultStatus result
532+ case status of
533+ PQ.EmptyQuery ->
534+ throwIO $ QueryError "query: Empty query" q
535+ PQ.CommandOk -> do
536+ throwIO $ QueryError "query resulted in a command response" q
537+ PQ.TuplesOk -> do
538+ let unCol (PQ.Col x) = fromIntegral x :: Int
539+ nrows <- PQ.ntuples result
540+ ncols <- PQ.nfields result
541+ forM' 0 (nrows-1) $ \row -> do
542+ let rw = Row row result
543+ okvc <- runConversion (runStateT (runReaderT (unRP fromRow) rw) 0) conn
544+ case okvc of
545+ Ok (val,col) | col == ncols -> return val
546+ | otherwise -> do
547+ vals <- forM' 0 (ncols-1) $ \c -> do
548+ tinfo <- getTypeInfo conn =<< PQ.ftype result c
549+ v <- PQ.getvalue result row c
550+ return ( tinfo
551+ , fmap ellipsis v )
552+ throw (ConversionFailed
553+ (show (unCol ncols) ++ " values: " ++ show vals)
554+ Nothing
555+ ""
556+ (show (unCol col) ++ " slots in target type")
557+ "mismatch between number of columns to \
558+ \convert and number in target type")
559+ Errors [] -> throwIO $ ConversionFailed "" Nothing "" "" "unknown error"
560+ Errors [x] -> throwIO x
561+ Errors xs -> throwIO $ ManyErrors xs
562+ PQ.CopyOut ->
563+ throwIO $ QueryError "query: COPY TO is not supported" q
564+ PQ.CopyIn ->
565+ throwIO $ QueryError "query: COPY FROM is not supported" q
566+ PQ.BadResponse -> throwResultError "query" result status
567+ PQ.NonfatalError -> throwResultError "query" result status
568+ PQ.FatalError -> throwResultError "query" result status
569+
570+ellipsis :: ByteString -> ByteString
571+ellipsis bs
572+ | B.length bs > 15 = B.take 10 bs `B.append` "[...]"
573+ | otherwise = bs
574+
575+fmtError :: String -> Query -> [Action] -> a
576+fmtError msg q xs = throw FormatError {
577+ fmtMessage = msg
578+ , fmtQuery = q
579+ , fmtParams = map twiddle xs
580+ }
581+ where twiddle (Plain b) = toByteString b
582+ twiddle (Escape s) = s
583+ twiddle (EscapeByteA s) = s
584+ twiddle (Many ys) = B.concat (map twiddle ys)
634585
635586-- $use
636587--
@@ -658,11 +609,9 @@ forEachWith_ parser conn template = foldWith_ parser conn template () . const
658609-- >
659610-- > import Database.PostgreSQL.Simple
660611-- >
661−-- > hello :: IO Int
662612-- > hello = do
663−-- > conn <- connectPostgreSQL ""
664−-- > [Only i] <- query_ conn "select 2 + 2"
665−-- > return i
613+-- > conn <- connect defaultConnectInfo
614+-- > query conn "select 2 + 2"
666615--
667616-- A 'Query' value does not represent the actual query that will be
668617-- executed, but is a template for constructing the final query.
@@ -723,30 +672,15 @@ forEachWith_ parser conn template = foldWith_ parser conn template () . const
723672-- The same kind of problem can arise with string literals if you have
724673-- the @OverloadedStrings@ language extension enabled. Again, just
725674-- 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])
740675
741676-- $only_param
742677--
743678-- Haskell lacks a single-element tuple type, so if you have just one
744−-- value you want substituted into a query or a single-column result,
745−-- what should you do?
679+-- value you want substituted into a query, what should you do?
746680--
747681-- The obvious approach would appear to be something like this:
748682--
749−-- > instance (ToField a) => ToRow a where
683+-- > instance (Param a) => QueryParam a where
750684-- > ...
751685--
752686-- Unfortunately, this wreaks havoc with type inference, so we take a
@@ -757,9 +691,6 @@ forEachWith_ parser conn template = foldWith_ parser conn template () . const
757691--
758692-- > execute conn "insert into users (first_name) values (?)"
759693-- > ["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.
763694
764695-- $in
765696--
@@ -777,7 +708,7 @@ forEachWith_ parser conn template = foldWith_ parser conn template () . const
777708-- Here's an example:
778709--
779710-- > query conn "select * from users where first_name in ?" $
780−-- > Only $ In ["Anna", "Boris", "Carla"]
711+-- > In ["Anna", "Boris", "Carla"]
781712--
782713-- If your 'In'-wrapped list is empty, the string @\"(null)\"@ will be
783714-- substituted instead, to ensure that your clause remains
@@ -805,7 +736,7 @@ forEachWith_ parser conn template = foldWith_ parser conn template () . const
805736-- * There must be no other \"@?@\" characters anywhere in your
806737-- template.
807738--
808−-- * There must be one or more \"@?@\" in the parentheses.
739+-- * There must one or more \"@?@\" in the parentheses.
809740--
810741-- * Extra white space is fine.
811742--
@@ -828,10 +759,9 @@ forEachWith_ parser conn template = foldWith_ parser conn template () . const
828759
829760-- $returning
830761--
831−-- PostgreSQL supports returning values from data manipulation statements
832−-- such as @INSERT@ and @UPDATE@. You can use these statements by
833−-- using 'query' instead of 'execute'. For multi-tuple inserts,
834−-- use 'returning' instead of 'executeMany'.
762+-- The 'returning' function is similar to 'executeMany' but is
763+-- intended for use with multi-tuple @INSERT@ or @UPDATE@ statements
764+-- that make use of @RETURNING@.
835765--
836766-- For example, were there an auto-incrementing @id@ column and
837767-- timestamp column @t@ that defaulted to the present time for the
@@ -839,8 +769,7 @@ forEachWith_ parser conn template = foldWith_ parser conn template () . const
839769-- sales records and also return their new @id@s and timestamps.
840770--
841771-- > let q = "insert into sales (amount, label) values (?,?) returning id, t"
842−-- > xs :: [(Int, UTCTime)] <- query conn q (15,"Sawdust")
843−-- > ys :: [(Int, UTCTime)] <- returning conn q [(20,"Chips"),(300,"Wood")]
772+-- > xs :: [(Int, UTCTime)] <- returning conn q [(20,"Chips"),(300,"Wood")]
844773
845774-- $result
846775--
@@ -876,7 +805,7 @@ forEachWith_ parser conn template = foldWith_ parser conn template () . const
876805--
877806-- Although SQL can accommodate @NULL@ as a value for any of these
878807-- types, Haskell cannot. If your result contains columns that may be
879−-- @NULL@, be sure that you use 'Maybe' in those positions of your
808+-- @NULL@, be sure that you use 'Maybe' in those positions of of your
880809-- tuple.
881810--
882811-- > (Text, Maybe Int, Int)
@@ -902,7 +831,7 @@ forEachWith_ parser conn template = foldWith_ parser conn template () . const
902831-- all values of the given PostgreSQL type is considered \"compatible\".
903832-- For instance, you can always extract a PostgreSQL 16-bit @SMALLINT@
904833-- column to a Haskell 'Int'. The Haskell 'Float' type can accurately
905−-- represent a @SMALLINT@, so it is considered compatible with those types.
834+-- represent a @SMALLINT@, so it is considered compatble with those types.
906835--
907836-- * A numeric compatibility check is based only on the type of a
908837-- column, /not/ on its values. For instance, a PostgreSQL 64-bit
src/Database/PostgreSQL/Simple/Arrays.hs+5−3
@@ -7,6 +7,7 @@
77-- License: BSD3
88-- Maintainer: Leon P Smith <leon@melding-monads.com>
99-- Stability: experimental
10+-- Portability: portable
1011--
1112-- A Postgres array parser and pretty-printer.
1213------------------------------------------------------------------------------
@@ -17,7 +18,7 @@ import Control.Applicative (Applicative(..), Alternative(..), (<$>))
1718import Data.ByteString.Char8 (ByteString)
1819import qualified Data.ByteString.Char8 as B
1920import Data.Monoid
20−import Data.Attoparsec.ByteString.Char8
21+import Data.Attoparsec.Char8
2122
2223
2324-- | Parse one of three primitive field formats: array, quoted and plain.
@@ -42,9 +43,9 @@ array delim = char '{' *> option [] (arrays <|> strings) <* char '}'
4243quoted :: Parser ByteString
4344quoted = char '"' *> option "" contents <* char '"'
4445 where
45− esc' = char '\\' *> (char '\\' <|> char '"')
46+ esc = char '\\' *> (char '\\' <|> char '"')
4647 unQ = takeWhile1 (notInClass "\"\\")
47− contents = mconcat <$> many (unQ <|> B.singleton <$> esc')
48+ contents = mconcat <$> many (unQ <|> B.singleton <$> esc)
4849
4950-- | Recognizes a plain string literal, not containing quotes or brackets and
5051-- not containing the delimiter character.
@@ -90,3 +91,4 @@ esc = B.concatMap f
9091 f '\\' = "\\\\"
9192 f c = B.singleton c
9293 -- TODO: Implement easy performance improvements with unfoldr.
94+
src/Database/PostgreSQL/Simple/BuiltinTypes.hsnew file+411
@@ -0,0 +1,411 @@
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+ ( BuiltinType (..)
18+ , builtin2oid
19+ , oid2builtin
20+ , builtin2typname
21+ , oid2typname
22+ ) where
23+
24+import Data.Typeable
25+import Data.ByteString (ByteString)
26+import qualified Database.PostgreSQL.LibPQ as PQ
27+
28+data BuiltinType
29+ = Bool
30+ | ByteA
31+ | Char
32+ | Name
33+ | Int8
34+ | Int2
35+ | Int4
36+ | RegProc
37+ | Text
38+ | Oid
39+ | Tid
40+ | Xid
41+ | Cid
42+ | Xml
43+ | Point
44+ | LSeg
45+ | Path
46+ | Box
47+ | Polygon
48+ | Line
49+ | Cidr
50+ | Float4
51+ | Float8
52+ | AbsTime
53+ | RelTime
54+ | TInterval
55+ | Unknown
56+ | Circle
57+ | Money
58+ | MacAddr
59+ | Inet
60+ | BpChar
61+ | VarChar
62+ | Date
63+ | Time
64+ | Timestamp
65+ | TimestampTZ
66+ | Interval
67+ | TimeTZ
68+ | Bit
69+ | VarBit
70+ | Numeric
71+ | RefCursor
72+ | Record
73+ | Void
74+ | UUID
75+ deriving (Eq, Ord, Enum, Bounded, Read, Show, Typeable)
76+
77+builtin2oid :: BuiltinType -> PQ.Oid
78+builtin2oid typ = PQ.Oid $ case typ of
79+ Bool -> 16
80+ ByteA -> 17
81+ Char -> 18
82+ Name -> 19
83+ Int8 -> 20
84+ Int2 -> 21
85+ Int4 -> 23
86+ RegProc -> 24
87+ Text -> 25
88+ Oid -> 26
89+ Tid -> 27
90+ Xid -> 28
91+ Cid -> 29
92+ Xml -> 142
93+ Point -> 600
94+ LSeg -> 601
95+ Path -> 602
96+ Box -> 603
97+ Polygon -> 604
98+ Line -> 628
99+ Cidr -> 650
100+ Float4 -> 700
101+ Float8 -> 701
102+ AbsTime -> 702
103+ RelTime -> 703
104+ TInterval -> 704
105+ Unknown -> 705
106+ Circle -> 718
107+ Money -> 790
108+ MacAddr -> 829
109+ Inet -> 869
110+ BpChar -> 1042
111+ VarChar -> 1043
112+ Date -> 1082
113+ Time -> 1083
114+ Timestamp -> 1114
115+ TimestampTZ -> 1184
116+ Interval -> 1186
117+ TimeTZ -> 1266
118+ Bit -> 1560
119+ VarBit -> 1562
120+ Numeric -> 1700
121+ RefCursor -> 1790
122+ Record -> 2249
123+ Void -> 2278
124+ UUID -> 2950
125+
126+oid2builtin :: PQ.Oid -> Maybe BuiltinType
127+oid2builtin (PQ.Oid x) = case x of
128+ 16 -> Just Bool
129+ 17 -> Just ByteA
130+ 18 -> Just Char
131+ 19 -> Just Name
132+ 20 -> Just Int8
133+ 21 -> Just Int2
134+ 23 -> Just Int4
135+ 24 -> Just RegProc
136+ 25 -> Just Text
137+ 26 -> Just Oid
138+ 27 -> Just Tid
139+ 28 -> Just Xid
140+ 29 -> Just Cid
141+ 142 -> Just Xml
142+ 600 -> Just Point
143+ 601 -> Just LSeg
144+ 602 -> Just Path
145+ 603 -> Just Box
146+ 604 -> Just Polygon
147+ 628 -> Just Line
148+ 650 -> Just Cidr
149+ 700 -> Just Float4
150+ 701 -> Just Float8
151+ 702 -> Just AbsTime
152+ 703 -> Just RelTime
153+ 704 -> Just TInterval
154+ 705 -> Just Unknown
155+ 718 -> Just Circle
156+ 790 -> Just Money
157+ 829 -> Just MacAddr
158+ 869 -> Just Inet
159+ 1042 -> Just BpChar
160+ 1043 -> Just VarChar
161+ 1082 -> Just Date
162+ 1083 -> Just Time
163+ 1114 -> Just Timestamp
164+ 1184 -> Just TimestampTZ
165+ 1186 -> Just Interval
166+ 1266 -> Just TimeTZ
167+ 1560 -> Just Bit
168+ 1562 -> Just VarBit
169+ 1700 -> Just Numeric
170+ 1790 -> Just RefCursor
171+ 2249 -> Just Record
172+ 2278 -> Just Void
173+ 2950 -> Just UUID
174+ _ -> Nothing
175+
176+builtin2typname :: BuiltinType -> ByteString
177+builtin2typname typ = case typ of
178+ Bool -> bool
179+ ByteA -> bytea
180+ Char -> char
181+ Name -> name
182+ Int8 -> int8
183+ Int2 -> int2
184+ Int4 -> int4
185+ RegProc -> regproc
186+ Text -> text
187+ Oid -> oid
188+ Tid -> tid
189+ Xid -> xid
190+ Cid -> cid
191+ Xml -> xml
192+ Point -> point
193+ LSeg -> lseg
194+ Path -> path
195+ Box -> box
196+ Polygon -> polygon
197+ Line -> line
198+ Cidr -> cidr
199+ Float4 -> float4
200+ Float8 -> float8
201+ AbsTime -> abstime
202+ RelTime -> reltime
203+ TInterval -> tinterval
204+ Unknown -> unknown
205+ Circle -> circle
206+ Money -> money
207+ MacAddr -> macaddr
208+ Inet -> inet
209+ BpChar -> bpchar
210+ VarChar -> varchar
211+ Date -> date
212+ Time -> time
213+ Timestamp -> timestamp
214+ TimestampTZ -> timestamptz
215+ Interval -> interval
216+ TimeTZ -> timetz
217+ Bit -> bit
218+ VarBit -> varbit
219+ Numeric -> numeric
220+ RefCursor -> refcursor
221+ Record -> record
222+ Void -> void
223+ UUID -> uuid
224+
225+oid2typname :: PQ.Oid -> Maybe ByteString
226+oid2typname (PQ.Oid x) = case x of
227+ 16 -> Just bool
228+ 17 -> Just bytea
229+ 18 -> Just char
230+ 19 -> Just name
231+ 20 -> Just int8
232+ 21 -> Just int2
233+ 23 -> Just int4
234+ 24 -> Just regproc
235+ 25 -> Just text
236+ 26 -> Just oid
237+ 27 -> Just tid
238+ 28 -> Just xid
239+ 29 -> Just cid
240+ 142 -> Just xml
241+ 600 -> Just point
242+ 601 -> Just lseg
243+ 602 -> Just path
244+ 603 -> Just box
245+ 604 -> Just polygon
246+ 628 -> Just line
247+ 650 -> Just cidr
248+ 700 -> Just float4
249+ 701 -> Just float8
250+ 702 -> Just abstime
251+ 703 -> Just reltime
252+ 704 -> Just tinterval
253+ 705 -> Just unknown
254+ 718 -> Just circle
255+ 790 -> Just money
256+ 829 -> Just macaddr
257+ 869 -> Just inet
258+ 1042 -> Just bpchar
259+ 1043 -> Just varchar
260+ 1082 -> Just date
261+ 1083 -> Just time
262+ 1114 -> Just timestamp
263+ 1184 -> Just timestamptz
264+ 1186 -> Just interval
265+ 1266 -> Just timetz
266+ 1560 -> Just bit
267+ 1562 -> Just varbit
268+ 1700 -> Just numeric
269+ 1790 -> Just refcursor
270+ 2249 -> Just record
271+ 2278 -> Just void
272+ 2950 -> Just uuid
273+ _ -> Nothing
274+
275+bool :: ByteString
276+bool = "bool"
277+
278+bytea :: ByteString
279+bytea = "bytea"
280+
281+char :: ByteString
282+char = "char"
283+
284+name :: ByteString
285+name = "name"
286+
287+int8 :: ByteString
288+int8 = "int8"
289+
290+int2 :: ByteString
291+int2 = "int2"
292+
293+int4 :: ByteString
294+int4 = "int4"
295+
296+regproc :: ByteString
297+regproc = "regproc"
298+
299+text :: ByteString
300+text = "text"
301+
302+oid :: ByteString
303+oid = "oid"
304+
305+tid :: ByteString
306+tid = "tid"
307+
308+xid :: ByteString
309+xid = "xid"
310+
311+cid :: ByteString
312+cid = "cid"
313+
314+xml :: ByteString
315+xml = "xml"
316+
317+point :: ByteString
318+point = "point"
319+
320+lseg :: ByteString
321+lseg = "lseg"
322+
323+path :: ByteString
324+path = "path"
325+
326+box :: ByteString
327+box = "box"
328+
329+polygon :: ByteString
330+polygon = "polygon"
331+
332+line :: ByteString
333+line = "line"
334+
335+cidr :: ByteString
336+cidr = "cidr"
337+
338+float4 :: ByteString
339+float4 = "float4"
340+
341+float8 :: ByteString
342+float8 = "float8"
343+
344+abstime :: ByteString
345+abstime = "abstime"
346+
347+reltime :: ByteString
348+reltime = "reltime"
349+
350+tinterval :: ByteString
351+tinterval = "tinterval"
352+
353+unknown :: ByteString
354+unknown = "unknown"
355+
356+circle :: ByteString
357+circle = "circle"
358+
359+money :: ByteString
360+money = "money"
361+
362+macaddr :: ByteString
363+macaddr = "macaddr"
364+
365+inet :: ByteString
366+inet = "inet"
367+
368+bpchar :: ByteString
369+bpchar = "bpchar"
370+
371+varchar :: ByteString
372+varchar = "varchar"
373+
374+date :: ByteString
375+date = "date"
376+
377+time :: ByteString
378+time = "time"
379+
380+timestamp :: ByteString
381+timestamp = "timestamp"
382+
383+timestamptz :: ByteString
384+timestamptz = "timestamptz"
385+
386+interval :: ByteString
387+interval = "interval"
388+
389+timetz :: ByteString
390+timetz = "timetz"
391+
392+bit :: ByteString
393+bit = "bit"
394+
395+varbit :: ByteString
396+varbit = "varbit"
397+
398+numeric :: ByteString
399+numeric = "numeric"
400+
401+refcursor :: ByteString
402+refcursor = "refcursor"
403+
404+record :: ByteString
405+record = "record"
406+
407+void :: ByteString
408+void = "void"
409+
410+uuid :: ByteString
411+uuid = "uuid"
src/Database/PostgreSQL/Simple/Compat.hs+21−17
@@ -5,20 +5,19 @@ module Database.PostgreSQL.Simple.Compat
55 ( mask
66 , (<>)
77 , unsafeDupablePerformIO
8− , toByteString
9− , scientificBuilder
10− , toPico
11− , fromPico
128 ) where
139
1410import qualified Control.Exception as E
15−import Data.ByteString (ByteString)
16−import Data.ByteString.Lazy (toStrict)
17−import Data.ByteString.Builder (Builder, toLazyByteString)
18−import Data.Text.Lazy.Builder.Scientific (scientificBuilder)
11+import Data.Monoid
12+
13+#if __GLASGOW_HASKELL__ >= 702
1914import System.IO.Unsafe (unsafeDupablePerformIO)
20−import Data.Fixed (Pico)
21−import Data.Fixed (Fixed(MkFixed))
15+#elif __GLASGOW_HASKELL__ >= 611
16+import GHC.IO (unsafeDupablePerformIO)
17+#else
18+import GHC.IOBase (unsafeDupablePerformIO)
19+#endif
20+
2221
2322-- | Like 'E.mask', but backported to base before version 4.3.0.
2423--
@@ -28,14 +27,19 @@ import Data.Fixed (Fixed(MkFixed))
2827-- 'withTransactionMode' function calls the restore callback only once, so we
2928-- don't need that polymorphism.
3029mask :: ((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
3237{-# INLINE mask #-}
3338
34−toByteString :: Builder -> ByteString
35−toByteString x = toStrict (toLazyByteString x)
36−
37−toPico :: Integer -> Pico
38−toPico = MkFixed
39+#if !MIN_VERSION_base(4,5,0)
40+infixr 6 <>
3941
40−fromPico :: Pico -> Integer
41−fromPico (MkFixed i) = i
42+(<>) :: Monoid m => m -> m -> m
43+(<>) = mappend
44+{-# INLINE (<>) #-}
45+#endif
src/Database/PostgreSQL/Simple/Copy.hsdeleted−269
@@ -1,269 +0,0 @@
1−{-# LANGUAGE CPP, DeriveDataTypeable #-}
2−
3−------------------------------------------------------------------------------
4−-- |
5−-- Module: Database.PostgreSQL.Simple.Copy
6−-- Copyright: (c) 2013 Leon P Smith
7−-- License: BSD3
8−-- Maintainer: Leon P Smith <leon@melding-monads.com>
9−-- Stability: experimental
10−--
11−-- mid-level support for COPY IN and COPY OUT. See
12−-- <https://www.postgresql.org/docs/9.5/static/sql-copy.html> for
13−-- more information.
14−--
15−-- To use this binding, first call 'copy' with an appropriate
16−-- query as documented in the link above. Then, in the case of a
17−-- @COPY TO STDOUT@ query, call 'getCopyData' repeatedly until it
18−-- returns 'CopyOutDone'. In the case of a @COPY FROM STDIN@
19−-- query, call 'putCopyData' repeatedly and then finish by calling
20−-- either 'putCopyEnd' to proceed or 'putCopyError' to abort.
21−--
22−-- You cannot issue another query on the same connection while a copy
23−-- is ongoing; this will result in an exception. It is harmless to
24−-- concurrently call @getNotification@ on a connection while it is in
25−-- a @CopyIn@ or @CopyOut@ state, however be aware that current versions
26−-- of the PostgreSQL backend will not deliver notifications to a client
27−-- while a transaction is ongoing.
28−--
29−------------------------------------------------------------------------------
30−
31−module Database.PostgreSQL.Simple.Copy
32− ( copy
33− , copy_
34− , CopyOutResult(..)
35− , foldCopyData
36− , getCopyData
37− , putCopyData
38− , putCopyEnd
39− , putCopyError
40− ) where
41−
42−import Control.Applicative
43−import Control.Concurrent
44−import Control.Exception ( throwIO )
45−import qualified Data.Attoparsec.ByteString.Char8 as P
46−import Data.Typeable(Typeable)
47−import Data.Int(Int64)
48−import qualified Data.ByteString.Char8 as B
49−import qualified Database.PostgreSQL.LibPQ as PQ
50−import Database.PostgreSQL.Simple
51−import Database.PostgreSQL.Simple.Types
52−import Database.PostgreSQL.Simple.Internal hiding (result, row)
53−
54−
55−-- | Issue a @COPY FROM STDIN@ or @COPY TO STDOUT@ query. In the former
56−-- case, the connection's state will change to @CopyIn@; in the latter,
57−-- @CopyOut@. The connection must be in the ready state in order
58−-- to call this function. Performs parameter substitution.
59−
60−copy :: ( ToRow params ) => Connection -> Query -> params -> IO ()
61−copy conn template qs = do
62− q <- formatQuery conn template qs
63− doCopy "Database.PostgreSQL.Simple.Copy.copy" conn template q
64−
65−
66−-- | Issue a @COPY FROM STDIN@ or @COPY TO STDOUT@ query. In the former
67−-- case, the connection's state will change to @CopyIn@; in the latter,
68−-- @CopyOut@. The connection must be in the ready state in order
69−-- to call this function. Does not perform parameter subsitution.
70−
71−copy_ :: Connection -> Query -> IO ()
72−copy_ conn (Query q) = do
73− doCopy "Database.PostgreSQL.Simple.Copy.copy_" conn (Query q) q
74−
75−doCopy :: B.ByteString -> Connection -> Query -> B.ByteString -> IO ()
76−doCopy funcName conn template q = do
77− result <- exec conn q
78− status <- PQ.resultStatus result
79− let errMsg msg = throwIO $ QueryError
80− (B.unpack funcName ++ " " ++ msg)
81− template
82− let err = errMsg $ show status
83− case status of
84− PQ.EmptyQuery -> err
85− PQ.CommandOk -> err
86− PQ.TuplesOk -> err
87− PQ.CopyOut -> return ()
88− PQ.CopyIn -> return ()
89− PQ.CopyBoth -> errMsg "COPY BOTH is not supported"
90− PQ.SingleTuple -> errMsg "single-row mode is not supported"
91− PQ.BadResponse -> throwResultError funcName result status
92− PQ.NonfatalError -> throwResultError funcName result status
93− PQ.FatalError -> throwResultError funcName result status
94−
95−data CopyOutResult
96− = CopyOutRow !B.ByteString -- ^ Data representing either exactly
97− -- one row of the result, or header
98− -- or footer data depending on format.
99− | CopyOutDone {-# UNPACK #-} !Int64 -- ^ No more rows, and a count of the
100− -- number of rows returned.
101− deriving (Eq, Typeable, Show)
102−
103−
104−-- | Fold over @COPY TO STDOUT@ query passing each copied row to an accumulator
105−-- and calling a post-process at the end. A connection must be in the
106−-- @CopyOut@ state in order to call this function.
107−--
108−-- __Example__
109−--
110−-- > (acc, count) <- foldCopyData conn
111−-- > (\acc row -> return (row:acc))
112−-- > (\acc count -> return (acc, count))
113−-- > []
114−
115−foldCopyData
116− :: Connection -- ^ Database connection
117− -> (a -> B.ByteString -> IO a) -- ^ Accumulate one row of the result
118− -> (a -> Int64 -> IO b) -- ^ Post-process accumulator with a count of rows
119− -> a -- ^ Initial accumulator
120− -> IO b -- ^ Result
121−foldCopyData conn f g !acc = do
122− result <- getCopyData conn
123− case result of
124− CopyOutRow row -> f acc row >>= foldCopyData conn f g
125− CopyOutDone count -> g acc count
126−
127−
128−-- | Retrieve some data from a @COPY TO STDOUT@ query. A connection
129−-- must be in the @CopyOut@ state in order to call this function. If this
130−-- returns a 'CopyOutRow', the connection remains in the @CopyOut@ state,
131−-- if it returns 'CopyOutDone', then the connection has reverted to the
132−-- ready state.
133−
134−getCopyData :: Connection -> IO CopyOutResult
135−getCopyData conn = withConnection conn loop
136− where
137− funcName = "Database.PostgreSQL.Simple.Copy.getCopyData"
138− loop pqconn = do
139−#if defined(mingw32_HOST_OS)
140− row <- PQ.getCopyData pqconn False
141−#else
142− row <- PQ.getCopyData pqconn True
143−#endif
144− case row of
145− PQ.CopyOutRow rowdata -> return $! CopyOutRow rowdata
146− PQ.CopyOutDone -> CopyOutDone <$> getCopyCommandTag funcName pqconn
147−#if defined(mingw32_HOST_OS)
148− PQ.CopyOutWouldBlock -> do
149− fail (B.unpack funcName ++ ": the impossible happened")
150−#else
151− PQ.CopyOutWouldBlock -> do
152− mfd <- PQ.socket pqconn
153− case mfd of
154− Nothing -> throwIO (fdError funcName)
155− Just fd -> do
156− threadWaitRead fd
157− _ <- PQ.consumeInput pqconn
158− loop pqconn
159−#endif
160− PQ.CopyOutError -> do
161− mmsg <- PQ.errorMessage pqconn
162− throwIO SqlError {
163− sqlState = "",
164− sqlExecStatus = FatalError,
165− sqlErrorMsg = maybe "" id mmsg,
166− sqlErrorDetail = "",
167− sqlErrorHint = funcName
168− }
169−
170−
171−-- | Feed some data to a @COPY FROM STDIN@ query. Note that
172−-- the data does not need to represent a single row, or even an
173−-- integral number of rows. The net result of
174−-- @putCopyData conn a >> putCopyData conn b@
175−-- is the same as @putCopyData conn c@ whenever @c == BS.append a b@.
176−--
177−-- A connection must be in the @CopyIn@ state in order to call this
178−-- function, otherwise a 'SqlError' exception will result. The
179−-- connection remains in the @CopyIn@ state after this function
180−-- is called.
181−
182−putCopyData :: Connection -> B.ByteString -> IO ()
183−putCopyData conn dat = withConnection conn $ \pqconn -> do
184− doCopyIn funcName (\c -> PQ.putCopyData c dat) pqconn
185− where
186− funcName = "Database.PostgreSQL.Simple.Copy.putCopyData"
187−
188−
189−-- | Completes a @COPY FROM STDIN@ query. Returns the number of rows
190−-- processed.
191−--
192−-- A connection must be in the @CopyIn@ state in order to call this
193−-- function, otherwise a 'SqlError' exception will result. The
194−-- connection's state changes back to ready after this function
195−-- is called.
196−
197−putCopyEnd :: Connection -> IO Int64
198−putCopyEnd conn = withConnection conn $ \pqconn -> do
199− doCopyIn funcName (\c -> PQ.putCopyEnd c Nothing) pqconn
200− getCopyCommandTag funcName pqconn
201− where
202− funcName = "Database.PostgreSQL.Simple.Copy.putCopyEnd"
203−
204−
205−-- | Aborts a @COPY FROM STDIN@ query. The string parameter is simply
206−-- an arbitrary error message that may show up in the PostgreSQL
207−-- server's log.
208−--
209−-- A connection must be in the @CopyIn@ state in order to call this
210−-- function, otherwise a 'SqlError' exception will result. The
211−-- connection's state changes back to ready after this function
212−-- is called.
213−
214−putCopyError :: Connection -> B.ByteString -> IO ()
215−putCopyError conn err = withConnection conn $ \pqconn -> do
216− doCopyIn funcName (\c -> PQ.putCopyEnd c (Just err)) pqconn
217− consumeResults pqconn
218− where
219− funcName = "Database.PostgreSQL.Simple.Copy.putCopyError"
220−
221−
222−doCopyIn :: B.ByteString -> (PQ.Connection -> IO PQ.CopyInResult)
223− -> PQ.Connection -> IO ()
224−doCopyIn funcName action = loop
225− where
226− loop pqconn = do
227− stat <- action pqconn
228− case stat of
229− PQ.CopyInOk -> return ()
230− PQ.CopyInError -> do
231− mmsg <- PQ.errorMessage pqconn
232− throwIO SqlError {
233− sqlState = "",
234− sqlExecStatus = FatalError,
235− sqlErrorMsg = maybe "" id mmsg,
236− sqlErrorDetail = "",
237− sqlErrorHint = funcName
238− }
239− PQ.CopyInWouldBlock -> do
240− mfd <- PQ.socket pqconn
241− case mfd of
242− Nothing -> throwIO (fdError funcName)
243− Just fd -> do
244− threadWaitWrite fd
245− loop pqconn
246−{-# INLINE doCopyIn #-}
247−
248−getCopyCommandTag :: B.ByteString -> PQ.Connection -> IO Int64
249−getCopyCommandTag funcName pqconn = do
250− result <- maybe (fail errCmdStatus) return =<< PQ.getResult pqconn
251− cmdStat <- maybe (fail errCmdStatus) return =<< PQ.cmdStatus result
252− consumeResults pqconn
253− let rowCount = P.string "COPY " *> (P.decimal <* P.endOfInput)
254− case P.parseOnly rowCount cmdStat of
255− Left _ -> do mmsg <- PQ.errorMessage pqconn
256− fail $ errCmdStatusFmt
257− ++ maybe "" (\msg -> "\nConnection error: "++B.unpack msg) mmsg
258− Right n -> return $! n
259− where
260− errCmdStatus = B.unpack funcName ++ ": failed to fetch command status"
261− errCmdStatusFmt = B.unpack funcName ++ ": failed to parse command status"
262−
263−
264−consumeResults :: PQ.Connection -> IO ()
265−consumeResults pqconn = do
266− mres <- PQ.getResult pqconn
267− case mres of
268− Nothing -> return ()
269− Just _ -> consumeResults pqconn
src/Database/PostgreSQL/Simple/Cursor.hsdeleted−98
@@ -1,98 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−
3−------------------------------------------------------------------------------
4−-- |
5−-- Module: Database.PostgreSQL.Simple.Cursor
6−-- Copyright: (c) 2011-2012 Leon P Smith
7−-- (c) 2017 Bardur Arantsson
8−-- License: BSD3
9−-- Maintainer: Leon P Smith <leon@melding-monads.com>
10−--
11−------------------------------------------------------------------------------
12−
13−module Database.PostgreSQL.Simple.Cursor
14− (
15− -- * Types
16− Cursor
17− -- * Cursor management
18− , declareCursor
19− , closeCursor
20− -- * Folding over rows from a cursor
21− , foldForward
22− , foldForwardWithParser
23− ) where
24−
25−import Data.ByteString.Builder (intDec)
26−import Control.Applicative ((<$>))
27−import Control.Exception as E
28−import Control.Monad (unless, void)
29−import Data.Monoid (mconcat)
30−import Database.PostgreSQL.Simple.Compat ((<>), toByteString)
31−import Database.PostgreSQL.Simple.FromRow (FromRow(..))
32−import Database.PostgreSQL.Simple.Types (Query(..))
33−import Database.PostgreSQL.Simple.Internal as Base hiding (result, row)
34−import Database.PostgreSQL.Simple.Internal.PQResultUtils
35−import Database.PostgreSQL.Simple.Transaction
36−import qualified Database.PostgreSQL.LibPQ as PQ
37−
38−-- | Cursor within a transaction.
39−data Cursor = Cursor !Query !Connection
40−
41−-- | Declare a temporary cursor. The cursor is given a
42−-- unique name for the given connection.
43−declareCursor :: Connection -> Query -> IO Cursor
44−declareCursor conn q = do
45− name <- newTempName conn
46− void $ execute_ conn $ mconcat ["DECLARE ", name, " NO SCROLL CURSOR FOR ", q]
47− return $ Cursor name conn
48−
49−-- | Close the given cursor.
50−closeCursor :: Cursor -> IO ()
51−closeCursor (Cursor name conn) =
52− (void $ execute_ conn ("CLOSE " <> name)) `E.catch` \ex ->
53− -- Don't throw exception if CLOSE failed because the transaction is
54− -- aborted. Otherwise, it will throw away the original error.
55− unless (isFailedTransactionError ex) $ throwIO ex
56−
57−-- | Fold over a chunk of rows from the given cursor, calling the
58−-- supplied fold-like function on each row as it is received. In case
59−-- the cursor is exhausted, a 'Left' value is returned, otherwise a
60−-- 'Right' value is returned.
61−foldForwardWithParser :: Cursor -> RowParser r -> Int -> (a -> r -> IO a) -> a -> IO (Either a a)
62−foldForwardWithParser (Cursor name conn) parser chunkSize f a0 = do
63− let q = "FETCH FORWARD "
64− <> (toByteString $ intDec chunkSize)
65− <> " FROM "
66− <> fromQuery name
67− result <- exec conn q
68− status <- PQ.resultStatus result
69− case status of
70− PQ.TuplesOk -> do
71− nrows <- PQ.ntuples result
72− ncols <- PQ.nfields result
73− if nrows > 0
74− then do
75− let inner a row = do
76− x <- getRowWith parser row ncols conn result
77− f a x
78− Right <$> foldM' inner a0 0 (nrows - 1)
79− else
80− return $ Left a0
81− _ -> throwResultError "foldForwardWithParser" result status
82−
83−-- | Fold over a chunk of rows, calling the supplied fold-like function
84−-- on each row as it is received. In case the cursor is exhausted,
85−-- a 'Left' value is returned, otherwise a 'Right' value is returned.
86−foldForward :: FromRow r => Cursor -> Int -> (a -> r -> IO a) -> a -> IO (Either a a)
87−foldForward cursor = foldForwardWithParser cursor fromRow
88−
89−
90−foldM' :: (Ord n, Num n) => (a -> n -> IO a) -> a -> n -> n -> IO a
91−foldM' f a lo hi = loop a lo
92− where
93− loop x !n
94− | n > hi = return x
95− | otherwise = do
96− x' <- f x n
97− loop x' (n+1)
98−{-# INLINE foldM' #-}
src/Database/PostgreSQL/Simple/Errors.hs+20−50
@@ -1,16 +1,8 @@
11{-# LANGUAGE DeriveDataTypeable #-}
22{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE RecordWildCards #-}
4−------------------------------------------------------------------------------
5−-- |
6−-- Module: Database.PostgreSQL.Simple.Errors
7−-- Copyright: (c) 2012-2013 Leonid Onokhov, Joey Adams
8−-- License: BSD3
9−-- Maintainer: Leon P Smith <leon@melding-monads.com>
10−-- Stability: experimental
11−--
12−-- | Module for parsing errors from postgresql error messages.
13−-- Currently only parses integrity violation errors (class 23).
3+
4+-- | Module for parsing errors from posgresql error messages.
5+-- Currently in only parses integrity violation errors (class 23).
146--
157-- /Note: Success of parsing may depend on language settings./
168----------------------------------------------------------
@@ -19,15 +11,15 @@ module Database.PostgreSQL.Simple.Errors
1911 , constraintViolation
2012 , constraintViolationE
2113 , catchViolation
22− , isSerializationError
23− , isNoActiveTransactionError
24− , isFailedTransactionError
2514 )
2615 where
2716
28−import Control.Exception as E
17+import Prelude hiding (catch)
18+
19+import Control.Applicative
20+import Control.Exception
2921
30−import Data.Attoparsec.ByteString.Char8
22+import Data.Attoparsec.Char8
3123import Data.ByteString (ByteString)
3224import Data.Typeable
3325
@@ -54,23 +46,19 @@ data ConstraintViolation
5446 -- ^ Name of violated constraint
5547 | CheckViolation ByteString ByteString
5648 -- ^ Relation name (usually table), constraint name
57− | ExclusionViolation ByteString
58− -- ^ Name of the exclusion violation constraint
5949 deriving (Show, Eq, Ord, Typeable)
6050
6151-- Default instance should be enough
62−instance Exception ConstraintViolation where
63− toException = postgresqlExceptionToException
64− fromException = postgresqlExceptionFromException
52+instance Exception ConstraintViolation
6553
6654
6755-- | Tries to convert 'SqlError' to 'ConstrainViolation', checks sqlState and
68−-- succeeds only if able to parse sqlErrorMsg.
56+-- succeedes only if able to parse sqlErrorMsg.
6957--
70−-- > createUser = handleJust constraintViolation handler $ execute conn ...
58+-- > createUser = catchJust constraintViolation catcher $ execute conn ...
7159-- > where
72−-- > handler (UniqueViolation "user_login_key") = ...
73−-- > handler _ = ...
60+-- > catcher UniqueViolation "user_login_key" = ...
61+-- > catcher _ = ...
7462constraintViolation :: SqlError -> Maybe ConstraintViolation
7563constraintViolation e =
7664 case sqlState e of
@@ -78,31 +66,30 @@ constraintViolation e =
7866 "23503" -> uncurry ForeignKeyViolation <$> parseMaybe parseQ2 msg
7967 "23505" -> UniqueViolation <$> parseMaybe parseQ1 msg
8068 "23514" -> uncurry CheckViolation <$> parseMaybe parseQ2 msg
81− "23P01" -> ExclusionViolation <$> parseMaybe parseQ1 msg
8269 _ -> Nothing
8370 where msg = sqlErrorMsg e
8471
8572
8673-- | Like constraintViolation, but also packs original SqlError.
8774--
88−-- > createUser = handleJust constraintViolationE handler $ execute conn ...
75+-- > createUser = catchJust constraintViolationE catcher $ execute conn ...
8976-- > where
90−-- > handler (_, UniqueViolation "user_login_key") = ...
91−-- > handler (e, _) = throwIO e
77+-- > catcher (_, UniqueViolation "user_login_key") = ...
78+-- > catcher (e, _) = throw e
9279--
9380constraintViolationE :: SqlError -> Maybe (SqlError, ConstraintViolation)
9481constraintViolationE e = fmap ((,) e) $ constraintViolation e
9582
9683-- | Catches SqlError, tries to convert to ConstraintViolation, re-throws
97−-- on fail. Provides alternative interface to 'E.handleJust'
84+-- on fail. Provides alternative interface to catchJust
9885--
9986-- > createUser = catchViolation catcher $ execute conn ...
10087-- > where
10188-- > catcher _ (UniqueViolation "user_login_key") = ...
102−-- > catcher e _ = throwIO e
89+-- > catcher e _ = throw e
10390catchViolation :: (SqlError -> ConstraintViolation -> IO a) -> IO a -> IO a
104−catchViolation f m = E.catch m
105− (\e -> maybe (throwIO e) (f e) $ constraintViolation e)
91+catchViolation f m = catch m
92+ (\e -> maybe (throw e) (f e) $ constraintViolation e)
10693
10794-- Parsers just try to extract quoted strings from error messages, number
10895-- of quoted strings depend on error type.
@@ -121,20 +108,3 @@ parseQ2 = (,) <$> parseQ1 <*> parseQ1
121108
122109parseMaybe :: Parser a -> ByteString -> Maybe a
123110parseMaybe p b = either (const Nothing) Just $ parseOnly p b
124−
125−------------------------------------------------------------------------
126−-- Error predicates
127−--
128−-- https://www.postgresql.org/docs/9.5/static/errcodes-appendix.html
129−
130−isSerializationError :: SqlError -> Bool
131−isSerializationError = isSqlState "40001"
132−
133−isNoActiveTransactionError :: SqlError -> Bool
134−isNoActiveTransactionError = isSqlState "25P01"
135−
136−isFailedTransactionError :: SqlError -> Bool
137−isFailedTransactionError = isSqlState "25P02"
138−
139−isSqlState :: ByteString -> SqlError -> Bool
140−isSqlState s SqlError{..} = sqlState == s
src/Database/PostgreSQL/Simple/FromField.hs+152−437
@@ -2,84 +2,62 @@
22{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
33{-# LANGUAGE PatternGuards, ScopedTypeVariables #-}
44{-# LANGUAGE RecordWildCards #-}
5−{-# LANGUAGE PolyKinds #-}
6−
7−{- |
8−Module: Database.PostgreSQL.Simple.FromField
9−Copyright: (c) 2011 MailRank, Inc.
10− (c) 2011-2013 Leon P Smith
11−License: BSD3
12−Maintainer: Leon P Smith <leon@melding-monads.com>
13−Stability: experimental
14−
15−The 'FromField' typeclass, for converting a single value in a row
16−returned by a SQL query into a more useful Haskell representation.
17−Note that each instance of 'FromField' is documented by a list of
18−compatible postgresql types.
19−
20−A Haskell numeric type is considered to be compatible with all
21−PostgreSQL numeric types that are less accurate than it. For instance,
22−the Haskell 'Double' type is compatible with the PostgreSQL's 32-bit
23−@int@ type because it can represent a @int@ exactly. On the other hand,
24−since a 'Double' might lose precision if representing PostgreSQL's 64-bit
25−@bigint@, the two are /not/ considered compatible.
26−
27−Note that the 'Float' and 'Double' instances use attoparsec's 'double'
28−conversion routine, which sacrifices some accuracy for speed. If you
29−need accuracy, consider first converting data to a 'Scientific' or 'Rational'
30−type, and then converting to a floating-point type. If you are defining
31−your own 'Database.PostgreSQL.Simple.FromRow.FromRow' instances, this can be
32−achieved simply by
33−@'fromRational' '<$>' 'Database.PostgreSQL.Simple.FromRow.field'@, although
34−this idiom is additionally compatible with PostgreSQL's @int8@ and @numeric@
35−types. If this is unacceptable, you may find
36−'Database.PostgreSQL.Simple.FromRow.fieldWith' useful.
37−
38−Also note that while converting to a 'Double' through the 'Scientific' type
39−is likely somewhat faster than converting through the 'Rational' type,
40−the 'Scientific' type has no way to represent @NaN@ and @±Infinity@ values.
41−Thus, if you need precision conversion of regular floating point values
42−and the possibility of receiving these special values from the backend,
43−stick with 'Rational'.
44−
45−Because 'FromField' is a typeclass, one may provide conversions to
46−additional Haskell types without modifying postgresql-simple. This is
47−particularly useful for supporting PostgreSQL types that postgresql-simple
48−does not support out-of-box. Here's an example of what such an instance
49−might look like for a UUID type that implements the @Read@ class:
50−
51−@
52−import Data.UUID ( UUID )
53−import Database.PostgreSQL.Simple.FromField
54− ( FromField (fromField) , typeOid, returnError, ResultError (..) )
55−import Database.PostgreSQL.Simple.TypeInfo.Static (typoid, uuid)
56−import qualified Data.ByteString.Char8 as B
57−
58−instance FromField UUID where
59− fromField f mdata =
60− if typeOid f /= typoid uuid
61− then returnError Incompatible f \"\"
62− else case B.unpack \`fmap\` mdata of
63− Nothing -> returnError UnexpectedNull f \"\"
64− Just dat ->
65− case [ x | (x,t) <- reads dat, (\"\",\"\") <- lex t ] of
66− [x] -> return x
67− _ -> returnError ConversionFailed f dat
68−@
69−
70−Note that because PostgreSQL's @uuid@ type is built into postgres and is
71−not provided by an extension, the 'typeOid' of @uuid@ does not change and
72−thus we can examine it directly. One could hard-code the type oid, or
73−obtain it by other means, but in this case we simply pull it out of the
74−static table provided by postgresql-simple.
75−
76−On the other hand if the type is provided by an extension, such as
77−@PostGIS@ or @hstore@, then the 'typeOid' is not stable and can vary from
78−database to database. In this case it is recommended that FromField
79−instances use 'typename' instead.
80−
81−-}
825
6+------------------------------------------------------------------------------
7+-- |
8+-- Module: Database.PostgreSQL.Simple.FromField
9+-- Copyright: (c) 2011 MailRank, Inc.
10+-- (c) 2011-2012 Leon P Smith
11+-- License: BSD3
12+-- Maintainer: Leon P Smith <leon@melding-monads.com>
13+-- Stability: experimental
14+-- Portability: portable
15+--
16+-- The 'FromField' typeclass, for converting a single value in a row
17+-- returned by a SQL query into a more useful Haskell representation.
18+--
19+-- A Haskell numeric type is considered to be compatible with all
20+-- PostgreSQL numeric types that are less accurate than it. For instance,
21+-- the Haskell 'Double' type is compatible with the PostgreSQL's 32-bit
22+-- @int@ type because it can represent a @int@ exactly. On the other hand,
23+-- since a 'Double' might lose precision if representing PostgreSQL's 64-bit
24+-- @bigint@, the two are /not/ considered compatible.
25+--
26+-- Because 'FromField' is a typeclass, one may provide conversions to
27+-- additional Haskell types without modifying postgresql-simple. This is
28+-- particularly useful for supporting PostgreSQL types that postgresql-simple
29+-- does not support out-of-box. Here's an example of what such an instance
30+-- might look like for a UUID type that implements the @Read@ class:
31+--
32+-- @
33+-- import Data.UUID ( UUID )
34+-- import Database.PostgreSQL.Simple.BuiltinTypes
35+-- ( BuiltinType(UUID), builtin2oid )
36+-- import qualified Data.ByteString as B
37+--
38+-- instance FromField UUID where
39+-- fromField f mdata =
40+-- if typeOid f /= builtin2oid UUID
41+-- then returnError Incompatible f ""
42+-- else case B.unpack `fmap` mdata of
43+-- Nothing -> returnError UnexpectedNull f ""
44+-- Just data ->
45+-- case [ x | (x,t) <- reads data, ("","") <- lex t ] of
46+-- [x] -> Ok x
47+-- _ -> returnError ConversionError f data
48+-- @
49+--
50+-- Note that because PostgreSQL's @uuid@ type is built into postgres and is
51+-- not provided by an extension, the 'typeOid' of @uuid@ does not change and
52+-- thus we can examine it directly. Here, we simply pull the type oid out
53+-- of the static table provided by postgresql-simple.
54+--
55+-- On the other hand if the type is provided by an extension, such as
56+-- @PostGIS@ or @hstore@, then the 'typeOid' is not stable and can vary from
57+-- database to database. In this case it is recommended that FromField
58+-- instances use 'typename' instead.
59+--
60+------------------------------------------------------------------------------
8361
8462module Database.PostgreSQL.Simple.FromField
8563 (
@@ -95,10 +73,7 @@ module Database.PostgreSQL.Simple.FromField
9573
9674 , Field
9775 , typename
98− , TypeInfo(..)
99− , Attribute(..)
100− , typeInfo
101− , typeInfoByOid
76+ , typeinfo
10277 , name
10378 , tableOid
10479 , tableColumn
@@ -106,40 +81,34 @@ module Database.PostgreSQL.Simple.FromField
10681 , typeOid
10782 , PQ.Oid(..)
10883 , PQ.Format(..)
109− , pgArrayFieldParser
110− , attoFieldParser
111−
112− , optionalField
113− , fromJSONField
114− , fromFieldJSONByteString
11584 ) where
11685
11786#include "MachDeps.h"
11887
119−import Control.Applicative ( Const(Const), (<|>), (<$>), pure, (*>), (<*) )
120−import Control.Concurrent.MVar (MVar, newMVar)
121−import Control.Exception (Exception (toException, fromException))
122−import qualified Data.Aeson as JSON
123−import Data.Attoparsec.ByteString.Char8 hiding (Result)
88+import Control.Applicative
89+ ( Applicative, (<|>), (<$>), pure )
90+import Control.Exception (Exception)
91+import Data.Attoparsec.Char8 hiding (Result)
92+import Data.Bits ((.&.), (.|.), shiftL)
12493import Data.ByteString (ByteString)
12594import qualified Data.ByteString.Char8 as B
126−import Data.Functor.Identity (Identity(Identity))
12795import Data.Int (Int16, Int32, Int64)
128−import Data.IORef (IORef, newIORef)
96+import Data.List (foldl')
97+import Data.Maybe (fromMaybe)
12998import Data.Ratio (Ratio)
130−import Data.Time.Compat ( UTCTime, ZonedTime, LocalTime, Day, TimeOfDay, CalendarDiffTime )
99+import Data.Time ( UTCTime, ZonedTime, LocalTime, Day, TimeOfDay )
131100import Data.Typeable (Typeable, typeOf)
132101import Data.Vector (Vector)
133−import Data.Vector.Mutable (IOVector)
134102import qualified Data.Vector as V
103+import Data.Word (Word64)
135104import Database.PostgreSQL.Simple.Internal
105+import Database.PostgreSQL.Simple.BuiltinTypes
136106import Database.PostgreSQL.Simple.Compat
137107import Database.PostgreSQL.Simple.Ok
138−import Database.PostgreSQL.Simple.Types
139−import Database.PostgreSQL.Simple.TypeInfo as TI
140−import qualified Database.PostgreSQL.Simple.TypeInfo.Static as TI
108+import Database.PostgreSQL.Simple.Types (Binary(..), Null(..))
109+import Database.PostgreSQL.Simple.TypeInfo
141110import Database.PostgreSQL.Simple.Time
142−import Database.PostgreSQL.Simple.Arrays as Arrays
111+import Database.PostgreSQL.Simple.Arrays
143112import qualified Database.PostgreSQL.LibPQ as PQ
144113import qualified Data.ByteString as SB
145114import qualified Data.ByteString.Char8 as B8
@@ -147,14 +116,6 @@ import qualified Data.ByteString.Lazy as LB
147116import qualified Data.Text as ST
148117import qualified Data.Text.Encoding as ST
149118import qualified Data.Text.Lazy as LT
150−import Data.CaseInsensitive (CI)
151−import qualified Data.CaseInsensitive as CI
152−import Data.UUID.Types (UUID)
153−import qualified Data.UUID.Types as UUID
154−import Data.Scientific (Scientific)
155−import GHC.Real (infinity, notANumber)
156−
157−import qualified Data.Aeson.Types as JSON
158119
159120-- | Exception thrown if conversion from a SQL value to a Haskell
160121-- value fails.
@@ -182,9 +143,7 @@ data ResultError = Incompatible { errSQLType :: String
182143 -- between metadata and actual data in a row).
183144 deriving (Eq, Show, Typeable)
184145
185−instance Exception ResultError where
186− toException = postgresqlExceptionToException
187− fromException = postgresqlExceptionFromException
146+instance Exception ResultError
188147
189148left :: Exception a => a -> Conversion b
190149left = conversionError
@@ -200,15 +159,14 @@ class FromField a where
200159 -- library instances, this will usually be a single 'ResultError', but
201160 -- may be a 'UnicodeException'.
202161 --
203− -- Note that retaining any reference to the 'Field' argument causes
204− -- the entire @LibPQ.'PQ.Result'@ to be retained. Thus, implementations
205− -- of 'fromField' should return results that do not refer to this value
206− -- after the result have been evaluated to WHNF.
162+ -- Implementations of 'fromField' should not retain any references to
163+ -- the 'Field' nor the 'ByteString' arguments after the result has
164+ -- been evaluated to WHNF. Such a reference causes the entire
165+ -- @LibPQ.'PQ.Result'@ to be retained.
207166 --
208− -- Note that as of @postgresql-simple-0.4.0.0@, the 'ByteString' value
209− -- has already been copied out of the @LibPQ.'PQ.Result'@ before it has
210− -- been passed to 'fromField'. This is because for short strings, it's
211− -- cheaper to copy the string than to set up a finalizer.
167+ -- For example, the instance for 'ByteString' uses 'B.copy' to avoid
168+ -- such a reference, and that using bytestring functions such as 'B.drop'
169+ -- and 'B.takeWhile' alone will also trigger this memory leak.
212170
213171-- | Returns the data type name. This is the preferred way of identifying
214172-- types that do not have a stable type oid, such as types provided by
@@ -216,20 +174,16 @@ class FromField a where
216174--
217175-- More concretely, it returns the @typname@ column associated with the
218176-- type oid in the @pg_type@ table. First, postgresql-simple will check
219−-- the built-in, static table. If the type oid is not there,
220−-- postgresql-simple will check a per-connection cache, and then
221−-- finally query the database's meta-schema.
177+-- built-in, static table. If the type oid is not there, postgresql-simple
178+-- will check a per-connection cache, and then finally query the database's
179+-- meta-schema.
222180
223181typename :: Field -> Conversion ByteString
224−typename field = typname <$> typeInfo field
225−
226−typeInfo :: Field -> Conversion TypeInfo
227−typeInfo Field{..} = Conversion $ \conn -> do
228− Ok <$> (getTypeInfo conn typeOid)
182+typename field = typname . typ <$> typeinfo field
229183
230−typeInfoByOid :: PQ.Oid -> Conversion TypeInfo
231−typeInfoByOid oid = Conversion $ \conn -> do
232− Ok <$> (getTypeInfo conn oid)
184+typeinfo :: Field -> Conversion TypeInfo
185+typeinfo Field{..} = Conversion $ \conn -> do
186+ Ok <$> (getTypeInfo conn =<< PQ.ftype result column)
233187
234188-- | Returns the name of the column. This is often determined by a table
235189-- definition, but it can be set using an @as@ clause.
@@ -250,11 +204,9 @@ tableOid Field{..} = toMaybeOid (unsafeDupablePerformIO (PQ.ftable result column
250204 then Nothing
251205 else Just x
252206
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@.
207+-- | If the column has a table associated with it, this returns the number
208+-- of the associated table column. Numbering starts from 0. Analogous
209+-- to libpq's @PQftablecol@.
258210
259211tableColumn :: Field -> Int
260212tableColumn Field{..} = fromCol (unsafeDupablePerformIO (PQ.ftablecol result column))
@@ -267,245 +219,122 @@ tableColumn Field{..} = fromCol (unsafeDupablePerformIO (PQ.ftablecol result col
267219format :: Field -> PQ.Format
268220format Field{..} = unsafeDupablePerformIO (PQ.fformat result column)
269221
270−-- | void
271−instance FromField () where
272− fromField f _bs
273− | typeOid f /= TI.voidOid = returnError Incompatible f ""
274− | otherwise = pure ()
275−
276−instance (FromField a) => FromField (Const a b) where
277− fromField f bs = Const <$> fromField f bs
278−
279−instance (FromField a) => FromField (Identity a) where
280− fromField f bs = Identity <$> fromField f bs
281−
282−-- | For dealing with null values. Compatible with any postgresql type
283−-- compatible with type @a@. Note that the type is not checked if
284−-- the value is null, although it is inadvisable to rely on this
285−-- behavior.
286−instance FromField a => FromField (Maybe a) where
287− fromField = optionalField fromField
288−
289−-- | For dealing with SQL @null@ values outside of the 'FromField' class.
290−-- Alternatively, one could use 'Control.Applicative.optional', but that
291−-- also turns type and conversion errors into 'Nothing', whereas this is
292−-- more specific and turns only @null@ values into 'Nothing'.
293−
294−optionalField :: FieldParser a -> FieldParser (Maybe a)
295−optionalField p f mv =
296− case mv of
297− Nothing -> pure Nothing
298− Just _ -> Just <$> p f mv
299−{-# INLINE optionalField #-}
300−
301−-- | compatible with any data type, but the value must be null
222+instance (FromField a) => FromField (Maybe a) where
223+ fromField _ Nothing = pure Nothing
224+ fromField f bs = Just <$> fromField f bs
225+
302226instance FromField Null where
303227 fromField _ Nothing = pure Null
304228 fromField f (Just _) = returnError ConversionFailed f "data is not null"
305229
306−-- | bool
307230instance FromField Bool where
308231 fromField f bs
309− | typeOid f /= TI.boolOid = returnError Incompatible f ""
232+ | typeOid f /= builtin2oid Bool = returnError Incompatible f ""
310233 | bs == Nothing = returnError UnexpectedNull f ""
311234 | bs == Just "t" = pure True
312235 | bs == Just "f" = pure False
313236 | otherwise = returnError ConversionFailed f ""
314237
315−-- | \"char\", bpchar
316−instance FromField Char where
317− fromField f bs0 =
318− if (eq TI.charOid \/ eq TI.bpcharOid) (typeOid f)
319− then case bs0 of
320− Nothing -> returnError UnexpectedNull f ""
321− Just bs -> if B.length bs /= 1
322− then returnError ConversionFailed f "length not 1"
323− else return $! (B.head bs)
324− else returnError Incompatible f ""
325−
326−-- | int2
327238instance FromField Int16 where
328− fromField = attoFieldParser ok16 $ signed decimal
239+ fromField = atto ok16 $ signed decimal
329240
330−-- | int2, int4
331241instance FromField Int32 where
332− fromField = attoFieldParser ok32 $ signed decimal
242+ fromField = atto ok32 $ signed decimal
333243
334−#if WORD_SIZE_IN_BITS < 64
335−-- | int2, int4, and if compiled as 64-bit code, int8 as well.
336−-- This library was compiled as 32-bit code.
337−#else
338−-- | int2, int4, and if compiled as 64-bit code, int8 as well.
339−-- This library was compiled as 64-bit code.
340−#endif
341244instance FromField Int where
342− fromField = attoFieldParser okInt $ signed decimal
245+ fromField = atto okInt $ signed decimal
343246
344−-- | int2, int4, int8
345247instance FromField Int64 where
346− fromField = attoFieldParser ok64 $ signed decimal
248+ fromField = atto ok64 $ signed decimal
347249
348−-- | int2, int4, int8
349250instance FromField Integer where
350− fromField = attoFieldParser ok64 $ signed decimal
251+ fromField = atto ok64 $ signed decimal
351252
352−-- | int2, float4 (Uses attoparsec's 'double' routine, for
353−-- better accuracy convert to 'Scientific' or 'Rational' first)
354253instance FromField Float where
355− fromField = attoFieldParser ok (realToFrac <$> pg_double)
356− where ok = eq TI.float4Oid \/ eq TI.int2Oid
254+ fromField = atto ok (realToFrac <$> double)
255+ where ok = mkCompats [Float4,Int2]
357256
358−-- | int2, int4, float4, float8 (Uses attoparsec's 'double' routine, for
359−-- better accuracy convert to 'Scientific' or 'Rational' first)
360257instance FromField Double where
361− fromField = attoFieldParser ok pg_double
362− where ok = eq TI.float4Oid \/ eq TI.float8Oid \/ eq TI.int2Oid \/ eq TI.int4Oid
258+ fromField = atto ok double
259+ where ok = mkCompats [Float4,Float8,Int2,Int4]
363260
364−-- | int2, int4, int8, float4, float8, numeric
365261instance FromField (Ratio Integer) where
366− fromField = attoFieldParser ok pg_rational
367− where ok = eq TI.float4Oid \/ eq TI.float8Oid \/ eq TI.int2Oid \/ eq TI.int4Oid \/ eq TI.int8Oid \/ eq TI.numericOid
368−
369−-- | int2, int4, int8, float4, float8, numeric
370−instance FromField Scientific where
371− fromField = attoFieldParser ok rational
372− where ok = eq TI.float4Oid \/ eq TI.float8Oid \/ eq TI.int2Oid \/ eq TI.int4Oid \/ eq TI.int8Oid \/ eq TI.numericOid
262+ fromField = atto ok rational
263+ where ok = mkCompats [Float4,Float8,Int2,Int4,Numeric]
373264
374265unBinary :: Binary t -> t
375266unBinary (Binary x) = x
376267
377−pg_double :: Parser Double
378−pg_double
379− = (string "NaN" *> pure ( 0 / 0))
380− <|> (string "Infinity" *> pure ( 1 / 0))
381− <|> (string "-Infinity" *> pure (-1 / 0))
382− <|> double
383−
384−pg_rational :: Parser Rational
385−pg_rational
386− = (string "NaN" *> pure notANumber )
387− <|> (string "Infinity" *> pure infinity )
388− <|> (string "-Infinity" *> pure (-infinity))
389− <|> rational
390−
391−-- | bytea, name, text, \"char\", bpchar, varchar, unknown
392268instance FromField SB.ByteString where
393− fromField f dat = if typeOid f == TI.byteaOid
269+ fromField f dat = if typeOid f == builtin2oid ByteA
394270 then unBinary <$> fromField f dat
395− else doFromField f okText' pure dat
271+ else doFromField f okText' (pure . B.copy) dat
396272
397−-- | oid
398273instance FromField PQ.Oid where
399− fromField f dat = PQ.Oid <$> attoFieldParser (== TI.oidOid) decimal f dat
274+ fromField f dat = PQ.Oid <$> atto (mkCompat Oid) decimal f dat
400275
401−-- | bytea, name, text, \"char\", bpchar, varchar, unknown
402276instance FromField LB.ByteString where
403277 fromField f dat = LB.fromChunks . (:[]) <$> fromField f dat
404278
405279unescapeBytea :: Field -> SB.ByteString
406280 -> Conversion (Binary SB.ByteString)
407−unescapeBytea f str' = case unsafeDupablePerformIO (PQ.unescapeBytea str') of
281+unescapeBytea f str = case unsafeDupablePerformIO (PQ.unescapeBytea str) of
408282 Nothing -> returnError ConversionFailed f "unescapeBytea failed"
409283 Just str -> pure (Binary str)
410284
411−-- | bytea
412285instance FromField (Binary SB.ByteString) where
413286 fromField f dat = case format f of
414287 PQ.Text -> doFromField f okBinary (unescapeBytea f) dat
415− PQ.Binary -> doFromField f okBinary (pure . Binary) dat
288+ PQ.Binary -> doFromField f okBinary (pure . Binary . B.copy) dat
416289
417−-- | bytea
418290instance FromField (Binary LB.ByteString) where
419291 fromField f dat = Binary . LB.fromChunks . (:[]) . unBinary <$> fromField f dat
420292
421−-- | name, text, \"char\", bpchar, varchar
422293instance FromField ST.Text where
423294 fromField f = doFromField f okText $ (either left pure . ST.decodeUtf8')
424295 -- FIXME: check character encoding
425296
426−-- | name, text, \"char\", bpchar, varchar
427297instance FromField LT.Text where
428298 fromField f dat = LT.fromStrict <$> fromField f dat
429299
430−-- | citext
431−instance FromField (CI ST.Text) where
432− fromField f mdat = do
433− typ <- typename f
434− if typ /= "citext"
435− then returnError Incompatible f ""
436− else case mdat of
437− Nothing -> returnError UnexpectedNull f ""
438− Just dat -> either left (pure . CI.mk)
439− (ST.decodeUtf8' dat)
440−
441−-- | citext
442−instance FromField (CI LT.Text) where
443− fromField f mdat = do
444− typ <- typename f
445− if typ /= "citext"
446− then returnError Incompatible f ""
447− else case mdat of
448− Nothing -> returnError UnexpectedNull f ""
449− Just dat -> either left (pure . CI.mk . LT.fromStrict)
450− (ST.decodeUtf8' dat)
451−
452−-- | name, text, \"char\", bpchar, varchar
453300instance FromField [Char] where
454301 fromField f dat = ST.unpack <$> fromField f dat
455302
456−-- | timestamptz
457303instance FromField UTCTime where
458− fromField = ff TI.timestamptzOid "UTCTime" parseUTCTime
304+ fromField = ff TimestampTZ "UTCTime" parseUTCTime
459305
460−-- | timestamptz
461306instance FromField ZonedTime where
462− fromField = ff TI.timestamptzOid "ZonedTime" parseZonedTime
307+ fromField = ff TimestampTZ "ZonedTime" parseZonedTime
463308
464−-- | timestamp
465309instance FromField LocalTime where
466− fromField = ff TI.timestampOid "LocalTime" parseLocalTime
310+ fromField = ff Timestamp "LocalTime" parseLocalTime
467311
468−-- | date
469312instance FromField Day where
470− fromField = ff TI.dateOid "Day" parseDay
313+ fromField = ff Date "Day" parseDay
471314
472−-- | time
473315instance FromField TimeOfDay where
474− fromField = ff TI.timeOid "TimeOfDay" parseTimeOfDay
316+ fromField = ff Time "TimeOfDay" parseTimeOfDay
475317
476−-- | timestamptz
477318instance FromField UTCTimestamp where
478− fromField = ff TI.timestamptzOid "UTCTimestamp" parseUTCTimestamp
319+ fromField = ff TimestampTZ "UTCTimestamp" parseUTCTimestamp
479320
480−-- | timestamptz
481321instance FromField ZonedTimestamp where
482− fromField = ff TI.timestamptzOid "ZonedTimestamp" parseZonedTimestamp
322+ fromField = ff TimestampTZ "ZonedTimestamp" parseZonedTimestamp
483323
484−-- | timestamp
485324instance FromField LocalTimestamp where
486− fromField = ff TI.timestampOid "LocalTimestamp" parseLocalTimestamp
325+ fromField = ff Timestamp "LocalTimestamp" parseLocalTimestamp
487326
488−-- | date
489327instance FromField Date where
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
328+ fromField = ff Date "Date" parseDate
500329
501−ff :: PQ.Oid -> String -> (B8.ByteString -> Either String a)
330+ff :: BuiltinType -> String -> (B8.ByteString -> Either String a)
502331 -> Field -> Maybe B8.ByteString -> Conversion a
503−ff compatOid hsType parseBS f mstr =
504− if typeOid f /= compatOid
332+ff pgType hsType parse f mstr =
333+ if typeOid f /= builtin2oid pgType
505334 then err Incompatible ""
506335 else case mstr of
507336 Nothing -> err UnexpectedNull ""
508− Just str -> case parseBS str of
337+ Just str -> case parse str of
509338 Left msg -> err ConversionFailed msg
510339 Right val -> return val
511340 where
@@ -518,153 +347,51 @@ ff compatOid hsType parseBS f mstr =
518347 msg
519348{-# INLINE ff #-}
520349
521−-- | Compatible with both types. Conversions to type @b@ are
522−-- preferred, the conversion to type @a@ will be tried after
523−-- the 'Right' conversion fails.
524350instance (FromField a, FromField b) => FromField (Either a b) where
525351 fromField f dat = (Right <$> fromField f dat)
526352 <|> (Left <$> fromField f dat)
527353
528−-- | any postgresql array whose elements are compatible with type @a@
529−instance (FromField a, Typeable a) => FromField (PGArray a) where
530− fromField = pgArrayFieldParser fromField
531−
532−pgArrayFieldParser :: Typeable a => FieldParser a -> FieldParser (PGArray a)
533−pgArrayFieldParser fieldParser f mdat = do
534− info <- typeInfo f
535− case info of
536− TI.Array{} ->
537− case mdat of
538− Nothing -> returnError UnexpectedNull f ""
539− Just dat -> do
540− case parseOnly (fromArray fieldParser info f) dat of
541− Left err -> returnError ConversionFailed f err
542− Right conv -> PGArray <$> conv
543− _ -> returnError Incompatible f ""
544−
545−fromArray :: FieldParser a -> TypeInfo -> Field -> Parser (Conversion [a])
546−fromArray fieldParser typInfo f = sequence . (parseIt <$>) <$> array delim
354+instance (FromField a, Typeable a) => FromField (Vector a) where
355+ fromField f dat = either (returnError ConversionFailed f)
356+ (V.fromList <$>)
357+ (parseOnly (fromArray ',' f) (maybe "" id dat))
358+
359+fromArray :: (FromField a) => Char -> Field -> Parser (Conversion [a])
360+fromArray delim f = sequence . (parseIt <$>) <$> array delim
547361 where
548− delim = typdelim (typelem typInfo)
549− fElem = f{ typeOid = typoid (typelem typInfo) }
362+ parseIt item = (fromField f . Just . fmt delim) item
550363
551− parseIt item =
552− fieldParser f' $ if item == Arrays.Plain "NULL" then Nothing else Just item'
553− where
554− item' = fmt delim item
555− f' | Arrays.Array _ <- item = f
556− | otherwise = fElem
364+newtype Compat = Compat Word64
557365
558−instance (FromField a, Typeable a) => FromField (Vector a) where
559− fromField f v = V.fromList . fromPGArray <$> fromField f v
560−
561−instance (FromField a, Typeable a) => FromField (IOVector a) where
562− fromField f v = liftConversion . V.unsafeThaw =<< fromField f v
563−
564−-- | uuid
565−instance FromField UUID where
566− fromField f mbs =
567− if typeOid f /= TI.uuidOid
568− then returnError Incompatible f ""
569− else case mbs of
570− Nothing -> returnError UnexpectedNull f ""
571− Just bs ->
572− case UUID.fromASCIIBytes bs of
573− Nothing -> returnError ConversionFailed f "Invalid UUID"
574− Just uuid -> pure uuid
575−
576−-- | json, jsonb
577−instance FromField JSON.Value where
578− fromField f mbs = parseBS =<< fromFieldJSONByteString f mbs
579− where parseBS bs = case JSON.eitherDecodeStrict' bs of
580− Left err -> returnError ConversionFailed f err
581− Right val -> pure val
582−
583−-- | Return the JSON ByteString directly
584−--
585−-- @since 0.6.3
586−fromFieldJSONByteString :: Field -> Maybe ByteString -> Conversion ByteString
587−fromFieldJSONByteString f mbs =
588− if typeOid f /= TI.jsonOid && typeOid f /= TI.jsonbOid
589− then returnError Incompatible f ""
590− else case mbs of
591− Nothing -> returnError UnexpectedNull f ""
592− Just bs -> pure bs
593−
594−-- | Parse a field to a JSON 'JSON.Value' and convert that into a
595−-- Haskell value using the 'JSON.FromJSON' instance.
596−--
597−-- This can be used as the default implementation for the 'fromField'
598−-- method for Haskell types that have a JSON representation in
599−-- PostgreSQL.
600−--
601−-- The 'Typeable' constraint is required to show more informative
602−-- error messages when parsing fails.
603−--
604−-- Note that @fromJSONField :: FieldParser ('Maybe' Foo)@ will return
605−-- @'Nothing'@ on the json @null@ value, and return an exception on SQL @null@
606−-- value. Alternatively, one could write @'optionalField' fromJSONField@
607−-- that will return @Nothing@ on SQL @null@, and otherwise will call
608−-- @fromJSONField :: FieldParser Foo@ and then return @'Just'@ the
609−-- result value, or return its exception. If one would
610−-- like to return @Nothing@ on both the SQL @null@ and json @null@ values,
611−-- one way to do it would be to write
612−-- @\\f mv -> 'Control.Monad.join' '<$>' optionalField fromJSONField f mv@
613−fromJSONField :: (JSON.FromJSON a, Typeable a) => FieldParser a
614−fromJSONField f mbBs = do
615− value <- fromField f mbBs
616− case JSON.ifromJSON value of
617− JSON.IError path err -> returnError ConversionFailed f $
618− "JSON decoding error: " ++ (JSON.formatError path err)
619− JSON.ISuccess x -> pure x
620−
621−-- | Compatible with the same set of types as @a@. Note that
622−-- modifying the 'IORef' does not have any effects outside
623−-- the local process on the local machine.
624−instance FromField a => FromField (IORef a) where
625− fromField f v = liftConversion . newIORef =<< fromField f v
626−
627−-- | Compatible with the same set of types as @a@. Note that
628−-- modifying the 'MVar' does not have any effects outside
629−-- the local process on the local machine.
630−instance FromField a => FromField (MVar a) where
631− fromField f v = liftConversion . newMVar =<< fromField f v
632−
633−type Compat = PQ.Oid -> Bool
366+mkCompats :: [BuiltinType] -> Compat
367+mkCompats = foldl' f (Compat 0) . map mkCompat
368+ where f (Compat a) (Compat b) = Compat (a .|. b)
369+
370+mkCompat :: BuiltinType -> Compat
371+mkCompat = Compat . shiftL 1 . fromEnum
372+
373+compat :: Compat -> Compat -> Bool
374+compat (Compat a) (Compat b) = a .&. b /= 0
634375
635376okText, okText', okBinary, ok16, ok32, ok64, okInt :: Compat
636−okText = eq TI.nameOid \/ eq TI.textOid \/ eq TI.charOid
637− \/ eq TI.bpcharOid \/ eq TI.varcharOid
638−okText' = eq TI.nameOid \/ eq TI.textOid \/ eq TI.charOid
639− \/ eq TI.bpcharOid \/ eq TI.varcharOid \/ eq TI.unknownOid
640−okBinary = eq TI.byteaOid
641−ok16 = eq TI.int2Oid
642−ok32 = eq TI.int2Oid \/ eq TI.int4Oid
643−ok64 = eq TI.int2Oid \/ eq TI.int4Oid \/ eq TI.int8Oid
377+okText = mkCompats [Name,Text,Char,BpChar,VarChar]
378+okText' = mkCompats [Name,Text,Char,BpChar,VarChar,Unknown]
379+okBinary = mkCompats [ByteA]
380+ok16 = mkCompats [Int2]
381+ok32 = mkCompats [Int2,Int4]
382+ok64 = mkCompats [Int2,Int4,Int8]
644383#if WORD_SIZE_IN_BITS < 64
645384okInt = ok32
646385#else
647386okInt = ok64
648387#endif
649388
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−
663389doFromField :: forall a . (Typeable a)
664390 => Field -> Compat -> (ByteString -> Conversion a)
665391 -> Maybe ByteString -> Conversion a
666−doFromField f isCompat cvt (Just bs)
667− | isCompat (typeOid f) = cvt bs
392+doFromField f types cvt (Just bs)
393+ | Just typ <- oid2builtin (typeOid f)
394+ , mkCompat typ `compat` types = cvt bs
668395 | otherwise = returnError Incompatible f "types incompatible"
669396doFromField f _ _ _ = returnError UnexpectedNull f ""
670397
@@ -684,22 +411,10 @@ returnError mkErr f msg = do
684411 (show (typeOf (undefined :: a)))
685412 msg
686413
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
414+atto :: forall a. (Typeable a)
415+ => Compat -> Parser a -> Field -> Maybe ByteString
416+ -> Conversion a
417+atto types p0 f dat = doFromField f types (go p0) dat
703418 where
704419 go :: Parser a -> ByteString -> Conversion a
705420 go p s =
src/Database/PostgreSQL/Simple/FromField.hs-boot−1
@@ -6,6 +6,5 @@ import Database.PostgreSQL.Simple.Types
66class FromField a
77
88instance FromField Oid
9−instance FromField Char
109instance FromField ByteString
1110instance FromField a => FromField (Maybe a)
src/Database/PostgreSQL/Simple/FromRow.hs+22−333
@@ -1,6 +1,4 @@
1−{-# LANGUAGE FlexibleContexts #-}
2−{-# LANGUAGE RecordWildCards, FlexibleInstances, DefaultSignatures #-}
3−
1+{-# LANGUAGE RecordWildCards #-}
42
53------------------------------------------------------------------------------
64-- |
@@ -9,15 +7,13 @@
97-- License: BSD3
108-- Maintainer: Leon P Smith <leon@melding-monads.com>
119-- Stability: experimental
10+-- Portability: portable
1211--
1312-- The 'FromRow' typeclass, for converting a row of results
1413-- returned by a SQL query into a more useful Haskell representation.
1514--
1615-- Predefined instances are provided for tuples containing up to ten
17−-- elements. The instances for 'Maybe' types return 'Nothing' if all
18−-- the columns that would have been otherwise consumed are null, otherwise
19−-- it attempts a regular conversion.
20−--
16+-- elements.
2117------------------------------------------------------------------------------
2218
2319module Database.PostgreSQL.Simple.FromRow
@@ -28,36 +24,32 @@ module Database.PostgreSQL.Simple.FromRow
2824 , numFieldsRemaining
2925 ) where
3026
31−import Prelude hiding (null)
32−import Control.Applicative (Applicative(..), (<$>), (<|>), (*>), liftA2)
33−import Control.Monad (replicateM, replicateM_)
34−import Control.Monad.Trans.State.Strict
35−import Control.Monad.Trans.Reader
36−import Control.Monad.Trans.Class
37−import Data.ByteString (ByteString)
27+import Control.Applicative (Applicative(..), (<$>))
28+import Control.Monad (replicateM)
29+import Data.ByteString (ByteString)
3830import qualified Data.ByteString.Char8 as B
39−import Data.Vector (Vector)
40−import qualified Data.Vector as V
41−import Database.PostgreSQL.Simple.Types (Only(..))
31+import Database.PostgreSQL.Simple.Types (Only(..))
4232import qualified Database.PostgreSQL.LibPQ as PQ
4333import Database.PostgreSQL.Simple.Internal
4434import Database.PostgreSQL.Simple.Compat
4535import Database.PostgreSQL.Simple.FromField
4636import Database.PostgreSQL.Simple.Ok
47−import Database.PostgreSQL.Simple.Types ((:.)(..), Null)
37+import Database.PostgreSQL.Simple.Types ((:.)(..))
4838import Database.PostgreSQL.Simple.TypeInfo
4939
50−import GHC.Generics
40+import Control.Monad.Trans.State.Strict
41+import Control.Monad.Trans.Reader
42+import Control.Monad.Trans.Class
5143
44+import Data.Vector ((!))
5245
5346-- | A collection type that can be converted from a sequence of fields.
5447-- Instances are provided for tuples up to 10 elements and lists of any length.
5548--
56−-- Note that instances can be defined outside of postgresql-simple, which is
49+-- Note that instances can defined outside of postgresql-simple, which is
5750-- often useful. For example, here's an instance for a user-defined pair:
5851--
59−-- @
60−-- data User = User { name :: String, fileQuota :: Int }
52+-- @data User = User { name :: String, fileQuota :: Int }
6153--
6254-- instance 'FromRow' User where
6355-- fromRow = User \<$\> 'field' \<*\> 'field'
@@ -67,47 +59,27 @@ import GHC.Generics
6759-- in a single row of the query result. Otherwise, a 'ConversionFailed'
6860-- exception will be thrown.
6961--
70−-- You can also derive 'FromRow' for your data type using GHC generics, like
71−-- this:
72−--
73−-- @
74−-- \{-# LANGUAGE DeriveAnyClass \#-}
75−-- \{-# LANGUAGE DeriveGeneric \#-}
76−--
77−-- import "GHC.Generics" ('GHC.Generics.Generic')
78−-- import "Database.PostgreSQL.Simple" ('FromRow')
79−--
80−-- data User = User { name :: String, fileQuota :: Int }
81−-- deriving ('GHC.Generics.Generic', 'FromRow')
82−-- @
83−--
84−-- Note that this only works for product types (e.g. records) and does not
85−-- support sum types or recursive types.
86−--
87−-- Note that 'field' evaluates its result to WHNF, so the caveats listed in
88−-- mysql-simple and very early versions of postgresql-simple no longer apply.
89−-- Instead, look at the caveats associated with user-defined implementations
90−-- of 'fromField'.
62+-- Note that 'field' evaluates it's result to WHNF, so the caveats listed in
63+-- previous versions of postgresql-simple no longer apply. Instead, look
64+-- at the caveats associated with user-defined implementations of 'fromRow'.
9165
9266class FromRow a where
9367 fromRow :: RowParser a
94− default fromRow :: (Generic a, GFromRow (Rep a)) => RowParser a
95− fromRow = to <$> gfromRow
9668
9769getvalue :: PQ.Result -> PQ.Row -> PQ.Column -> Maybe ByteString
98−getvalue result row col = unsafeDupablePerformIO (PQ.getvalue' result row col)
70+getvalue result row col = unsafeDupablePerformIO (PQ.getvalue result row col)
9971
10072nfields :: PQ.Result -> PQ.Column
10173nfields result = unsafeDupablePerformIO (PQ.nfields result)
10274
10375getTypeInfoByCol :: Row -> PQ.Column -> Conversion TypeInfo
104−getTypeInfoByCol Row{..} col =
76+getTypeInfoByCol Row{..} col =
10577 Conversion $ \conn -> do
10678 oid <- PQ.ftype rowresult col
10779 Ok <$> getTypeInfo conn oid
10880
10981getTypenameByCol :: Row -> PQ.Column -> Conversion ByteString
110−getTypenameByCol row col = typname <$> getTypeInfoByCol row col
82+getTypenameByCol row col = typname . typ <$> getTypeInfoByCol row col
11183
11284fieldWith :: FieldParser a -> RowParser a
11385fieldWith fieldP = RP $ do
@@ -131,8 +103,8 @@ fieldWith fieldP = RP $ do
131103 else do
132104 let !result = rowresult
133105 !typeOid = unsafeDupablePerformIO (PQ.ftype result column)
134− !field' = Field{..}
135− lift (lift (fieldP field' (getvalue result row column)))
106+ !field = Field{..}
107+ lift (lift (fieldP field (getvalue result row column)))
136108
137109field :: FromField a => RowParser a
138110field = fieldWith fromField
@@ -148,340 +120,57 @@ numFieldsRemaining = RP $ do
148120 column <- lift get
149121 return $! (\(PQ.Col x) -> fromIntegral x) (nfields rowresult - column)
150122
151−null :: RowParser Null
152−null = field
153−
154123instance (FromField a) => FromRow (Only a) where
155124 fromRow = Only <$> field
156125
157−instance (FromField a) => FromRow (Maybe (Only a)) where
158− fromRow = (null *> pure Nothing)
159− <|> (Just <$> fromRow)
160−
161126instance (FromField a, FromField b) => FromRow (a,b) where
162127 fromRow = (,) <$> field <*> field
163128
164−instance (FromField a, FromField b) => FromRow (Maybe (a,b)) where
165− fromRow = (null *> null *> pure Nothing)
166− <|> (Just <$> fromRow)
167−
168129instance (FromField a, FromField b, FromField c) => FromRow (a,b,c) where
169130 fromRow = (,,) <$> field <*> field <*> field
170131
171−instance (FromField a, FromField b, FromField c) => FromRow (Maybe (a,b,c)) where
172− fromRow = (null *> null *> null *> pure Nothing)
173− <|> (Just <$> fromRow)
174−
175132instance (FromField a, FromField b, FromField c, FromField d) =>
176133 FromRow (a,b,c,d) where
177134 fromRow = (,,,) <$> field <*> field <*> field <*> field
178135
179−instance (FromField a, FromField b, FromField c, FromField d) =>
180− FromRow (Maybe (a,b,c,d)) where
181− fromRow = (null *> null *> null *> null *> pure Nothing)
182− <|> (Just <$> fromRow)
183−
184136instance (FromField a, FromField b, FromField c, FromField d, FromField e) =>
185137 FromRow (a,b,c,d,e) where
186138 fromRow = (,,,,) <$> field <*> field <*> field <*> field <*> field
187139
188−instance (FromField a, FromField b, FromField c, FromField d, FromField e) =>
189− FromRow (Maybe (a,b,c,d,e)) where
190− fromRow = (null *> null *> null *> null *> null *> pure Nothing)
191− <|> (Just <$> fromRow)
192−
193140instance (FromField a, FromField b, FromField c, FromField d, FromField e,
194141 FromField f) =>
195142 FromRow (a,b,c,d,e,f) where
196143 fromRow = (,,,,,) <$> field <*> field <*> field <*> field <*> field
197144 <*> field
198145
199−instance (FromField a, FromField b, FromField c, FromField d, FromField e,
200− FromField f) =>
201− FromRow (Maybe (a,b,c,d,e,f)) where
202− fromRow = (null *> null *> null *> null *> null *>
203− null *> pure Nothing)
204− <|> (Just <$> fromRow)
205−
206146instance (FromField a, FromField b, FromField c, FromField d, FromField e,
207147 FromField f, FromField g) =>
208148 FromRow (a,b,c,d,e,f,g) where
209149 fromRow = (,,,,,,) <$> field <*> field <*> field <*> field <*> field
210150 <*> field <*> field
211151
212−instance (FromField a, FromField b, FromField c, FromField d, FromField e,
213− FromField f, FromField g) =>
214− FromRow (Maybe (a,b,c,d,e,f,g)) where
215− fromRow = (null *> null *> null *> null *> null *>
216− null *> null *> pure Nothing)
217− <|> (Just <$> fromRow)
218−
219152instance (FromField a, FromField b, FromField c, FromField d, FromField e,
220153 FromField f, FromField g, FromField h) =>
221154 FromRow (a,b,c,d,e,f,g,h) where
222155 fromRow = (,,,,,,,) <$> field <*> field <*> field <*> field <*> field
223156 <*> field <*> field <*> field
224157
225−instance (FromField a, FromField b, FromField c, FromField d, FromField e,
226− FromField f, FromField g, FromField h) =>
227− FromRow (Maybe (a,b,c,d,e,f,g,h)) where
228− fromRow = (null *> null *> null *> null *> null *>
229− null *> null *> null *> pure Nothing)
230− <|> (Just <$> fromRow)
231−
232158instance (FromField a, FromField b, FromField c, FromField d, FromField e,
233159 FromField f, FromField g, FromField h, FromField i) =>
234160 FromRow (a,b,c,d,e,f,g,h,i) where
235161 fromRow = (,,,,,,,,) <$> field <*> field <*> field <*> field <*> field
236162 <*> field <*> field <*> field <*> field
237163
238−instance (FromField a, FromField b, FromField c, FromField d, FromField e,
239− FromField f, FromField g, FromField h, FromField i) =>
240− FromRow (Maybe (a,b,c,d,e,f,g,h,i)) where
241− fromRow = (null *> null *> null *> null *> null *>
242− null *> null *> null *> null *> pure Nothing)
243− <|> (Just <$> fromRow)
244−
245164instance (FromField a, FromField b, FromField c, FromField d, FromField e,
246165 FromField f, FromField g, FromField h, FromField i, FromField j) =>
247166 FromRow (a,b,c,d,e,f,g,h,i,j) where
248167 fromRow = (,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field
249168 <*> field <*> field <*> field <*> field <*> field
250169
251−instance (FromField a, FromField b, FromField c, FromField d, FromField e,
252− FromField f, FromField g, FromField h, FromField i, FromField j) =>
253− FromRow (Maybe (a,b,c,d,e,f,g,h,i,j)) where
254− fromRow = (null *> null *> null *> null *> null *>
255− null *> null *> null *> null *> null *> pure Nothing)
256− <|> (Just <$> fromRow)
257−
258−instance (FromField a, FromField b, FromField c, FromField d, FromField e,
259− FromField f, FromField g, FromField h, FromField i, FromField j,
260− FromField k) =>
261− FromRow (a,b,c,d,e,f,g,h,i,j,k) where
262− fromRow = (,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field
263− <*> field <*> field <*> field <*> field <*> field
264− <*> field
265−
266−instance (FromField a, FromField b, FromField c, FromField d, FromField e,
267− FromField f, FromField g, FromField h, FromField i, FromField j,
268− FromField k) =>
269− FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k)) where
270− fromRow = (null *> null *> null *> null *> null *>
271− null *> null *> null *> null *> null *>
272− null *> pure Nothing)
273− <|> (Just <$> fromRow)
274−
275−instance (FromField a, FromField b, FromField c, FromField d, FromField e,
276− FromField f, FromField g, FromField h, FromField i, FromField j,
277− FromField k, FromField l) =>
278− FromRow (a,b,c,d,e,f,g,h,i,j,k,l) where
279− fromRow = (,,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field
280− <*> field <*> field <*> field <*> field <*> field
281− <*> field <*> field
282−
283−instance (FromField a, FromField b, FromField c, FromField d, FromField e,
284− FromField f, FromField g, FromField h, FromField i, FromField j,
285− FromField k, FromField l) =>
286− FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l)) where
287− fromRow = (null *> null *> null *> null *> null *>
288− null *> null *> null *> null *> null *>
289− null *> null *> pure Nothing)
290− <|> (Just <$> fromRow)
291−
292−instance (FromField a, FromField b, FromField c, FromField d, FromField e,
293− FromField f, FromField g, FromField h, FromField i, FromField j,
294− FromField k, FromField l, FromField m) =>
295− FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m) where
296− fromRow = (,,,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field
297− <*> field <*> field <*> field <*> field <*> field
298− <*> field <*> field <*> field
299−
300−instance (FromField a, FromField b, FromField c, FromField d, FromField e,
301− FromField f, FromField g, FromField h, FromField i, FromField j,
302− FromField k, FromField l, FromField m) =>
303− FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l,m)) where
304− fromRow = (null *> null *> null *> null *> null *>
305− null *> null *> null *> null *> null *>
306− null *> null *> null *> pure Nothing)
307− <|> (Just <$> fromRow)
308−
309−instance (FromField a, FromField b, FromField c, FromField d, FromField e,
310− FromField f, FromField g, FromField h, FromField i, FromField j,
311− FromField k, FromField l, FromField m, FromField n) =>
312− FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n) where
313− fromRow = (,,,,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field
314− <*> field <*> field <*> field <*> field <*> field
315− <*> field <*> field <*> field <*> field
316−
317−instance (FromField a, FromField b, FromField c, FromField d, FromField e,
318− FromField f, FromField g, FromField h, FromField i, FromField j,
319− FromField k, FromField l, FromField m, FromField n) =>
320− FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l,m,n)) where
321− fromRow = (null *> null *> null *> null *> null *>
322− null *> null *> null *> null *> null *>
323− null *> null *> null *> null *> pure Nothing)
324− <|> (Just <$> fromRow)
325−
326−instance (FromField a, FromField b, FromField c, FromField d, FromField e,
327− FromField f, FromField g, FromField h, FromField i, FromField j,
328− FromField k, FromField l, FromField m, FromField n, FromField o) =>
329− FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) where
330− fromRow = (,,,,,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field
331− <*> field <*> field <*> field <*> field <*> field
332− <*> field <*> field <*> field <*> field <*> field
333−
334−instance (FromField a, FromField b, FromField c, FromField d, FromField e,
335− FromField f, FromField g, FromField h, FromField i, FromField j,
336− FromField k, FromField l, FromField m, FromField n, FromField o) =>
337− FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o)) where
338− fromRow = (null *> null *> null *> null *> null *>
339− null *> null *> null *> null *> null *>
340− null *> null *> null *> null *> null *> pure Nothing)
341− <|> (Just <$> fromRow)
342−
343−instance (FromField a, FromField b, FromField c, FromField d, FromField e,
344− FromField f, FromField g, FromField h, FromField i, FromField j,
345− FromField k, FromField l, FromField m, FromField n, FromField o,
346− FromField p) =>
347− FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) where
348− fromRow = (,,,,,,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field
349− <*> field <*> field <*> field <*> field <*> field
350− <*> field <*> field <*> field <*> field <*> field
351− <*> field
352−
353−instance (FromField a, FromField b, FromField c, FromField d, FromField e,
354− FromField f, FromField g, FromField h, FromField i, FromField j,
355− FromField k, FromField l, FromField m, FromField n, FromField o,
356− FromField p) =>
357− FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p)) where
358− fromRow = (null *> null *> null *> null *> null *>
359− null *> null *> null *> null *> null *>
360− null *> null *> null *> null *> null *>
361− null *> pure Nothing)
362− <|> (Just <$> fromRow)
363−
364−instance (FromField a, FromField b, FromField c, FromField d, FromField e,
365− FromField f, FromField g, FromField h, FromField i, FromField j,
366− FromField k, FromField l, FromField m, FromField n, FromField o,
367− FromField p, FromField q) =>
368− FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q) where
369− fromRow = (,,,,,,,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field
370− <*> field <*> field <*> field <*> field <*> field
371− <*> field <*> field <*> field <*> field <*> field
372− <*> field <*> field
373−
374−instance (FromField a, FromField b, FromField c, FromField d, FromField e,
375− FromField f, FromField g, FromField h, FromField i, FromField j,
376− FromField k, FromField l, FromField m, FromField n, FromField o,
377− FromField p, FromField q) =>
378− FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q)) where
379− fromRow = (null *> null *> null *> null *> null *>
380− null *> null *> null *> null *> null *>
381− null *> null *> null *> null *> null *>
382− null *> null *> pure Nothing)
383− <|> (Just <$> fromRow)
384−
385−instance (FromField a, FromField b, FromField c, FromField d, FromField e,
386− FromField f, FromField g, FromField h, FromField i, FromField j,
387− FromField k, FromField l, FromField m, FromField n, FromField o,
388− FromField p, FromField q, FromField r) =>
389− FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r) where
390− fromRow = (,,,,,,,,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field
391− <*> field <*> field <*> field <*> field <*> field
392− <*> field <*> field <*> field <*> field <*> field
393− <*> field <*> field <*> field
394−
395−instance (FromField a, FromField b, FromField c, FromField d, FromField e,
396− FromField f, FromField g, FromField h, FromField i, FromField j,
397− FromField k, FromField l, FromField m, FromField n, FromField o,
398− FromField p, FromField q, FromField r) =>
399− FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r)) where
400− fromRow = (null *> null *> null *> null *> null *>
401− null *> null *> null *> null *> null *>
402− null *> null *> null *> null *> null *>
403− null *> null *> null *> pure Nothing)
404− <|> (Just <$> fromRow)
405−
406−instance (FromField a, FromField b, FromField c, FromField d, FromField e,
407− FromField f, FromField g, FromField h, FromField i, FromField j,
408− FromField k, FromField l, FromField m, FromField n, FromField o,
409− FromField p, FromField q, FromField r, FromField s) =>
410− FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s) where
411− fromRow = (,,,,,,,,,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field
412− <*> field <*> field <*> field <*> field <*> field
413− <*> field <*> field <*> field <*> field <*> field
414− <*> field <*> field <*> field <*> field
415−
416−instance (FromField a, FromField b, FromField c, FromField d, FromField e,
417− FromField f, FromField g, FromField h, FromField i, FromField j,
418− FromField k, FromField l, FromField m, FromField n, FromField o,
419− FromField p, FromField q, FromField r, FromField s) =>
420− FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s)) where
421− fromRow = (null *> null *> null *> null *> null *>
422− null *> null *> null *> null *> null *>
423− null *> null *> null *> null *> null *>
424− null *> null *> null *> null *> pure Nothing)
425− <|> (Just <$> fromRow)
426−
427−instance (FromField a, FromField b, FromField c, FromField d, FromField e,
428− FromField f, FromField g, FromField h, FromField i, FromField j,
429− FromField k, FromField l, FromField m, FromField n, FromField o,
430− FromField p, FromField q, FromField r, FromField s, FromField t) =>
431− FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t) where
432− fromRow = (,,,,,,,,,,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field
433− <*> field <*> field <*> field <*> field <*> field
434− <*> field <*> field <*> field <*> field <*> field
435− <*> field <*> field <*> field <*> field <*> field
436−
437−instance (FromField a, FromField b, FromField c, FromField d, FromField e,
438− FromField f, FromField g, FromField h, FromField i, FromField j,
439− FromField k, FromField l, FromField m, FromField n, FromField o,
440− FromField p, FromField q, FromField r, FromField s, FromField t) =>
441− FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t)) where
442− fromRow = (null *> null *> null *> null *> null *>
443− null *> null *> null *> null *> null *>
444− null *> null *> null *> null *> null *>
445− null *> null *> null *> null *> null *> pure Nothing)
446− <|> (Just <$> fromRow)
447−
448170instance FromField a => FromRow [a] where
449171 fromRow = do
450172 n <- numFieldsRemaining
451173 replicateM n field
452174
453−instance FromField a => FromRow (Maybe [a]) where
454− fromRow = do
455− n <- numFieldsRemaining
456− (replicateM_ n null *> pure Nothing) <|> (Just <$> replicateM n field)
457−
458−instance FromField a => FromRow (Vector a) where
459− fromRow = do
460− n <- numFieldsRemaining
461− V.replicateM n field
462−
463−instance FromField a => FromRow (Maybe (Vector a)) where
464− fromRow = do
465− n <- numFieldsRemaining
466− (replicateM_ n null *> pure Nothing) <|> (Just <$> V.replicateM n field)
467−
468175instance (FromRow a, FromRow b) => FromRow (a :. b) where
469176 fromRow = (:.) <$> fromRow <*> fromRow
470−
471−
472−
473−-- Type class for default implementation of FromRow using generics
474−class GFromRow f where
475− gfromRow :: RowParser (f p)
476−
477−instance GFromRow f => GFromRow (M1 c i f) where
478− gfromRow = M1 <$> gfromRow
479−
480−instance (GFromRow f, GFromRow g) => GFromRow (f :*: g) where
481− gfromRow = liftA2 (:*:) gfromRow gfromRow
482−
483−instance (FromField a) => GFromRow (K1 R a) where
484− gfromRow = K1 <$> field
485−
486−instance GFromRow U1 where
487− gfromRow = pure U1
src/Database/PostgreSQL/Simple/FromRow.hs-boot+1−11
@@ -1,17 +1,7 @@
11module Database.PostgreSQL.Simple.FromRow where
22
33import {-# SOURCE #-} Database.PostgreSQL.Simple.FromField
4−import Database.PostgreSQL.Simple.Types
54
65class FromRow a
76
8−instance (FromField a) => FromRow (Only a)
9−instance (FromField a, FromField b)
10− => FromRow (a,b)
11−instance (FromField a, FromField b, FromField c, FromField d)
12− => FromRow (a,b,c,d)
13−instance (FromField a, FromField b, FromField c, FromField d, FromField e)
14− => FromRow (a,b,c,d,e)
15−instance (FromField a, FromField b, FromField c, FromField d, FromField e
16− ,FromField f)
17− => FromRow (a,b,c,d,e,f)
7+instance (FromField a, FromField b, FromField c, FromField d) => FromRow (a,b,c,d)
src/Database/PostgreSQL/Simple/HStore.hsdeleted−36
@@ -1,36 +0,0 @@
1−------------------------------------------------------------------------------
2−-- |
3−-- Module: Database.PostgreSQL.Simple.HStore
4−-- Copyright: (c) 2013 Leon P Smith
5−-- License: BSD3
6−-- Maintainer: Leon P Smith <leon@melding-monads.com>
7−-- Stability: experimental
8−--
9−-- Parsers and printers for hstore, a extended type bundled with
10−-- PostgreSQL providing finite maps from text strings to text strings.
11−-- See <https://www.postgresql.org/docs/9.5/static/hstore.html> for more
12−-- information.
13−--
14−-- Note that in order to use this type, a database superuser must
15−-- install it by running a sql script in the share directory. This
16−-- can be done on PostgreSQL 9.1 and later with the command
17−-- @CREATE EXTENSION hstore@. See
18−-- <https://www.postgresql.org/docs/9.5/static/contrib.html> for more
19−-- information.
20−--
21−------------------------------------------------------------------------------
22−
23−module Database.PostgreSQL.Simple.HStore
24− ( HStoreList(..)
25− , HStoreMap(..)
26− , ToHStore(..)
27− , HStoreBuilder
28− , toBuilder
29− , toLazyByteString
30− , hstore
31− , parseHStoreList
32− , ToHStoreText(..)
33− , HStoreText
34− ) where
35−
36−import Database.PostgreSQL.Simple.HStore.Implementation
src/Database/PostgreSQL/Simple/HStore/Implementation.hsdeleted−210
@@ -1,210 +0,0 @@
1−{-# LANGUAGE CPP, ViewPatterns, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
2−
3−------------------------------------------------------------------------------
4−-- |
5−-- Module: Database.PostgreSQL.Simple.HStore.Implementation
6−-- Copyright: (c) 2013 Leon P Smith
7−-- License: BSD3
8−-- Maintainer: Leon P Smith <leon@melding-monads.com>
9−-- Stability: experimental
10−--
11−-- This code has yet to be profiled and optimized.
12−--
13−------------------------------------------------------------------------------
14−
15−module Database.PostgreSQL.Simple.HStore.Implementation where
16−
17−import Control.Applicative
18−import qualified Data.Attoparsec.ByteString as P
19−import qualified Data.Attoparsec.ByteString.Char8 as P (isSpace_w8)
20−import qualified Data.ByteString as BS
21−import Data.ByteString.Builder (Builder, byteString, char8)
22−import qualified Data.ByteString.Builder as BU
23−import Data.ByteString.Internal (c2w, w2c)
24−import qualified Data.ByteString.Lazy as BL
25−import Data.Map(Map)
26−import qualified Data.Map as Map
27−import Data.Text(Text)
28−import qualified Data.Text as TS
29−import qualified Data.Text.Encoding as TS
30−import Data.Text.Encoding.Error(UnicodeException)
31−import qualified Data.Text.Lazy as TL
32−import Data.Typeable
33−import Data.Monoid(Monoid(..))
34−import Data.Semigroup
35−import Database.PostgreSQL.Simple.FromField
36−import Database.PostgreSQL.Simple.ToField
37−
38−class ToHStore a where
39− toHStore :: a -> HStoreBuilder
40−
41−-- | Represents valid hstore syntax.
42−data HStoreBuilder
43− = Empty
44− | Comma !Builder
45− deriving (Typeable)
46−
47−instance ToHStore HStoreBuilder where
48− toHStore = id
49−
50−toBuilder :: HStoreBuilder -> Builder
51−toBuilder x = case x of
52− Empty -> mempty
53− Comma c -> c
54−
55−toLazyByteString :: HStoreBuilder -> BL.ByteString
56−toLazyByteString x = case x of
57− Empty -> BL.empty
58− Comma c -> BU.toLazyByteString c
59−
60−instance Semigroup HStoreBuilder where
61− Empty <> x = x
62− Comma a <> x
63− = Comma (a `mappend` case x of
64− Empty -> mempty
65− Comma b -> char8 ',' `mappend` b)
66−
67−instance Monoid HStoreBuilder where
68− mempty = Empty
69−
70−class ToHStoreText a where
71− toHStoreText :: a -> HStoreText
72−
73−-- | Represents escape text, ready to be the key or value to a hstore value
74−newtype HStoreText = HStoreText Builder deriving (Typeable, Semigroup, Monoid)
75−
76−instance ToHStoreText HStoreText where
77− toHStoreText = id
78−
79−-- | Assumed to be UTF-8 encoded
80−instance ToHStoreText BS.ByteString where
81− toHStoreText str = HStoreText (escapeAppend str mempty)
82−
83−-- | Assumed to be UTF-8 encoded
84−instance ToHStoreText BL.ByteString where
85− toHStoreText = HStoreText . BL.foldrChunks escapeAppend mempty
86−
87−instance ToHStoreText TS.Text where
88− toHStoreText str = HStoreText (escapeAppend (TS.encodeUtf8 str) mempty)
89−
90−instance ToHStoreText TL.Text where
91− toHStoreText = HStoreText . TL.foldrChunks (escapeAppend . TS.encodeUtf8) mempty
92−
93−escapeAppend :: BS.ByteString -> Builder -> Builder
94−escapeAppend = loop
95− where
96− loop (BS.break quoteNeeded -> (a,b)) rest
97− = byteString a `mappend`
98− case BS.uncons b of
99− Nothing -> rest
100− Just (c,d) -> quoteChar c `mappend` loop d rest
101−
102− quoteNeeded c = c == c2w '\"' || c == c2w '\\'
103− quoteChar c
104− | c == c2w '\"' = byteString "\\\""
105− | otherwise = byteString "\\\\"
106−
107−hstore :: (ToHStoreText a, ToHStoreText b) => a -> b -> HStoreBuilder
108−hstore (toHStoreText -> (HStoreText key)) (toHStoreText -> (HStoreText val)) =
109− Comma (char8 '"' `mappend` key `mappend` byteString "\"=>\""
110− `mappend` val `mappend` char8 '"')
111−
112−instance ToField HStoreBuilder where
113− toField Empty = toField (BS.empty)
114− toField (Comma x) = toField (BU.toLazyByteString x)
115−
116−newtype HStoreList = HStoreList {fromHStoreList :: [(Text,Text)]} deriving (Typeable, Show)
117−
118−-- | hstore
119−instance ToHStore HStoreList where
120− toHStore (HStoreList xs) = mconcat (map (uncurry hstore) xs)
121−
122−instance ToField HStoreList where
123− toField xs = toField (toHStore xs)
124−
125−-- | hstore
126−instance FromField HStoreList where
127− fromField f mdat = do
128− typ <- typename f
129− if typ /= "hstore"
130− then returnError Incompatible f ""
131− else case mdat of
132− Nothing -> returnError UnexpectedNull f ""
133− Just dat ->
134− case P.parseOnly (parseHStore <* P.endOfInput) dat of
135− Left err ->
136− returnError ConversionFailed f err
137− Right (Left err) ->
138− returnError ConversionFailed f "unicode exception" <|>
139− conversionError err
140− Right (Right val) ->
141− return val
142−
143−newtype HStoreMap = HStoreMap {fromHStoreMap :: Map Text Text} deriving (Eq, Ord, Typeable, Show)
144−
145−instance ToHStore HStoreMap where
146− toHStore (HStoreMap xs) = Map.foldrWithKey f mempty xs
147− where f k v xs' = hstore k v `mappend` xs'
148−
149−instance ToField HStoreMap where
150− toField xs = toField (toHStore xs)
151−
152−instance FromField HStoreMap where
153− fromField f mdat = convert <$> fromField f mdat
154− where convert (HStoreList xs) = HStoreMap (Map.fromList xs)
155−
156−parseHStoreList :: BS.ByteString -> Either String HStoreList
157−parseHStoreList dat =
158− case P.parseOnly (parseHStore <* P.endOfInput) dat of
159− Left err -> Left (show err)
160− Right (Left err) -> Left (show err)
161− Right (Right val) -> Right val
162−
163−parseHStore :: P.Parser (Either UnicodeException HStoreList)
164−parseHStore = do
165− kvs <- P.sepBy' (skipWhiteSpace *> parseHStoreKeyVal)
166− (skipWhiteSpace *> P.word8 (c2w ','))
167− return $ HStoreList <$> sequence kvs
168−
169−parseHStoreKeyVal :: P.Parser (Either UnicodeException (Text,Text))
170−parseHStoreKeyVal = do
171− mkey <- parseHStoreText
172− case mkey of
173− Left err -> return (Left err)
174− Right key -> do
175− skipWhiteSpace
176− _ <- P.string "=>"
177− skipWhiteSpace
178− mval <- parseHStoreText
179− case mval of
180− Left err -> return (Left err)
181− Right val -> return (Right (key,val))
182−
183−
184−skipWhiteSpace :: P.Parser ()
185−skipWhiteSpace = P.skipWhile P.isSpace_w8
186−
187−parseHStoreText :: P.Parser (Either UnicodeException Text)
188−parseHStoreText = do
189− _ <- P.word8 (c2w '"')
190− mtexts <- parseHStoreTexts id
191− case mtexts of
192− Left err -> return (Left err)
193− Right texts -> do
194− _ <- P.word8 (c2w '"')
195− return (Right (TS.concat texts))
196−
197−parseHStoreTexts :: ([Text] -> [Text])
198− -> P.Parser (Either UnicodeException [Text])
199−parseHStoreTexts acc = do
200− mchunk <- TS.decodeUtf8' <$> P.takeWhile (not . isSpecialChar)
201− case mchunk of
202− Left err -> return (Left err)
203− Right chunk ->
204− (do
205− _ <- P.word8 (c2w '\\')
206− c <- TS.singleton . w2c <$> P.satisfy isSpecialChar
207− parseHStoreTexts (acc . (chunk:) . (c:))
208− ) <|> return (Right (acc [chunk]))
209− where
210− isSpecialChar c = c == c2w '\\' || c == c2w '"'
src/Database/PostgreSQL/Simple/HStore/Internal.hsdeleted−19
@@ -1,19 +0,0 @@
1−------------------------------------------------------------------------------
2−-- |
3−-- Module: Database.PostgreSQL.Simple.HStore.Internal
4−-- Copyright: (c) 2013 Leon P Smith
5−-- License: BSD3
6−-- Maintainer: Leon P Smith <leon@melding-monads.com>
7−-- Stability: experimental
8−--
9−------------------------------------------------------------------------------
10−
11−module Database.PostgreSQL.Simple.HStore.Internal
12− ( HStoreBuilder(..)
13− , HStoreText(..)
14− , parseHStore
15− , parseHStoreKeyVal
16− , parseHStoreText
17− ) where
18−
19−import Database.PostgreSQL.Simple.HStore.Implementation
src/Database/PostgreSQL/Simple/Internal.hs+41−343
@@ -1,16 +1,12 @@
1−{-# LANGUAGE CPP, BangPatterns, DoAndIfThenElse, RecordWildCards #-}
2−{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}
3−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4−{-# LANGUAGE ExistentialQuantification #-}
5−{-# LANGUAGE InstanceSigs #-}
6−
1+{-# LANGUAGE RecordWildCards, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
72------------------------------------------------------------------------------
83-- |
94-- Module: Database.PostgreSQL.Simple.Internal
10−-- Copyright: (c) 2011-2015 Leon P Smith
5+-- Copyright: (c) 2011-2012 Leon P Smith
116-- License: BSD3
127-- Maintainer: Leon P Smith <leon@melding-monads.com>
138-- Stability: experimental
9+-- Portability: portable
1410--
1511-- Internal bits. This interface is less stable and can change at any time.
1612-- In particular this means that while the rest of the postgresql-simple
@@ -23,40 +19,28 @@
2319
2420module Database.PostgreSQL.Simple.Internal where
2521
22+import Prelude hiding (catch)
23+
2624import Control.Applicative
2725import Control.Exception
2826import Control.Concurrent.MVar
2927import Control.Monad(MonadPlus(..))
3028import Data.ByteString(ByteString)
31−import qualified Data.ByteString as B
3229import qualified Data.ByteString.Char8 as B8
33−import Data.ByteString.Builder ( Builder, byteString )
3430import Data.Char (ord)
3531import Data.Int (Int64)
3632import qualified Data.IntMap as IntMap
37−import Data.IORef
3833import Data.Maybe(fromMaybe)
3934import Data.String
40−import qualified Data.Text as T
41−import qualified Data.Text.Encoding as TE
4235import Data.Typeable
4336import Data.Word
4437import Database.PostgreSQL.LibPQ(Oid(..))
4538import qualified Database.PostgreSQL.LibPQ as PQ
4639import Database.PostgreSQL.LibPQ(ExecStatus(..))
47−import Database.PostgreSQL.Simple.Compat ( toByteString )
4840import Database.PostgreSQL.Simple.Ok
49−import Database.PostgreSQL.Simple.ToField (Action(..), inQuotes)
5041import Database.PostgreSQL.Simple.Types (Query(..))
51−import Database.PostgreSQL.Simple.TypeInfo.Types(TypeInfo)
5242import Control.Monad.Trans.State.Strict
5343import Control.Monad.Trans.Reader
54−import Control.Monad.Trans.Class
55−import GHC.Generics
56−import GHC.IO.Exception
57−#if !defined(mingw32_HOST_OS)
58−import Control.Concurrent(threadWaitRead, threadWaitWrite)
59−#endif
6044
6145-- | A Field represents metadata about a particular field
6246--
@@ -67,40 +51,23 @@ import Control.Concurrent(threadWaitRead, threadWaitWrite)
6751data Field = Field {
6852 result :: !PQ.Result
6953 , column :: {-# UNPACK #-} !PQ.Column
70− , typeOid :: {-# UNPACK #-} !PQ.Oid
71− -- ^ This returns the type oid associated with the column. Analogous
54+ , typeOid :: {-# UNPACK #-} !PQ.Oid
55+ -- ^ This returns the type oid associated with the column. Analogous
7256 -- to libpq's @PQftype@.
7357 }
7458
75−type TypeInfoCache = IntMap.IntMap TypeInfo
59+data NamedOid = NamedOid { typoid :: !PQ.Oid
60+ , typname :: !ByteString
61+ } deriving Show
62+
63+data TypeInfo = TypeInfo { typ :: !NamedOid
64+ , typelem :: !(Maybe NamedOid)
65+ } deriving Show
7666
7767data Connection = Connection {
7868 connectionHandle :: {-# UNPACK #-} !(MVar PQ.Connection)
79− , connectionObjects :: {-# UNPACK #-} !(MVar TypeInfoCache)
80− , connectionTempNameCounter :: {-# UNPACK #-} !(IORef Int64)
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
69+ , connectionObjects :: {-# UNPACK #-} !(MVar (IntMap.IntMap TypeInfo))
70+ }
10471
10572data SqlError = SqlError {
10673 sqlState :: ByteString
@@ -108,15 +75,12 @@ data SqlError = SqlError {
10875 , sqlErrorMsg :: ByteString
10976 , sqlErrorDetail :: ByteString
11077 , sqlErrorHint :: ByteString
111− } deriving (Eq, Show, Typeable)
78+ } deriving (Show, Typeable)
11279
11380fatalError :: ByteString -> SqlError
11481fatalError msg = SqlError "" FatalError msg "" ""
11582
116−instance Exception SqlError where
117− toException = postgresqlExceptionToException
118− fromException = postgresqlExceptionFromException
119−
83+instance Exception SqlError
12084
12185-- | Exception thrown if 'query' is used to perform an @INSERT@-like
12286-- operation, or 'execute' is used to perform a @SELECT@-like operation.
@@ -125,22 +89,7 @@ data QueryError = QueryError {
12589 , qeQuery :: Query
12690 } deriving (Eq, Show, Typeable)
12791
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
92+instance Exception QueryError
14493
14594data ConnectInfo = ConnectInfo {
14695 connectHost :: String
@@ -148,7 +97,7 @@ data ConnectInfo = ConnectInfo {
14897 , connectUser :: String
14998 , connectPassword :: String
15099 , connectDatabase :: String
151− } deriving (Generic,Eq,Read,Show,Typeable)
100+ } deriving (Eq,Read,Show,Typeable)
152101
153102-- | Default information for setting up a connection.
154103--
@@ -182,133 +131,30 @@ defaultConnectInfo = ConnectInfo {
182131connect :: ConnectInfo -> IO Connection
183132connect = connectPostgreSQL . postgreSQLConnectionString
184133
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−
191134-- | Attempt to make a connection based on a libpq connection string.
192−-- See <https://www.postgresql.org/docs/9.5/static/libpq-connect.html#LIBPQ-CONNSTRING>
193−-- for more information. Also note that environment variables also affect
194−-- parameters not provided, parameters provided as the empty string, and a
195−-- few other things; see
196−-- <https://www.postgresql.org/docs/9.5/static/libpq-envars.html>
197−-- for details. Here is an example with some of the most commonly used
198−-- parameters:
199−--
200−-- > host='db.somedomain.com' port=5432 ...
201−--
202−-- This attempts to connect to @db.somedomain.com:5432@. Omitting the port
203−-- will normally default to 5432.
204−--
205−-- On systems that provide unix domain sockets, omitting the host parameter
206−-- will cause libpq to attempt to connect via unix domain sockets.
207−-- The default filesystem path to the socket is constructed from the
208−-- port number and the @DEFAULT_PGSOCKET_DIR@ constant defined in the
209−-- @pg_config_manual.h@ header file. Connecting via unix sockets tends
210−-- to use the @peer@ authentication method, which is very secure and
211−-- does not require a password.
212−--
213−-- On Windows and other systems without unix domain sockets, omitting
214−-- the host will default to @localhost@.
215−--
216−-- > ... dbname='postgres' user='postgres' password='secret \' \\ pw'
217−--
218−-- This attempts to connect to a database named @postgres@ with
219−-- user @postgres@ and password @secret \' \\ pw@. Backslash
220−-- characters will have to be double-quoted in literal Haskell strings,
221−-- of course. Omitting @dbname@ and @user@ will both default to the
222−-- system username that the client process is running as.
223−--
224−-- Omitting @password@ will default to an appropriate password found
225−-- in the @pgpass@ file, or no password at all if a matching line is
226−-- not found. The path of the @pgpass@ file may be specified by setting
227−-- the @PGPASSFILE@ environment variable. See
228−-- <https://www.postgresql.org/docs/9.5/static/libpq-pgpass.html> for
229−-- more information regarding this file.
230−--
231−-- As all parameters are optional and the defaults are sensible, the
232−-- empty connection string can be useful for development and
233−-- exploratory use, assuming your system is set up appropriately.
234−--
235−-- On Unix, such a setup would typically consist of a local
236−-- postgresql server listening on port 5432, as well as a system user,
237−-- database user, and database sharing a common name, with permissions
238−-- granted to the user on the database.
239−--
240−-- On Windows, in addition you will either need @pg_hba.conf@
241−-- to specify the use of the @trust@ authentication method for
242−-- the connection, which may not be appropriate for multiuser
243−-- or production machines, or you will need to use a @pgpass@ file
244−-- with the @password@ or @md5@ authentication methods.
245−--
246−-- See <https://www.postgresql.org/docs/9.5/static/client-authentication.html>
247−-- for more information regarding the authentication process.
248−--
249−-- SSL/TLS will typically "just work" if your postgresql server supports or
250−-- requires it. However, note that libpq is trivially vulnerable to a MITM
251−-- attack without setting additional SSL connection parameters. In
252−-- particular, @sslmode@ needs to be set to @require@, @verify-ca@, or
253−-- @verify-full@ in order to perform certificate validation. When @sslmode@
254−-- is @require@, then you will also need to specify a @sslrootcert@ file,
255−-- otherwise no validation of the server's identity will be performed.
256−-- Client authentication via certificates is also possible via the
257−-- @sslcert@ and @sslkey@ parameters. See
258−-- <https://www.postgresql.org/docs/9.5/static/libpq-ssl.html>
259−-- for detailed information regarding libpq and SSL.
135+-- See <http://www.postgresql.org/docs/9.1/static/libpq-connect.html>
136+-- for more information.
260137
261138connectPostgreSQL :: ByteString -> IO Connection
262139connectPostgreSQL connstr = do
263− conn <- connectdb connstr
140+ conn <- PQ.connectdb connstr
264141 stat <- PQ.status conn
265142 case stat of
266143 PQ.ConnectionOk -> do
267144 connectionHandle <- newMVar conn
268145 connectionObjects <- newMVar (IntMap.empty)
269− connectionTempNameCounter <- newIORef 0
270146 let wconn = Connection{..}
271147 version <- PQ.serverVersion conn
272148 let settings
273− | version < 80200 = "SET datestyle TO ISO;SET client_encoding TO UTF8"
274− | otherwise = "SET datestyle TO ISO;SET client_encoding TO UTF8;SET standard_conforming_strings TO on"
149+ | version < 80200 = "SET datestyle TO ISO"
150+ | otherwise = "SET standard_conforming_strings TO on;\
151+ \SET datestyle TO ISO"
275152 _ <- execute_ wconn settings
276153 return wconn
277154 _ -> do
278155 msg <- maybe "connectPostgreSQL error" id <$> PQ.errorMessage conn
279156 throwIO $ fatalError msg
280157
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−
312158-- | Turns a 'ConnectInfo' data structure into a libpq connection string.
313159
314160postgreSQLConnectionString :: ConnectInfo -> ByteString
@@ -323,7 +169,7 @@ postgreSQLConnectionString connectInfo = fromString connstr
323169
324170 str name field
325171 | null value = id
326− | otherwise = showString name . addQuotes value . space
172+ | otherwise = showString name . quote value . space
327173 where value = field connectInfo
328174
329175 num name field
@@ -331,7 +177,7 @@ postgreSQLConnectionString connectInfo = fromString connstr
331177 | otherwise = showString name . shows value . space
332178 where value = field connectInfo
333179
334− addQuotes s rest = '\'' : foldr delta ('\'' : rest) s
180+ quote str rest = '\'' : foldr delta ('\'' : rest) str
335181 where
336182 delta c cs = case c of
337183 '\\' -> '\\' : '\\' : cs
@@ -350,53 +196,15 @@ oid2int (Oid x) = fromIntegral x
350196exec :: Connection
351197 -> ByteString
352198 -> IO PQ.Result
353−#if defined(mingw32_HOST_OS)
354199exec conn sql =
355200 withConnection conn $ \h -> do
356201 mres <- PQ.exec h sql
357202 case mres of
358− Nothing -> throwLibPQError h "PQexec returned no results"
359− Just res -> return res
360−#else
361−exec conn sql =
362− withConnection conn $ \h -> do
363− success <- PQ.sendQuery h sql
364− if success
365− then awaitResult h Nothing
366− else throwLibPQError h "PQsendQuery failed"
367− where
368− awaitResult h mres = do
369− mfd <- PQ.socket h
370− case mfd of
371− Nothing -> throwIO $! fdError "Database.PostgreSQL.Simple.Internal.exec"
372− Just fd -> do
373− threadWaitRead fd
374− _ <- PQ.consumeInput h -- FIXME?
375− getResult h mres
376−
377− getResult h mres = do
378− isBusy <- PQ.isBusy h
379− if isBusy
380− then awaitResult h mres
381− else do
382− mres' <- PQ.getResult h
383− case mres' of
384− Nothing -> case mres of
385− Nothing -> throwLibPQError h "PQgetResult returned no results"
386− Just res -> return res
387− Just res -> do
388− status <- PQ.resultStatus res
389− case status of
390− -- FIXME: handle PQ.CopyBoth and PQ.SingleTuple
391− PQ.EmptyQuery -> getResult h mres'
392− PQ.CommandOk -> getResult h mres'
393− PQ.TuplesOk -> getResult h mres'
394− PQ.CopyOut -> return res
395− PQ.CopyIn -> return res
396− PQ.BadResponse -> getResult h mres'
397− PQ.NonfatalError -> getResult h mres'
398− PQ.FatalError -> getResult h mres'
399−#endif
203+ Nothing -> do
204+ msg <- maybe "execute error" id <$> PQ.errorMessage h
205+ throwIO $ fatalError msg
206+ Just res -> do
207+ return res
400208
401209-- | A version of 'execute' that does not perform query substitution.
402210execute_ :: Connection -> Query -> IO Int64
@@ -408,7 +216,6 @@ finishExecute :: Connection -> Query -> PQ.Result -> IO Int64
408216finishExecute _conn q result = do
409217 status <- PQ.resultStatus result
410218 case status of
411− -- FIXME: handle PQ.CopyBoth and PQ.SingleTuple
412219 PQ.EmptyQuery -> throwIO $ QueryError "execute: Empty query" q
413220 PQ.CommandOk -> do
414221 ncols <- PQ.nfields result
@@ -419,7 +226,7 @@ finishExecute _conn q result = do
419226 nstr <- PQ.cmdTuples result
420227 return $ case nstr of
421228 Nothing -> 0 -- is this appropriate?
422− Just str -> mkInteger str
229+ Just str -> toInteger str
423230 PQ.TuplesOk -> do
424231 ncols <- PQ.nfields result
425232 throwIO $ QueryError ("execute resulted in " ++ show ncols ++
@@ -432,7 +239,7 @@ finishExecute _conn q result = do
432239 PQ.NonfatalError -> throwResultError "execute" result status
433240 PQ.FatalError -> throwResultError "execute" result status
434241 where
435− mkInteger str = B8.foldl' delta 0 str
242+ toInteger str = B8.foldl' delta 0 str
436243 where
437244 delta acc c =
438245 if '0' <= c && c <= '9'
@@ -447,8 +254,8 @@ throwResultError _ result status = do
447254 PQ.resultErrorField result PQ.DiagMessageDetail
448255 hint <- fromMaybe "" <$>
449256 PQ.resultErrorField result PQ.DiagMessageHint
450− state' <- maybe "" id <$> PQ.resultErrorField result PQ.DiagSqlstate
451− throwIO $ SqlError { sqlState = state'
257+ state <- maybe "" id <$> PQ.resultErrorField result PQ.DiagSqlstate
258+ throwIO $ SqlError { sqlState = state
452259 , sqlExecStatus = status
453260 , sqlErrorMsg = errormsg
454261 , sqlErrorDetail = detail
@@ -478,7 +285,6 @@ newNullConnection :: IO Connection
478285newNullConnection = do
479286 connectionHandle <- newMVar =<< PQ.newNullConnection
480287 connectionObjects <- newMVar IntMap.empty
481− connectionTempNameCounter <- newIORef 0
482288 return Connection{..}
483289
484290data Row = Row {
@@ -489,14 +295,8 @@ data Row = Row {
489295newtype RowParser a = RP { unRP :: ReaderT Row (StateT PQ.Column Conversion) a }
490296 deriving ( Functor, Applicative, Alternative, Monad )
491297
492−liftRowParser :: IO a -> RowParser a
493−liftRowParser = RP . lift . lift . liftConversion
494−
495298newtype Conversion a = Conversion { runConversion :: Connection -> IO (Ok a) }
496299
497−liftConversion :: IO a -> Conversion a
498−liftConversion m = Conversion (\_ -> Ok <$> m)
499−
500300instance Functor Conversion where
501301 fmap f m = Conversion $ \conn -> (fmap . fmap) f (runConversion m conn)
502302
@@ -515,10 +315,11 @@ instance Alternative Conversion where
515315 case oka of
516316 Ok _ -> return oka
517317 Errors _ -> (oka <|>) <$> runConversion mb conn
518−
318+
519319instance Monad Conversion where
320+ return a = Conversion $ \_conn -> return (return a)
520321 m >>= f = Conversion $ \conn -> do
521− oka <- runConversion m conn
322+ oka <- runConversion m conn
522323 case oka of
523324 Ok a -> runConversion (f a) conn
524325 Errors err -> return (Errors err)
@@ -531,107 +332,4 @@ conversionMap :: (Ok a -> Ok b) -> Conversion a -> Conversion b
531332conversionMap f m = Conversion $ \conn -> f <$> runConversion m conn
532333
533334conversionError :: Exception err => err -> Conversion a
534−conversionError err = Conversion $ \_ -> return (Errors [toException err])
535−
536−newTempName :: Connection -> IO Query
537−newTempName Connection{..} = do
538− !n <- atomicModifyIORef connectionTempNameCounter
539− (\n -> let !n' = n+1 in (n', n'))
540− return $! Query $ B8.pack $ "temp" ++ show n
541−
542−-- FIXME? What error should getNotification and getCopyData throw?
543−fdError :: ByteString -> IOError
544−fdError funcName = IOError {
545− ioe_handle = Nothing,
546− ioe_type = ResourceVanished,
547− ioe_location = B8.unpack funcName,
548− ioe_description = "failed to fetch file descriptor",
549− ioe_errno = Nothing,
550− ioe_filename = Nothing
551− }
552−
553−
554−libPQError :: ByteString -> IOError
555−libPQError desc = IOError {
556− ioe_handle = Nothing,
557− ioe_type = OtherError,
558− ioe_location = "libpq",
559− ioe_description = B8.unpack desc,
560− ioe_errno = Nothing,
561− ioe_filename = Nothing
562− }
563−
564−throwLibPQError :: PQ.Connection -> ByteString -> IO a
565−throwLibPQError conn default_desc = do
566− msg <- maybe default_desc id <$> PQ.errorMessage conn
567− throwIO $! libPQError msg
568−
569−
570−fmtError :: String -> Query -> [Action] -> a
571−fmtError msg q xs = throw FormatError {
572− fmtMessage = msg
573− , fmtQuery = q
574− , fmtParams = map twiddle xs
575− }
576− where twiddle (Plain b) = toByteString b
577− twiddle (Escape s) = s
578− twiddle (EscapeByteA s) = s
579− twiddle (EscapeIdentifier s) = s
580− twiddle (Many ys) = B.concat (map twiddle ys)
581−
582−fmtErrorBs :: Query -> [Action] -> ByteString -> a
583−fmtErrorBs q xs msg = fmtError (T.unpack $ TE.decodeUtf8 msg) q xs
584−
585−-- | Quote bytestring or throw 'FormatError'
586−quote :: Query -> [Action] -> Either ByteString ByteString -> Builder
587−quote q xs = either (fmtErrorBs q xs) (inQuotes . byteString)
588−
589−buildAction :: Connection -- ^ Connection for string escaping
590− -> Query -- ^ Query for message error
591− -> [Action] -- ^ List of parameters for message error
592− -> Action -- ^ Action to build
593− -> IO Builder
594−buildAction _ _ _ (Plain b) = pure b
595−buildAction conn q xs (Escape s) = quote q xs <$> escapeStringConn conn s
596−buildAction conn q xs (EscapeByteA s) = quote q xs <$> escapeByteaConn conn s
597−buildAction conn q xs (EscapeIdentifier s) =
598− either (fmtErrorBs q xs) byteString <$> escapeIdentifier conn s
599−buildAction conn q xs (Many ys) =
600− mconcat <$> mapM (buildAction conn q xs) ys
601−
602−checkError :: PQ.Connection -> Maybe a -> IO (Either ByteString a)
603−checkError _ (Just x) = return $ Right x
604−checkError c Nothing = Left . maybe "" id <$> PQ.errorMessage c
605−
606−escapeWrap :: (PQ.Connection -> ByteString -> IO (Maybe ByteString))
607− -> Connection
608− -> ByteString
609− -> IO (Either ByteString ByteString)
610−escapeWrap f conn s =
611− withConnection conn $ \c ->
612− f c s >>= checkError c
613−
614−escapeStringConn :: Connection -> ByteString -> IO (Either ByteString ByteString)
615−escapeStringConn = escapeWrap PQ.escapeStringConn
616−
617−escapeIdentifier :: Connection -> ByteString -> IO (Either ByteString ByteString)
618−escapeIdentifier = escapeWrap PQ.escapeIdentifier
619−
620−escapeByteaConn :: Connection -> ByteString -> IO (Either ByteString ByteString)
621−escapeByteaConn = escapeWrap PQ.escapeByteaConn
622−
623−breakOnSingleQuestionMark :: ByteString -> (ByteString, ByteString)
624−breakOnSingleQuestionMark b = go (B8.empty, b)
625− where go (x,bs) = (x `B8.append` x',bs')
626− -- seperate from first QM
627− where tup@(noQ, restWithQ) = B8.break (=='?') bs
628− -- if end of query, just return
629− -- else check for second QM in 'go2'
630− (x', bs') = maybe tup go2 $
631− -- drop found QM and peek at next char
632− B8.uncons restWithQ >>= B8.uncons . snd
633− -- another QM after the first means:
634− -- take literal QM and keep going.
635− go2 ('?', t2) = go (noQ `B8.snoc` '?',t2)
636− -- Anything else means
637− go2 _ = tup
335+conversionError err = Conversion $ \_ -> return (Errors [SomeException err])
src/Database/PostgreSQL/Simple/Internal/PQResultUtils.hsdeleted−123
@@ -1,123 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−
3−------------------------------------------------------------------------------
4−-- |
5−-- Module: Database.PostgreSQL.Simple.Internal.PQResultUtils
6−-- Copyright: (c) 2011 MailRank, Inc.
7−-- (c) 2011-2012 Leon P Smith
8−-- License: BSD3
9−-- Maintainer: Leon P Smith <leon@melding-monads.com>
10−-- Stability: experimental
11−--
12−------------------------------------------------------------------------------
13−
14−
15−module Database.PostgreSQL.Simple.Internal.PQResultUtils
16− ( finishQueryWith
17− , finishQueryWithV
18− , finishQueryWithVU
19− , getRowWith
20− ) where
21−
22−import Control.Exception as E
23−import Data.ByteString (ByteString)
24−import Data.Foldable (for_)
25−import Database.PostgreSQL.Simple.FromField (ResultError(..))
26−import Database.PostgreSQL.Simple.Ok
27−import Database.PostgreSQL.Simple.Types (Query(..))
28−import Database.PostgreSQL.Simple.Internal as Base hiding (result, row)
29−import Database.PostgreSQL.Simple.TypeInfo
30−import qualified Database.PostgreSQL.LibPQ as PQ
31−import qualified Data.ByteString.Char8 as B
32−import qualified Data.Vector as V
33−import qualified Data.Vector.Mutable as MV
34−import qualified Data.Vector.Unboxed as VU
35−import qualified Data.Vector.Unboxed.Mutable as MVU
36−import Control.Monad.Trans.Reader
37−import Control.Monad.Trans.State.Strict
38−
39−finishQueryWith :: RowParser r -> Connection -> Query -> PQ.Result -> IO [r]
40−finishQueryWith parser conn q result = finishQueryWith' q result $ do
41− nrows <- PQ.ntuples result
42− ncols <- PQ.nfields result
43− forM' 0 (nrows-1) $ \row ->
44− getRowWith parser row ncols conn result
45−
46−finishQueryWithV :: RowParser r -> Connection -> Query -> PQ.Result -> IO (V.Vector r)
47−finishQueryWithV parser conn q result = finishQueryWith' q result $ do
48− nrows <- PQ.ntuples result
49− let PQ.Row nrows' = nrows
50− ncols <- PQ.nfields result
51− mv <- MV.unsafeNew (fromIntegral nrows')
52− for_ [ 0 .. nrows-1 ] $ \row -> do
53− let PQ.Row row' = row
54− value <- getRowWith parser row ncols conn result
55− MV.unsafeWrite mv (fromIntegral row') value
56− V.unsafeFreeze mv
57−
58−finishQueryWithVU :: VU.Unbox r => RowParser r -> Connection -> Query -> PQ.Result -> IO (VU.Vector r)
59−finishQueryWithVU parser conn q result = finishQueryWith' q result $ do
60− nrows <- PQ.ntuples result
61− let PQ.Row nrows' = nrows
62− ncols <- PQ.nfields result
63− mv <- MVU.unsafeNew (fromIntegral nrows')
64− for_ [ 0 .. nrows-1 ] $ \row -> do
65− let PQ.Row row' = row
66− value <- getRowWith parser row ncols conn result
67− MVU.unsafeWrite mv (fromIntegral row') value
68− VU.unsafeFreeze mv
69−
70−finishQueryWith' :: Query -> PQ.Result -> IO a -> IO a
71−finishQueryWith' q result k = do
72− status <- PQ.resultStatus result
73− case status of
74− PQ.TuplesOk -> k
75− PQ.EmptyQuery -> queryErr "query: Empty query"
76− PQ.CommandOk -> queryErr "query resulted in a command response (did you mean to use `execute` or forget a RETURNING?)"
77− PQ.CopyOut -> queryErr "query: COPY TO is not supported"
78− PQ.CopyIn -> queryErr "query: COPY FROM is not supported"
79− PQ.CopyBoth -> queryErr "query: COPY BOTH is not supported"
80− PQ.SingleTuple -> queryErr "query: single-row mode is not supported"
81− PQ.BadResponse -> throwResultError "query" result status
82− PQ.NonfatalError -> throwResultError "query" result status
83− PQ.FatalError -> throwResultError "query" result status
84− where
85− queryErr msg = throwIO $ QueryError msg q
86−
87−getRowWith :: RowParser r -> PQ.Row -> PQ.Column -> Connection -> PQ.Result -> IO r
88−getRowWith parser row ncols conn result = do
89− let rw = Row row result
90− let unCol (PQ.Col x) = fromIntegral x :: Int
91− okvc <- runConversion (runStateT (runReaderT (unRP parser) rw) 0) conn
92− case okvc of
93− Ok (val,col) | col == ncols -> return val
94− | otherwise -> do
95− vals <- forM' 0 (ncols-1) $ \c -> do
96− tinfo <- getTypeInfo conn =<< PQ.ftype result c
97− v <- PQ.getvalue result row c
98− return ( tinfo
99− , fmap ellipsis v )
100− throw (ConversionFailed
101− (show (unCol ncols) ++ " values: " ++ show vals)
102− Nothing
103− ""
104− (show (unCol col) ++ " slots in target type")
105− "mismatch between number of columns to convert and number in target type")
106− Errors [] -> throwIO $ ConversionFailed "" Nothing "" "" "unknown error"
107− Errors [x] -> throwIO x
108− Errors xs -> throwIO $ ManyErrors xs
109−
110−ellipsis :: ByteString -> ByteString
111−ellipsis bs
112− | B.length bs > 15 = B.take 10 bs `B.append` "[...]"
113− | otherwise = bs
114−
115−forM' :: (Ord n, Num n) => n -> n -> (n -> IO a) -> IO [a]
116−forM' lo hi m = loop hi []
117− where
118− loop !n !as
119− | n < lo = return as
120− | otherwise = do
121− a <- m n
122− loop (n-1) (a:as)
123−{-# INLINE forM' #-}
src/Database/PostgreSQL/Simple/LargeObjects.hs+3−6
@@ -7,16 +7,13 @@
77-- Maintainer : leon@melding-monads.com
88--
99-- Support for PostgreSQL's Large Objects; see
10−-- <https://www.postgresql.org/docs/9.5/static/largeobjects.html> for more
10+-- <http://www.postgresql.org/docs/9.1/static/largeobjects.html> for more
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
15−-- 'loCreat', 'loCreate', and 'loUnlink', you will need to run the entire
16−-- sequence of functions in a transaction. As 'loImport' and 'loExport'
17−-- are simply C functions that call 'loCreat', 'loOpen', 'loRead', and
18−-- 'loWrite', and do not perform any transaction handling themselves,
19−-- they also need to be wrapped in an explicit transaction.
15+-- 'loCreat', 'loImport', 'loExport', and 'loUnlink', you will need to run
16+-- the entire sequence of functions in a transaction.
2017--
2118-----------------------------------------------------------------------------
2219
src/Database/PostgreSQL/Simple/Newtypes.hsdeleted−49
@@ -1,49 +0,0 @@
1−{-# LANGUAGE DeriveFunctor #-}
2−{-# LANGUAGE DeriveDataTypeable #-}
3−-- | Module with newtypes suitable to usage with @DerivingVia@ or standalone.
4−--
5−-- The newtypes are named after packages they wrap.
6−module Database.PostgreSQL.Simple.Newtypes (
7− Aeson (..), getAeson,
8−) where
9−
10−import Data.Typeable (Typeable)
11−import Database.PostgreSQL.Simple.ToField (ToField (..))
12−import Database.PostgreSQL.Simple.FromField (FromField (..), fromJSONField)
13−
14−import qualified Data.Aeson as Aeson
15−
16−-------------------------------------------------------------------------------
17−-- aeson
18−-------------------------------------------------------------------------------
19−
20−-- | A newtype wrapper with 'ToField' and 'FromField' instances
21−-- based on 'Aeson.ToJSON' and 'Aeson.FromJSON' type classes from @aeson@.
22−--
23−-- Example using @DerivingVia@:
24−--
25−-- @
26−-- data Foo = Foo Int String
27−-- deriving stock (Eq, Show, Generic) -- GHC built int
28−-- deriving anyclass ('Aeson.FromJSON', 'Aeson.ToJSON') -- Derived using GHC Generics
29−-- deriving ('ToField', 'FromField') via 'Aeson' Foo -- DerivingVia
30−-- @
31−--
32−-- Example using 'Aeson' newtype directly, for more ad-hoc queries
33−--
34−-- @
35−-- execute conn "INSERT INTO tbl (fld) VALUES (?)" (Only ('Aeson' x))
36−-- @
37−--
38−-- @since 0.6.3
39−newtype Aeson a = Aeson a
40− deriving (Eq, Show, Read, Typeable, Functor)
41−
42−getAeson :: Aeson a -> a
43−getAeson (Aeson a) = a
44−
45−instance Aeson.ToJSON a => ToField (Aeson a) where
46− toField = toField . Aeson.encode . getAeson
47−
48−instance (Aeson.FromJSON a, Typeable a) => FromField (Aeson a) where
49− fromField f bs = fmap Aeson (fromJSONField f bs)
src/Database/PostgreSQL/Simple/Notification.hs+29−90
@@ -1,12 +1,9 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE NamedFieldPuns #-}
3−{-# LANGUAGE RecordWildCards #-}
1+{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}
42
53-----------------------------------------------------------------------------
64-- |
75-- Module : Database.PostgreSQL.Simple.Notification
8−-- Copyright : (c) 2011-2015 Leon P Smith
9−-- (c) 2012 Joey Adams
6+-- Copyright : (c) 2011-2012 Leon P Smith
107-- License : BSD3
118--
129-- Maintainer : leon@melding-monads.com
@@ -14,49 +11,33 @@
1411--
1512-- Support for receiving asynchronous notifications via PostgreSQL's
1613-- Listen/Notify mechanism. See
17−-- <https://www.postgresql.org/docs/9.5/static/sql-notify.html> for more
14+-- <http://www.postgresql.org/docs/9.1/static/sql-notify.html> for more
1815-- information.
1916--
20−-- Note that on Windows, @getNotification@ currently uses a polling loop
21−-- of 1 second to check for more notifications, due to some inadequacies
22−-- in GHC's IO implementation and interface on that platform. See GHC
23−-- issue #7353 for more information. While this workaround is less than
24−-- ideal, notifications are still better than polling the database directly.
25−-- Notifications do not create any extra work for the backend, and are
26−-- likely cheaper on the client side as well.
27−--
28−-- <https://hackage.haskell.org/trac/ghc/ticket/7353>
29−--
3017-----------------------------------------------------------------------------
3118
3219module Database.PostgreSQL.Simple.Notification
3320 ( Notification(..)
3421 , getNotification
3522 , getNotificationNonBlocking
36− , getBackendPID
3723 ) where
3824
39−import Control.Monad ( join, void )
40−import Control.Exception ( throwIO, catch )
25+import Control.Concurrent ( threadWaitRead )
26+import Control.Monad ( when )
4127import qualified Data.ByteString as B
42−import qualified Data.ByteString.Char8 as B8
4328import Database.PostgreSQL.Simple.Internal
4429import qualified Database.PostgreSQL.LibPQ as PQ
4530import 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
5431
5532data Notification = Notification
56− { notificationPid :: {-# UNPACK #-} !CPid
57− , notificationChannel :: {-# UNPACK #-} !B.ByteString
58− , notificationData :: {-# UNPACK #-} !B.ByteString
59− } deriving (Show, Eq)
33+ { notificationPid :: !CPid
34+ , notificationChannel :: !B.ByteString
35+ , notificationData :: !B.ByteString
36+ }
37+
38+errfd :: String
39+errfd = "Database.PostgreSQL.Simple.Notification.getNotification: \
40+ \failed to fetch file descriptor"
6041
6142convertNotice :: PQ.Notify -> Notification
6243convertNotice PQ.Notify{..}
@@ -66,56 +47,25 @@ convertNotice PQ.Notify{..}
6647
6748-- | Returns a single notification. If no notifications are available,
6849-- '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.
7350
7451getNotification :: Connection -> IO Notification
75−getNotification conn = join $ withConnection conn fetch
52+getNotification = loop False
7653 where
77− funcName = "Database.PostgreSQL.Simple.Notification.getNotification"
78−
79− fetch c = do
80− mmsg <- PQ.notifies c
81− case mmsg of
82− Just msg -> return (return $! convertNotice msg)
83− Nothing -> do
84− mfd <- PQ.socket c
85− case mfd of
86− Nothing -> return (throwIO $! fdError funcName)
87−#if defined(mingw32_HOST_OS)
88− -- threadWaitRead doesn't work for sockets on Windows, so just
89− -- poll for input every second (PQconsumeInput is non-blocking).
90− --
91− -- We could call select(), but FFI calls can't be interrupted
92− -- with async exceptions, whereas threadDelay can.
93− Just _fd -> do
94− return (threadDelay 1000000 >> loop)
95−#else
96− -- This case fixes the race condition above. By registering
97− -- our interest in the descriptor before we drop the lock,
98− -- there is no opportunity for the descriptor index to be
99− -- reallocated on us.
100− --
101− -- (That is, assuming there isn't concurrently executing
102− -- code that manipulates the descriptor without holding
103− -- the lock... but such a major bug is likely to exhibit
104− -- itself in an at least somewhat more dramatic fashion.)
105− Just fd -> do
106− (waitRead, _) <- threadWaitReadSTM fd
107− return $ do
108− atomically waitRead `catch` (throwIO . setIOErrorLocation)
109− loop
110−#endif
111−
112− loop = join $ withConnection conn $ \c -> do
113− void $ PQ.consumeInput c
114− fetch c
115−
116− setIOErrorLocation :: IOError -> IOError
117− setIOErrorLocation err = err { ioe_location = B8.unpack funcName }
118−
54+ loop doConsume conn = do
55+ res <- withConnection conn $ \c -> do
56+ when doConsume (PQ.consumeInput c >> return ())
57+ mmsg <- PQ.notifies c
58+ case mmsg of
59+ Nothing -> do
60+ mfd <- PQ.socket c
61+ case mfd of
62+ Nothing -> fail errfd
63+ Just fd -> return (Left fd)
64+ Just msg -> return (Right msg)
65+ -- FIXME? what happens if the connection is closed/reset right here?
66+ case res of
67+ Left fd -> threadWaitRead fd >> loop True conn
68+ Right msg -> return $! convertNotice msg
11969
12070-- | Non-blocking variant of 'getNotification'. Returns a single notification,
12171-- if available. If no notifications are available, returns 'Nothing'.
@@ -132,14 +82,3 @@ getNotificationNonBlocking conn =
13282 case mmsg' of
13383 Just msg -> return $! Just $! convertNotice msg
13484 Nothing -> return Nothing
135−
136−-- | Returns the process 'CPid' of the backend server process
137−-- handling this connection.
138−--
139−-- The backend PID is useful for debugging purposes and for comparison
140−-- to NOTIFY messages (which include the PID of the notifying backend
141−-- process). Note that the PID belongs to a process executing on the
142−-- database server host, not the local host!
143−
144−getBackendPID :: Connection -> IO CPid
145−getBackendPID conn = withConnection conn PQ.backendPID
src/Database/PostgreSQL/Simple/Ok.hs+4−10
@@ -1,11 +1,10 @@
11{-# LANGUAGE DeriveDataTypeable #-}
22{-# LANGUAGE DeriveFunctor #-}
3−{-# LANGUAGE CPP #-}
43
54------------------------------------------------------------------------------
65-- |
76-- Module : Database.PostgreSQL.Simple.Ok
8−-- Copyright : (c) 2012-2015 Leon P Smith
7+-- Copyright : (c) 2012 Leon P Smith
98-- License : BSD3
109--
1110-- Maintainer : leon@melding-monads.com
@@ -21,7 +20,7 @@
2120-- commonly-used type and typeclass included in @base@.
2221--
2322-- Extending the failure case to a list of 'SomeException's enables a
24−-- more sensible 'Alternative' instance definitions: '<|>' concatenates
23+-- more sensible 'Alternative' instance definitions: '<|>' concatinates
2524-- the list of exceptions when both cases fail, and 'empty' is defined as
2625-- 'Errors []'. Though '<|>' one could pick one of two exceptions, and
2726-- throw away the other, and have 'empty' provide a generic exception,
@@ -37,8 +36,6 @@ import Control.Exception
3736import Control.Monad(MonadPlus(..))
3837import Data.Typeable
3938
40−import qualified Control.Monad.Fail as Fail
41−
4239-- FIXME: [SomeException] should probably be something else, maybe
4340-- a difference list (or a tree?)
4441
@@ -72,14 +69,11 @@ instance MonadPlus Ok where
7269 mplus = (<|>)
7370
7471instance Monad Ok where
72+ return = Ok
73+
7574 Errors es >>= _ = Errors es
7675 Ok a >>= f = f a
7776
78−#if !(MIN_VERSION_base(4,13,0))
79− fail = Fail.fail
80−#endif
81−
82−instance Fail.MonadFail Ok where
8377 fail str = Errors [SomeException (ErrorCall str)]
8478
8579-- | a way to reify a list of exceptions into a single exception
src/Database/PostgreSQL/Simple/Range.hsdeleted−317
@@ -1,317 +0,0 @@
1−{-# LANGUAGE DeriveDataTypeable #-}
2−{-# LANGUAGE DeriveFunctor #-}
3−{-# LANGUAGE OverloadedStrings #-}
4−{-# LANGUAGE FlexibleInstances #-}
5−
6−------------------------------------------------------------------------------
7−-- |
8−-- Module: Database.PostgreSQL.Simple.Range
9−-- Copyright: (c) 2014-2015 Leonid Onokhov
10−-- (c) 2014-2015 Leon P Smith
11−-- License: BSD3
12−-- Maintainer: Leon P Smith <leon@melding-monads.com>
13−--
14−------------------------------------------------------------------------------
15−
16−module Database.PostgreSQL.Simple.Range
17− ( RangeBound(..)
18− , PGRange(..)
19− , empty
20− , isEmpty, isEmptyBy
21− , contains, containsBy
22− , fromFieldRange
23− ) where
24−
25−import Control.Applicative hiding (empty)
26−import Data.Attoparsec.ByteString.Char8 (Parser, parseOnly)
27−import qualified Data.Attoparsec.ByteString.Char8 as A
28−import qualified Data.ByteString as B
29−import Data.ByteString.Builder
30− ( Builder, byteString, lazyByteString, char8
31− , intDec, int8Dec, int16Dec, int32Dec, int64Dec, integerDec
32− , wordDec, word8Dec, word16Dec, word32Dec, word64Dec
33− , doubleDec, floatDec )
34−import Data.Int (Int16, Int32, Int64,
35− Int8)
36−import Data.Function (on)
37−import Data.Monoid (mempty)
38−import Data.Scientific (Scientific)
39−import qualified Data.Text.Lazy.Builder as LT
40−import qualified Data.Text.Lazy.Encoding as LT
41−import Data.Time.Compat (Day, LocalTime,
42− NominalDiffTime,
43− TimeOfDay, UTCTime,
44− ZonedTime,
45− zonedTimeToUTC)
46−import Data.Typeable (Typeable)
47−import Data.Word (Word, Word16, Word32,
48− Word64, Word8)
49−
50−import Database.PostgreSQL.Simple.Compat (scientificBuilder, (<>), toByteString)
51−import Database.PostgreSQL.Simple.FromField
52−import Database.PostgreSQL.Simple.Time
53− hiding (PosInfinity, NegInfinity)
54−-- import qualified Database.PostgreSQL.Simple.Time as Time
55−import Database.PostgreSQL.Simple.ToField
56−
57−-- | Represents boundary of a range
58−data RangeBound a = NegInfinity
59− | Inclusive !a
60− | Exclusive !a
61− | PosInfinity
62− deriving (Show, Typeable, Eq, Functor)
63−
64−-- | Generic range type
65−data PGRange a = PGRange !(RangeBound a) !(RangeBound a)
66− deriving (Show, Typeable, Functor)
67−
68−empty :: PGRange a
69−empty = PGRange PosInfinity NegInfinity
70−
71−instance Ord a => Eq (PGRange a) where
72− x == y = eq x y || (isEmpty x && isEmpty y)
73− where eq (PGRange a m) (PGRange b n) = a == b && m == n
74−
75−isEmptyBy :: (a -> a -> Ordering) -> PGRange a -> Bool
76−isEmptyBy cmp v =
77− case v of
78− (PGRange PosInfinity _) -> True
79− (PGRange _ NegInfinity) -> True
80− (PGRange NegInfinity _) -> False
81− (PGRange _ PosInfinity) -> False
82− (PGRange (Inclusive x) (Inclusive y)) -> cmp x y == GT
83− (PGRange (Inclusive x) (Exclusive y)) -> cmp x y /= LT
84− (PGRange (Exclusive x) (Inclusive y)) -> cmp x y /= LT
85− (PGRange (Exclusive x) (Exclusive y)) -> cmp x y /= LT
86−
87−-- | Is a range empty? If this returns 'True', then the 'contains'
88−-- predicate will always return 'False'. However, if this returns
89−-- 'False', it is not necessarily true that there exists a point for
90−-- which 'contains' returns 'True'.
91−-- Consider @'PGRange' ('Excludes' 2) ('Excludes' 3) :: PGRange Int@,
92−-- for example.
93−isEmpty :: Ord a => PGRange a -> Bool
94−isEmpty = isEmptyBy compare
95−
96−
97−-- | Does a range contain a given point? Note that in some cases, this may
98−-- not correspond exactly with a server-side computation. Consider @UTCTime@
99−-- for example, which has a resolution of a picosecond, whereas postgresql's
100−-- @timestamptz@ types have a resolution of a microsecond. Putting such
101−-- Haskell values into the database will result in them being rounded, which
102−-- can change the value of the containment predicate.
103−
104−contains :: Ord a => PGRange a -> (a -> Bool)
105−contains = containsBy compare
106−
107−containsBy :: (a -> a -> Ordering) -> PGRange a -> (a -> Bool)
108−containsBy cmp rng x =
109− case rng of
110− PGRange _lb NegInfinity -> False
111− PGRange lb ub -> checkLB lb x && checkUB ub x
112− where
113− checkLB lb y =
114− case lb of
115− NegInfinity -> True
116− PosInfinity -> False
117− Inclusive a -> cmp a y /= GT
118− Exclusive a -> cmp a y == LT
119−
120− checkUB ub y =
121− case ub of
122− NegInfinity -> False
123− PosInfinity -> True
124− Inclusive z -> cmp y z /= GT
125− Exclusive z -> cmp y z == LT
126−
127−lowerBound :: Parser (a -> RangeBound a)
128−lowerBound = (A.char '(' *> pure Exclusive) <|> (A.char '[' *> pure Inclusive)
129−{-# INLINE lowerBound #-}
130−
131−upperBound :: Parser (a -> RangeBound a)
132−upperBound = (A.char ')' *> pure Exclusive) <|> (A.char ']' *> pure Inclusive)
133−{-# INLINE upperBound #-}
134−
135−-- | Generic range parser
136−pgrange :: Parser (RangeBound B.ByteString, RangeBound B.ByteString)
137−pgrange = do
138− lb <- lowerBound
139− v1 <- (A.char ',' *> "") <|> (rangeElem (==',') <* A.char ',')
140− v2 <- rangeElem $ \c -> c == ')' || c == ']'
141− ub <- upperBound
142− A.endOfInput
143− let low = if B.null v1 then NegInfinity else lb v1
144− up = if B.null v2 then PosInfinity else ub v2
145− return (low, up)
146−
147−rangeElem :: (Char -> Bool) -> Parser B.ByteString
148−rangeElem end = (A.char '"' *> doubleQuoted)
149− <|> A.takeTill end
150−{-# INLINE rangeElem #-}
151−
152−-- | Simple double quoted value parser
153−doubleQuoted :: Parser B.ByteString
154−doubleQuoted = toByteString <$> go mempty
155− where
156− go acc = do
157− h <- byteString <$> A.takeTill (\c -> c == '\\' || c == '"')
158− let rest = do
159− start <- A.anyChar
160− case start of
161− '\\' -> do
162− c <- A.anyChar
163− go (acc <> h <> char8 c)
164− '"' -> (A.char '"' *> go (acc <> h <> char8 '"'))
165− <|> pure (acc <> h)
166− _ -> error "impossible in doubleQuoted"
167− rest
168−
169−rangeToBuilder :: Ord a => (a -> Builder) -> PGRange a -> Builder
170−rangeToBuilder = rangeToBuilderBy compare
171−
172−-- | Generic range to builder for plain values
173−rangeToBuilderBy :: (a -> a -> Ordering) -> (a -> Builder) -> PGRange a -> Builder
174−rangeToBuilderBy cmp f x =
175− if isEmptyBy cmp x
176− then byteString "'empty'"
177− else let (PGRange a b) = x
178− in buildLB a <> buildUB b
179− where
180− buildLB NegInfinity = byteString "'[,"
181− buildLB (Inclusive v) = byteString "'[\"" <> f v <> byteString "\","
182− buildLB (Exclusive v) = byteString "'(\"" <> f v <> byteString "\","
183− buildLB PosInfinity = error "impossible in rangeToBuilder"
184−
185− buildUB NegInfinity = error "impossible in rangeToBuilder"
186− buildUB (Inclusive v) = char8 '"' <> f v <> byteString "\"]'"
187− buildUB (Exclusive v) = char8 '"' <> f v <> byteString "\")'"
188− buildUB PosInfinity = byteString "]'"
189−{-# INLINE rangeToBuilder #-}
190−
191−
192−instance (FromField a, Typeable a) => FromField (PGRange a) where
193− fromField = fromFieldRange fromField
194−
195−fromFieldRange :: Typeable a => FieldParser a -> FieldParser (PGRange a)
196−fromFieldRange fromField' f mdat = do
197− info <- typeInfo f
198− case info of
199− Range{} ->
200− let f' = f { typeOid = typoid (rngsubtype info) }
201− in case mdat of
202− Nothing -> returnError UnexpectedNull f ""
203− Just "empty" -> pure $ empty
204− Just bs ->
205− let parseIt NegInfinity = pure NegInfinity
206− parseIt (Inclusive v) = Inclusive <$> fromField' f' (Just v)
207− parseIt (Exclusive v) = Exclusive <$> fromField' f' (Just v)
208− parseIt PosInfinity = pure PosInfinity
209− in case parseOnly pgrange bs of
210− Left e -> returnError ConversionFailed f e
211− Right (lb,ub) -> PGRange <$> parseIt lb <*> parseIt ub
212− _ -> returnError Incompatible f ""
213−
214−
215−instance ToField (PGRange Int8) where
216− toField = Plain . rangeToBuilder int8Dec
217− {-# INLINE toField #-}
218−
219−instance ToField (PGRange Int16) where
220− toField = Plain . rangeToBuilder int16Dec
221− {-# INLINE toField #-}
222−
223−instance ToField (PGRange Int32) where
224− toField = Plain . rangeToBuilder int32Dec
225− {-# INLINE toField #-}
226−
227−instance ToField (PGRange Int) where
228− toField = Plain . rangeToBuilder intDec
229− {-# INLINE toField #-}
230−
231−instance ToField (PGRange Int64) where
232− toField = Plain . rangeToBuilder int64Dec
233− {-# INLINE toField #-}
234−
235−instance ToField (PGRange Integer) where
236− toField = Plain . rangeToBuilder integerDec
237− {-# INLINE toField #-}
238−
239−instance ToField (PGRange Word8) where
240− toField = Plain . rangeToBuilder word8Dec
241− {-# INLINE toField #-}
242−
243−instance ToField (PGRange Word16) where
244− toField = Plain . rangeToBuilder word16Dec
245− {-# INLINE toField #-}
246−
247−instance ToField (PGRange Word32) where
248− toField = Plain . rangeToBuilder word32Dec
249− {-# INLINE toField #-}
250−
251−instance ToField (PGRange Word) where
252− toField = Plain . rangeToBuilder wordDec
253− {-# INLINE toField #-}
254−
255−instance ToField (PGRange Word64) where
256− toField = Plain . rangeToBuilder word64Dec
257− {-# INLINE toField #-}
258−
259−instance ToField (PGRange Float) where
260− toField = Plain . rangeToBuilder floatDec
261− {-# INLINE toField #-}
262−
263−instance ToField (PGRange Double) where
264− toField = Plain . rangeToBuilder doubleDec
265− {-# INLINE toField #-}
266−
267−instance ToField (PGRange Scientific) where
268− toField = Plain . rangeToBuilder f
269− where
270− f = lazyByteString . LT.encodeUtf8 . LT.toLazyText . scientificBuilder
271− {-# INLINE toField #-}
272−
273−instance ToField (PGRange UTCTime) where
274− toField = Plain . rangeToBuilder utcTimeToBuilder
275− {-# INLINE toField #-}
276−
277−instance ToField (PGRange ZonedTime) where
278− toField = Plain . rangeToBuilderBy cmpZonedTime zonedTimeToBuilder
279− {-# INLINE toField #-}
280−
281−cmpZonedTime :: ZonedTime -> ZonedTime -> Ordering
282−cmpZonedTime = compare `on` zonedTimeToUTC -- FIXME: optimize
283−
284−instance ToField (PGRange LocalTime) where
285− toField = Plain . rangeToBuilder localTimeToBuilder
286− {-# INLINE toField #-}
287−
288−instance ToField (PGRange Day) where
289− toField = Plain . rangeToBuilder dayToBuilder
290− {-# INLINE toField #-}
291−
292−instance ToField (PGRange TimeOfDay) where
293− toField = Plain . rangeToBuilder timeOfDayToBuilder
294− {-# INLINE toField #-}
295−
296−instance ToField (PGRange UTCTimestamp) where
297− toField = Plain . rangeToBuilder utcTimestampToBuilder
298− {-# INLINE toField #-}
299−
300−instance ToField (PGRange ZonedTimestamp) where
301− toField = Plain . rangeToBuilderBy cmpZonedTimestamp zonedTimestampToBuilder
302− {-# INLINE toField #-}
303−
304−cmpZonedTimestamp :: ZonedTimestamp -> ZonedTimestamp -> Ordering
305−cmpZonedTimestamp = compare `on` (zonedTimeToUTC <$>)
306−
307−instance ToField (PGRange LocalTimestamp) where
308− toField = Plain . rangeToBuilder localTimestampToBuilder
309− {-# INLINE toField #-}
310−
311−instance ToField (PGRange Date) where
312− toField = Plain . rangeToBuilder dateToBuilder
313− {-# INLINE toField #-}
314−
315−instance ToField (PGRange NominalDiffTime) where
316− toField = Plain . rangeToBuilder nominalDiffTimeToBuilder
317− {-# INLINE toField #-}
src/Database/PostgreSQL/Simple/SqlQQ.hs+22−36
@@ -1,9 +1,3 @@
1−{-# LANGUAGE CPP #-}
2−#if __GLASGOW_HASKELL__ >= 800
3−{-# LANGUAGE TemplateHaskellQuotes #-}
4−#else
5−{-# LANGUAGE TemplateHaskell #-}
6−#endif
71------------------------------------------------------------------------------
82-- |
93-- Module: Database.PostgreSQL.Simple.SqlQQ
@@ -15,11 +9,10 @@
159------------------------------------------------------------------------------
1610
1711module Database.PostgreSQL.Simple.SqlQQ (sql) where
18−import Database.PostgreSQL.Simple.Types (Query)
12+
1913import Language.Haskell.TH
2014import Language.Haskell.TH.Quote
2115import Data.Char
22−import Data.String
2316
2417-- | 'sql' is a quasiquoter that eases the syntactic burden
2518-- of writing big sql statements in Haskell source code. For example:
@@ -34,18 +27,16 @@ import Data.String
3427-- > LIMIT 100 |]
3528-- > (beginTime,endTime,string)
3629--
37−-- This quasiquoter returns a literal string expression of type 'Query',
38−-- and attempts to minimize whitespace; otherwise the above query would
39−-- consist of approximately half whitespace when sent to the database
40−-- backend. It also recognizes and strips out standard sql comments "--".
30+-- This quasiquoter attempts to mimimize whitespace; otherwise the
31+-- above query would consist of approximately half whitespace when sent
32+-- to the database backend.
4133--
4234-- The implementation of the whitespace reducer is currently incomplete.
4335-- Thus it can mess up your syntax in cases where whitespace should be
4436-- preserved as-is. It does preserve whitespace inside standard SQL string
4537-- literals. But it can get confused by the non-standard PostgreSQL string
4638-- literal syntax (which is the default setting in PostgreSQL 8 and below),
47−-- the extended escape string syntax, quoted identifiers, and other similar
48−-- constructs.
39+-- the extended escape string syntax, and other similar constructs.
4940--
5041-- Of course, this caveat only applies to text written inside the SQL
5142-- quasiquoter; whitespace reduction is a compile-time computation and
@@ -57,34 +48,29 @@ import Data.String
5748
5849sql :: QuasiQuoter
5950sql = QuasiQuoter
60− { quotePat = error "Database.PostgreSQL.Simple.SqlQQ.sql: quasiquoter used in pattern context"
61− , quoteType = error "Database.PostgreSQL.Simple.SqlQQ.sql: quasiquoter used in type context"
51+ { quotePat = error "Database.PostgreSQL.Simple.SqlQQ.sql:\
52+ \ quasiquoter used in pattern context"
53+ , quoteType = error "Database.PostgreSQL.Simple.SqlQQ.sql:\
54+ \ quasiquoter used in type context"
6255 , quoteExp = sqlExp
63− , quoteDec = error "Database.PostgreSQL.Simple.SqlQQ.sql: quasiquoter used in declaration context"
56+ , quoteDec = error "Database.PostgreSQL.Simple.SqlQQ.sql:\
57+ \ quasiquoter used in declaration context"
6458 }
6559
6660sqlExp :: String -> Q Exp
67−sqlExp = appE [| fromString :: String -> Query |] . stringE . minimizeSpace
68−
69−minimizeSpace :: String -> String
70−minimizeSpace = drop 1 . reduceSpace
61+sqlExp = stringE . outstring . dropSpace
7162 where
72− needsReduced [] = False
73− needsReduced ('-':'-':_) = True
74− needsReduced (x:_) = isSpace x
75−
76− reduceSpace xs =
77− case dropWhile isSpace xs of
78− [] -> []
79− ('-':'-':ys) -> reduceSpace (dropWhile (/= '\n') ys)
80− ys -> ' ' : insql ys
63+ dropSpace = dropWhile isSpace
8164
82− insql ('\'':xs) = '\'' : instring xs
83− insql xs | needsReduced xs = reduceSpace xs
84− insql (x:xs) = x : insql xs
85− insql [] = []
65+ outstring ('\'':xs) = '\'' : instring xs
66+ outstring (x:xs) | isSpace x = case dropSpace xs of
67+ [] -> []
68+ ys -> ' ' : outstring ys
69+ | otherwise = x : outstring xs
70+ outstring [] = []
8671
8772 instring ('\'':'\'':xs) = '\'':'\'': instring xs
88− instring ('\'':xs) = '\'': insql xs
73+ instring ('\'':xs) = '\'': outstring xs
8974 instring (x:xs) = x : instring xs
90− instring [] = error "Database.PostgreSQL.Simple.SqlQQ.sql: string literal not terminated"
75+ instring [] = error "Database.PostgreSQL.Simple.SqlQQ.sql:\
76+ \ string literal not terminated"
src/Database/PostgreSQL/Simple/Time.hs+50−216
@@ -1,216 +1,53 @@
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−-}
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+------------------------------------------------------------------------------
21451
21552module Database.PostgreSQL.Simple.Time
21653 ( Unbounded(..)
@@ -227,7 +64,6 @@ module Database.PostgreSQL.Simple.Time
22764 , parseUTCTimestamp
22865 , parseZonedTimestamp
22966 , parseLocalTimestamp
230− , parseCalendarDiffTime
23167 , dayToBuilder
23268 , utcTimeToBuilder
23369 , zonedTimeToBuilder
@@ -239,8 +75,6 @@ module Database.PostgreSQL.Simple.Time
23975 , zonedTimestampToBuilder
24076 , localTimestampToBuilder
24177 , unboundedToBuilder
242− , nominalDiffTimeToBuilder
243− , calendarDiffTimeToBuilder
24478 ) where
24579
24680import Database.PostgreSQL.Simple.Time.Implementation
src/Database/PostgreSQL/Simple/Time/Implementation.hs+157−51
@@ -1,44 +1,51 @@
11------------------------------------------------------------------------------
22-- |
33-- Module: Database.PostgreSQL.Simple.Time.Implementation
4−-- Copyright: (c) 2012-2015 Leon P Smith
4+-- Copyright: (c) 2012 Leon P Smith
55-- License: BSD3
66-- Maintainer: Leon P Smith <leon@melding-monads.com>
77-- Stability: experimental
88--
99------------------------------------------------------------------------------
1010
11−{-# LANGUAGE DeriveDataTypeable, DeriveFunctor #-}
11+{-# LANGUAGE DeriveDataTypeable #-}
1212
1313module Database.PostgreSQL.Simple.Time.Implementation where
1414
15−import Prelude hiding (take)
16−import Data.ByteString.Builder(Builder, byteString)
17−import Data.ByteString.Builder.Prim(primBounded)
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)
1819import Control.Arrow((***))
1920import Control.Applicative
21+import Control.Monad(when)
22+import Data.Bits((.&.))
2023import qualified Data.ByteString as B
21−import Data.Time.Compat (LocalTime, UTCTime, ZonedTime, Day, TimeOfDay, TimeZone, NominalDiffTime, utc)
22−import Data.Time.LocalTime.Compat (CalendarDiffTime)
24+import Data.ByteString.Internal (c2w, w2c)
25+import Data.Time hiding (getTimeZone, getZonedTime)
2326import Data.Typeable
24−import Data.Maybe (fromMaybe)
25−import qualified Data.Attoparsec.ByteString.Char8 as A
26−import Database.PostgreSQL.Simple.Compat ((<>))
27−import qualified Database.PostgreSQL.Simple.Time.Internal.Parser as TP
28−import qualified Database.PostgreSQL.Simple.Time.Internal.Printer as TPP
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 ++
2936
3037data Unbounded a
3138 = NegInfinity
3239 | Finite !a
3340 | PosInfinity
34− deriving (Eq, Ord, Typeable, Functor)
41+ deriving (Eq, Ord, Typeable)
3542
3643instance Show a => Show (Unbounded a) where
3744 showsPrec prec x rest
3845 = case x of
39− NegInfinity -> "-infinity" <> rest
46+ NegInfinity -> "-infinity" ++ rest
4047 Finite time -> showsPrec prec time rest
41− PosInfinity -> "infinity" <> rest
48+ PosInfinity -> "infinity" ++ rest
4249
4350instance Read a => Read (Unbounded a) where
4451 readsPrec prec = readParen False $ \str -> case str of
@@ -78,9 +85,6 @@ parseLocalTimestamp = A.parseOnly (getLocalTimestamp <* A.endOfInput)
7885parseDate :: B.ByteString -> Either String Date
7986parseDate = A.parseOnly (getDate <* A.endOfInput)
8087
81−parseCalendarDiffTime :: B.ByteString -> Either String CalendarDiffTime
82−parseCalendarDiffTime = A.parseOnly (getCalendarDiffTime <* A.endOfInput)
83−
8488getUnbounded :: A.Parser a -> A.Parser (Unbounded a)
8589getUnbounded getFinite
8690 = (pure NegInfinity <* A.string "-infinity")
@@ -88,74 +92,130 @@ getUnbounded getFinite
8892 <|> (Finite <$> getFinite)
8993
9094getDay :: A.Parser Day
91−getDay = TP.day
95+getDay = do
96+ yearStr <- A.takeWhile A.isDigit
97+ when (B.length yearStr < 4) (fail "year must consist of at least 4 digits")
98+
99+ let !year = toNum yearStr
100+ _ <- A.char '-'
101+ month <- digits "month"
102+ _ <- A.char '-'
103+ day <- digits "day"
104+
105+ case fromGregorianValid year month day of
106+ Nothing -> fail "invalid date"
107+ Just x -> return $! x
92108
93109getDate :: A.Parser Date
94110getDate = getUnbounded getDay
95111
112+decimal :: Fractional a => B.ByteString -> a
113+decimal str = toNum str / 10^(B.length str)
114+{-# INLINE decimal #-}
115+
96116getTimeOfDay :: A.Parser TimeOfDay
97−getTimeOfDay = TP.timeOfDay
117+getTimeOfDay = do
118+ hour <- digits "hours"
119+ _ <- A.char ':'
120+ minute <- digits "minutes"
121+ _ <- A.char ':'
122+ second <- digits "seconds"
123+ subsec <- (A.char '.' *> (decimal <$> A.takeWhile1 A.isDigit)) <|> return 0
124+
125+ let !picos' = second + subsec
126+
127+ case makeTimeOfDayValid hour minute picos' of
128+ Nothing -> fail "invalid time of day"
129+ Just x -> return $! x
98130
99131getLocalTime :: A.Parser LocalTime
100−getLocalTime = TP.localTime
132+getLocalTime = LocalTime <$> getDay <*> (A.char ' ' *> getTimeOfDay)
101133
102134getLocalTimestamp :: A.Parser LocalTimestamp
103135getLocalTimestamp = getUnbounded getLocalTime
104136
105137getTimeZone :: A.Parser TimeZone
106−getTimeZone = fromMaybe utc <$> TP.timeZone
107−
108−type TimeZoneHMS = (Int,Int,Int)
109−
110−getTimeZoneHMS :: A.Parser TimeZoneHMS
111−getTimeZoneHMS = munge <$> TP.timeZoneHMS
112− where
113− munge Nothing = (0,0,0)
114− munge (Just (TP.UTCOffsetHMS h m s)) = (h,m,s)
115−
116−localToUTCTimeOfDayHMS :: TimeZoneHMS -> TimeOfDay -> (Integer, TimeOfDay)
117−localToUTCTimeOfDayHMS (dh, dm, ds) tod =
118− TP.localToUTCTimeOfDayHMS (TP.UTCOffsetHMS dh dm ds) tod
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
119145
120146getZonedTime :: A.Parser ZonedTime
121−getZonedTime = TP.zonedTime
147+getZonedTime = ZonedTime <$> getLocalTime <*> getTimeZone
122148
123149getZonedTimestamp :: A.Parser ZonedTimestamp
124150getZonedTimestamp = getUnbounded getZonedTime
125151
126152getUTCTime :: A.Parser UTCTime
127−getUTCTime = TP.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'')
128162
129163getUTCTimestamp :: A.Parser UTCTimestamp
130164getUTCTimestamp = getUnbounded getUTCTime
131165
132−getCalendarDiffTime :: A.Parser CalendarDiffTime
133−getCalendarDiffTime = TP.calendarDiffTime
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 #-}
134182
135183dayToBuilder :: Day -> Builder
136−dayToBuilder = primBounded TPP.day
184+dayToBuilder (toGregorian -> (y,m,d)) = do
185+ pad4 y ++ fromChar '-' ++ pad2 m ++ fromChar '-' ++ pad2 d
137186
138187timeOfDayToBuilder :: TimeOfDay -> Builder
139−timeOfDayToBuilder = primBounded TPP.timeOfDay
188+timeOfDayToBuilder (TimeOfDay h m s) = do
189+ pad2 h ++ fromChar ':' ++ pad2 m ++ fromChar ':' ++ showSeconds s
140190
141191timeZoneToBuilder :: TimeZone -> Builder
142−timeZoneToBuilder = primBounded TPP.timeZone
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 '-'
143199
144200utcTimeToBuilder :: UTCTime -> Builder
145−utcTimeToBuilder = primBounded TPP.utcTime
201+utcTimeToBuilder (UTCTime day time) =
202+ dayToBuilder day ++ fromChar ' '
203+ ++ timeOfDayToBuilder (timeToTimeOfDay time) ++ fromByteString "+00"
146204
147205zonedTimeToBuilder :: ZonedTime -> Builder
148−zonedTimeToBuilder = primBounded TPP.zonedTime
206+zonedTimeToBuilder (ZonedTime localTime tz) =
207+ localTimeToBuilder localTime ++ timeZoneToBuilder tz
149208
150209localTimeToBuilder :: LocalTime -> Builder
151−localTimeToBuilder = primBounded TPP.localTime
210+localTimeToBuilder (LocalTime day tod) =
211+ dayToBuilder day ++ fromChar ' ' ++ timeOfDayToBuilder tod
152212
153213unboundedToBuilder :: (a -> Builder) -> (Unbounded a -> Builder)
154214unboundedToBuilder finiteToBuilder unbounded
155215 = case unbounded of
156− NegInfinity -> byteString "-infinity"
216+ NegInfinity -> fromByteString "-infinity"
157217 Finite a -> finiteToBuilder a
158− PosInfinity -> byteString "infinity"
218+ PosInfinity -> fromByteString "infinity"
159219
160220utcTimestampToBuilder :: UTCTimestamp -> Builder
161221utcTimestampToBuilder = unboundedToBuilder utcTimeToBuilder
@@ -169,8 +229,54 @@ localTimestampToBuilder = unboundedToBuilder localTimeToBuilder
169229dateToBuilder :: Date -> Builder
170230dateToBuilder = unboundedToBuilder dayToBuilder
171231
172−nominalDiffTimeToBuilder :: NominalDiffTime -> Builder
173−nominalDiffTimeToBuilder = TPP.nominalDiffTime
174−
175−calendarDiffTimeToBuilder :: CalendarDiffTime -> Builder
176−calendarDiffTimeToBuilder = TPP.calendarDiffTime
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 #-}
src/Database/PostgreSQL/Simple/Time/Internal.hs−3
@@ -19,9 +19,6 @@ module Database.PostgreSQL.Simple.Time.Internal
1919 , getZonedTimestamp
2020 , getUTCTime
2121 , getUTCTimestamp
22− , TimeZoneHMS
23− , getTimeZoneHMS
24− , localToUTCTimeOfDayHMS
2522 ) where
2623
2724import Database.PostgreSQL.Simple.Time.Implementation
src/Database/PostgreSQL/Simple/Time/Internal/Parser.hsdeleted−204
@@ -1,204 +0,0 @@
1−{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}
2−
3−-- |
4−-- Module: Database.PostgreSQL.Simple.Time.Internal.Parser
5−-- Copyright: (c) 2012-2015 Leon P Smith
6−-- (c) 2015 Bryan O'Sullivan
7−-- License: BSD3
8−-- Maintainer: Leon P Smith <leon@melding-monads.com>
9−-- Stability: experimental
10−--
11−-- Parsers for parsing dates and times.
12−
13−module Database.PostgreSQL.Simple.Time.Internal.Parser
14− (
15− day
16− , localTime
17− , timeOfDay
18− , timeZone
19− , UTCOffsetHMS(..)
20− , timeZoneHMS
21− , localToUTCTimeOfDayHMS
22− , utcTime
23− , zonedTime
24− , calendarDiffTime
25− ) where
26−
27−import Control.Applicative ((<$>), (<*>), (<*), (*>))
28−import Database.PostgreSQL.Simple.Compat (toPico)
29−import Data.Attoparsec.ByteString.Char8 as A
30−import Data.Bits ((.&.))
31−import Data.ByteString (ByteString)
32−import Data.Char (ord)
33−import Data.Fixed (Pico)
34−import Data.Int (Int64)
35−import Data.Maybe (fromMaybe)
36−import Data.Time.Calendar.Compat (Day, fromGregorianValid, addDays)
37−import Data.Time.Clock.Compat (UTCTime(..))
38−import Data.Time.Format.ISO8601.Compat (iso8601ParseM)
39−import Data.Time.LocalTime.Compat (CalendarDiffTime)
40−import qualified Data.ByteString.Char8 as B8
41−import qualified Data.Time.LocalTime.Compat as Local
42−
43−-- | Parse a date of the form @YYYY-MM-DD@.
44−day :: Parser Day
45−day = do
46− y <- decimal <* char '-'
47− m <- twoDigits <* char '-'
48− d <- twoDigits
49− maybe (fail "invalid date") return (fromGregorianValid y m d)
50−
51−-- | Parse a two-digit integer (e.g. day of month, hour).
52−twoDigits :: Parser Int
53−twoDigits = do
54− a <- digit
55− b <- digit
56− let c2d c = ord c .&. 15
57− return $! c2d a * 10 + c2d b
58−
59−-- | Parse a time of the form @HH:MM[:SS[.SSS]]@.
60−timeOfDay :: Parser Local.TimeOfDay
61−timeOfDay = do
62− h <- twoDigits <* char ':'
63− m <- twoDigits
64− mc <- peekChar
65− s <- case mc of
66− Just ':' -> anyChar *> seconds
67− _ -> return 0
68− if h < 24 && m < 60 && s <= 60
69− then return (Local.TimeOfDay h m s)
70− else fail "invalid time"
71−
72−-- | Parse a count of seconds, with the integer part being two digits
73−-- long.
74−seconds :: Parser Pico
75−seconds = do
76− real <- twoDigits
77− mc <- peekChar
78− case mc of
79− Just '.' -> do
80− t <- anyChar *> takeWhile1 isDigit
81− return $! parsePicos (fromIntegral real) t
82− _ -> return $! fromIntegral real
83− where
84− parsePicos :: Int64 -> B8.ByteString -> Pico
85− parsePicos a0 t = toPico (fromIntegral (t' * 10^n))
86− where n = max 0 (12 - B8.length t)
87− t' = B8.foldl' (\a c -> 10 * a + fromIntegral (ord c .&. 15)) a0
88− (B8.take 12 t)
89−
90−-- | Parse a time zone, and return 'Nothing' if the offset from UTC is
91−-- zero. (This makes some speedups possible.)
92−timeZone :: Parser (Maybe Local.TimeZone)
93−timeZone = do
94− ch <- satisfy $ \c -> c == '+' || c == '-' || c == 'Z'
95− if ch == 'Z'
96− then return Nothing
97− else do
98− h <- twoDigits
99− mm <- peekChar
100− m <- case mm of
101− Just ':' -> anyChar *> twoDigits
102− _ -> return 0
103− let off | ch == '-' = negate off0
104− | otherwise = off0
105− off0 = h * 60 + m
106− case undefined of
107− _ | off == 0 ->
108− return Nothing
109− | h > 23 || m > 59 ->
110− fail "invalid time zone offset"
111− | otherwise ->
112− let !tz = Local.minutesToTimeZone off
113− in return (Just tz)
114−
115−data UTCOffsetHMS = UTCOffsetHMS {-# UNPACK #-} !Int {-# UNPACK #-} !Int {-# UNPACK #-} !Int
116−
117−-- | Parse a time zone, and return 'Nothing' if the offset from UTC is
118−-- zero. (This makes some speedups possible.)
119−timeZoneHMS :: Parser (Maybe UTCOffsetHMS)
120−timeZoneHMS = do
121− ch <- satisfy $ \c -> c == '+' || c == '-' || c == 'Z'
122− if ch == 'Z'
123− then return Nothing
124− else do
125− h <- twoDigits
126− m <- maybeTwoDigits
127− s <- maybeTwoDigits
128− case undefined of
129− _ | h == 0 && m == 0 && s == 0 ->
130− return Nothing
131− | h > 23 || m >= 60 || s >= 60 ->
132− fail "invalid time zone offset"
133− | otherwise ->
134− if ch == '+'
135− then let !tz = UTCOffsetHMS h m s
136− in return (Just tz)
137− else let !tz = UTCOffsetHMS (-h) (-m) (-s)
138− in return (Just tz)
139− where
140− maybeTwoDigits = do
141− ch <- peekChar
142− case ch of
143− Just ':' -> anyChar *> twoDigits
144− _ -> return 0
145−
146−localToUTCTimeOfDayHMS :: UTCOffsetHMS -> Local.TimeOfDay -> (Integer, Local.TimeOfDay)
147−localToUTCTimeOfDayHMS (UTCOffsetHMS dh dm ds) (Local.TimeOfDay h m s) =
148− (\ !a !b -> (a,b)) dday (Local.TimeOfDay h'' m'' s'')
149− where
150− s' = s - fromIntegral ds
151− (!s'', m')
152− | s' < 0 = (s' + 60, m - dm - 1)
153− | s' >= 60 = (s' - 60, m - dm + 1)
154− | otherwise = (s' , m - dm )
155− (!m'', h')
156− | m' < 0 = (m' + 60, h - dh - 1)
157− | m' >= 60 = (m' - 60, h - dh + 1)
158− | otherwise = (m' , h - dh )
159− (!h'', dday)
160− | h' < 0 = (h' + 24, -1)
161− | h' >= 24 = (h' - 24, 1)
162− | otherwise = (h' , 0)
163−
164−
165−-- | Parse a date and time, of the form @YYYY-MM-DD HH:MM:SS@.
166−-- The space may be replaced with a @T@. The number of seconds may be
167−-- followed by a fractional component.
168−localTime :: Parser Local.LocalTime
169−localTime = Local.LocalTime <$> day <* daySep <*> timeOfDay
170− where daySep = satisfy (\c -> c == ' ' || c == 'T')
171−
172−-- | Behaves as 'zonedTime', but converts any time zone offset into a
173−-- UTC time.
174−utcTime :: Parser UTCTime
175−utcTime = do
176− (Local.LocalTime d t) <- localTime
177− mtz <- timeZoneHMS
178− case mtz of
179− Nothing -> let !tt = Local.timeOfDayToTime t
180− in return (UTCTime d tt)
181− Just tz -> let !(dd,t') = localToUTCTimeOfDayHMS tz t
182− !d' = addDays dd d
183− !tt = Local.timeOfDayToTime t'
184− in return (UTCTime d' tt)
185−
186−-- | Parse a date with time zone info. Acceptable formats:
187−--
188−-- @YYYY-MM-DD HH:MM:SS Z@
189−--
190−-- The first space may instead be a @T@, and the second space is
191−-- optional. The @Z@ represents UTC. The @Z@ may be replaced with a
192−-- time zone offset of the form @+0000@ or @-08:00@, where the first
193−-- two digits are hours, the @:@ is optional and the second two digits
194−-- (also optional) are minutes.
195−zonedTime :: Parser Local.ZonedTime
196−zonedTime = Local.ZonedTime <$> localTime <*> (fromMaybe utc <$> timeZone)
197−
198−utc :: Local.TimeZone
199−utc = Local.TimeZone 0 False ""
200−
201−calendarDiffTime :: Parser CalendarDiffTime
202−calendarDiffTime = do
203− contents <- takeByteString
204− iso8601ParseM $ B8.unpack contents
src/Database/PostgreSQL/Simple/Time/Internal/Printer.hsdeleted−135
@@ -1,135 +0,0 @@
1−{-# LANGUAGE BangPatterns, ViewPatterns #-}
2−
3−------------------------------------------------------------------------------
4−-- Module: Database.PostgreSQL.Simple.Time.Internal.Printer
5−-- Copyright: (c) 2012-2015 Leon P Smith
6−-- License: BSD3
7−-- Maintainer: Leon P Smith <leon@melding-monads.com>
8−-- Stability: experimental
9−------------------------------------------------------------------------------
10−
11−module Database.PostgreSQL.Simple.Time.Internal.Printer
12− (
13− day
14− , timeOfDay
15− , timeZone
16− , utcTime
17− , localTime
18− , zonedTime
19− , nominalDiffTime
20− , calendarDiffTime
21− ) where
22−
23−import Control.Arrow ((>>>))
24−import Data.ByteString.Builder (Builder, byteString, integerDec)
25−import Data.ByteString.Builder.Prim
26− ( liftFixedToBounded, (>$<), (>*<)
27− , BoundedPrim, primBounded, condB, emptyB, FixedPrim, char8, int32Dec)
28−import Data.Char ( chr )
29−import Data.Int ( Int32, Int64 )
30−import Data.String (fromString)
31−import Data.Time.Compat
32− ( UTCTime(..), ZonedTime(..), LocalTime(..), NominalDiffTime
33− , Day, toGregorian, TimeOfDay(..), timeToTimeOfDay
34− , TimeZone, timeZoneMinutes )
35−import Data.Time.Format.ISO8601.Compat (iso8601Show)
36−import Data.Time.LocalTime.Compat (CalendarDiffTime)
37−import Database.PostgreSQL.Simple.Compat ((<>), fromPico)
38−import Unsafe.Coerce (unsafeCoerce)
39−
40−liftB :: FixedPrim a -> BoundedPrim a
41−liftB = liftFixedToBounded
42−
43−digit :: FixedPrim Int
44−digit = (\x -> chr (x + 48)) >$< char8
45−
46−digits2 :: FixedPrim Int
47−digits2 = (`quotRem` 10) >$< (digit >*< digit)
48−
49−digits3 :: FixedPrim Int
50−digits3 = (`quotRem` 10) >$< (digits2 >*< digit)
51−
52−digits4 :: FixedPrim Int
53−digits4 = (`quotRem` 10) >$< (digits3 >*< digit)
54−
55−frac :: BoundedPrim Int64
56−frac = condB (== 0) emptyB ((,) '.' >$< (liftB char8 >*< trunc12))
57− where
58− trunc12 :: BoundedPrim Int64
59− trunc12 = (`quotRem` 1000000) >$<
60− condB (\(_,y) -> y == 0)
61− (fst >$< trunc6)
62− (liftB digits6 >*< trunc6)
63−
64− digitB = liftB digit
65−
66− digits6 = (fromIntegral >>> (`quotRem` 10)) >$< (digits5 >*< digit)
67− digits5 = (`quotRem` 10) >$< (digits4 >*< digit)
68−
69− trunc6 = (fromIntegral >>> (`quotRem` 100000)) >$< (digitB >*< trunc5)
70− trunc5 = condB (== 0) emptyB ((`quotRem` 10000) >$< (digitB >*< trunc4))
71− trunc4 = condB (== 0) emptyB ((`quotRem` 1000) >$< (digitB >*< trunc3))
72− trunc3 = condB (== 0) emptyB ((`quotRem` 100) >$< (digitB >*< trunc2))
73− trunc2 = condB (== 0) emptyB ((`quotRem` 10) >$< (digitB >*< trunc1))
74− trunc1 = condB (== 0) emptyB digitB
75−
76−
77−year :: BoundedPrim Int32
78−year = condB (>= 10000) int32Dec (checkBCE >$< liftB digits4)
79− where
80− checkBCE :: Int32 -> Int
81− checkBCE y
82− | y > 0 = fromIntegral y
83− | otherwise = error msg
84−
85− msg = "Database.PostgreSQL.Simple.Time.Printer.year: years BCE not supported"
86−
87−day :: BoundedPrim Day
88−day = toYMD >$< (year >*< liftB (char8 >*< digits2 >*< char8 >*< digits2))
89− where
90− toYMD (toGregorian -> (fromIntegral -> !y, !m,!d)) = (y,('-',(m,('-',d))))
91−
92−timeOfDay :: BoundedPrim TimeOfDay
93−timeOfDay = f >$< (hh_mm_ >*< ss)
94− where
95− f (TimeOfDay h m s) = ((h,(':',(m,':'))),s)
96−
97− hh_mm_ = liftB (digits2 >*< char8 >*< digits2 >*< char8)
98−
99− ss = (\s -> fromIntegral (fromPico s) `quotRem` 1000000000000) >$<
100− (liftB (fromIntegral >$< digits2) >*< frac)
101−
102−timeZone :: BoundedPrim TimeZone
103−timeZone = timeZoneMinutes >$< tz
104− where
105− tz = condB (>= 0) ((,) '+' >$< tzh) ((,) '-' . negate >$< tzh)
106−
107− tzh = liftB char8 >*< ((`quotRem` 60) >$< (liftB digits2 >*< tzm))
108−
109− tzm = condB (==0) emptyB ((,) ':' >$< liftB (char8 >*< digits2))
110−
111−utcTime :: BoundedPrim UTCTime
112−utcTime = f >$< (day >*< liftB char8 >*< timeOfDay >*< liftB char8)
113− where f (UTCTime d (timeToTimeOfDay -> tod)) = (d,(' ',(tod,'Z')))
114−
115−localTime :: BoundedPrim LocalTime
116−localTime = f >$< (day >*< liftB char8 >*< timeOfDay)
117− where f (LocalTime d tod) = (d, (' ', tod))
118−
119−zonedTime :: BoundedPrim ZonedTime
120−zonedTime = f >$< (localTime >*< timeZone)
121− where f (ZonedTime lt tz) = (lt, tz)
122−
123−
124−nominalDiffTime :: NominalDiffTime -> Builder
125−nominalDiffTime xy = integerDec x <> primBounded frac (abs (fromIntegral y))
126− where
127− (x,y) = fromPico (unsafeCoerce xy) `quotRem` 1000000000000
128−
129−calendarDiffTime :: CalendarDiffTime -> Builder
130−calendarDiffTime = byteString
131− . fromString
132− -- from the docs: "Beware: fromString truncates multi-byte characters to octets".
133− -- However, I think this is a safe usage, because ISO8601-encoding seems restricted
134− -- to ASCII output.
135− . iso8601Show
src/Database/PostgreSQL/Simple/ToField.hs+44−198
@@ -1,6 +1,5 @@
1−{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-}
1+{-# LANGUAGE DeriveDataTypeable, DeriveFunctor #-}
22{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
3−{-# LANGUAGE PolyKinds #-}
43
54------------------------------------------------------------------------------
65-- |
@@ -10,6 +9,7 @@
109-- License: BSD3
1110-- Maintainer: Leon P Smith <leon@melding-monads.com>
1211-- Stability: experimental
12+-- Portability: portable
1313--
1414-- The 'ToField' typeclass, for rendering a parameter to a SQL query.
1515--
@@ -19,48 +19,30 @@ module Database.PostgreSQL.Simple.ToField
1919 (
2020 Action(..)
2121 , ToField(..)
22− , toJSONField
2322 , inQuotes
2423 ) where
2524
26−import Control.Applicative (Const(Const))
27−import qualified Data.Aeson as JSON
28−import Data.ByteString (ByteString)
29−import Data.ByteString.Builder
30− ( Builder, byteString, char8, stringUtf8
31− , intDec, int8Dec, int16Dec, int32Dec, int64Dec, integerDec
32− , wordDec, word8Dec, word16Dec, word32Dec, word64Dec
33− , floatDec, doubleDec
34− )
35−import Data.Functor.Identity (Identity(Identity))
25+import Blaze.ByteString.Builder (Builder, fromByteString, toByteString)
26+import Blaze.ByteString.Builder.Char8 (fromChar)
27+import Blaze.Text (integral, double, float)
28+import Data.ByteString (ByteString)
3629import Data.Int (Int8, Int16, Int32, Int64)
3730import Data.List (intersperse)
3831import Data.Monoid (mappend)
39−import Data.Time.Compat (Day, TimeOfDay, LocalTime, UTCTime, ZonedTime, NominalDiffTime)
40−import Data.Time.LocalTime.Compat (CalendarDiffTime)
32+import Data.Time (Day, TimeOfDay, LocalTime, UTCTime, ZonedTime)
4133import Data.Typeable (Typeable)
4234import Data.Word (Word, Word8, Word16, Word32, Word64)
43−import {-# SOURCE #-} Database.PostgreSQL.Simple.ToRow
44−import Database.PostgreSQL.Simple.Types
45−import Database.PostgreSQL.Simple.Compat (toByteString)
46−
35+import Database.PostgreSQL.Simple.Types (Binary(..), In(..), Null)
36+import qualified Blaze.ByteString.Builder.Char.Utf8 as Utf8
4737import qualified Data.ByteString as SB
4838import qualified Data.ByteString.Lazy as LB
49−import Data.CaseInsensitive (CI)
50−import qualified Data.CaseInsensitive as CI
5139import qualified Data.Text as ST
5240import qualified Data.Text.Encoding as ST
5341import qualified Data.Text.Lazy as LT
54−import qualified Data.Text.Lazy.Builder as LT
55−import Data.UUID.Types (UUID)
56−import qualified Data.UUID.Types as UUID
5742import Data.Vector (Vector)
5843import qualified Data.Vector as V
5944import qualified Database.PostgreSQL.LibPQ as PQ
6045import Database.PostgreSQL.Simple.Time
61−import Data.Scientific (Scientific)
62−import Data.Text.Lazy.Builder.Scientific (scientificBuilder)
63−import Foreign.C.Types (CUInt(..))
6446
6547-- | How to render an element when substituting it into a query.
6648data Action =
@@ -76,20 +58,15 @@ data Action =
7658 | EscapeByteA ByteString
7759 -- ^ Escape binary data for use as a @bytea@ literal. Include surrounding
7860 -- quotes. This is used by the 'Binary' newtype wrapper.
79− | EscapeIdentifier ByteString
80− -- ^ Escape before substituting. Use for all sql identifiers like
81− -- table, column names, etc. This is used by the 'Identifier' newtype
82− -- wrapper.
8361 | Many [Action]
8462 -- ^ Concatenate a series of rendering actions.
8563 deriving (Typeable)
8664
8765instance Show Action where
88− show (Plain b) = "Plain " ++ show (toByteString b)
89− show (Escape b) = "Escape " ++ show b
90− show (EscapeByteA b) = "EscapeByteA " ++ show b
91− show (EscapeIdentifier b) = "EscapeIdentifier " ++ show b
92− show (Many b) = "Many " ++ show b
66+ show (Plain b) = "Plain " ++ show (toByteString b)
67+ show (Escape b) = "Escape " ++ show b
68+ show (EscapeByteA b) = "EscapeByteA " ++ show b
69+ show (Many b) = "Many " ++ show b
9370
9471-- | A type that may be used as a single parameter to a SQL query.
9572class ToField a where
@@ -100,102 +77,86 @@ instance ToField Action where
10077 toField a = a
10178 {-# INLINE toField #-}
10279
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−
11180instance (ToField a) => ToField (Maybe a) where
11281 toField Nothing = renderNull
11382 toField (Just a) = toField a
11483 {-# INLINE toField #-}
11584
11685instance (ToField a) => ToField (In [a]) where
117− toField (In []) = Plain $ byteString "(null)"
86+ toField (In []) = Plain $ fromByteString "(null)"
11887 toField (In xs) = Many $
119− Plain (char8 '(') :
120− (intersperse (Plain (char8 ',')) . map toField $ xs) ++
121− [Plain (char8 ')')]
88+ Plain (fromChar '(') :
89+ (intersperse (Plain (fromChar ',')) . map toField $ xs) ++
90+ [Plain (fromChar ')')]
12291
12392renderNull :: Action
124−renderNull = Plain (byteString "null")
93+renderNull = Plain (fromByteString "null")
12594
12695instance ToField Null where
12796 toField _ = renderNull
12897 {-# INLINE toField #-}
12998
130−instance ToField Default where
131− toField _ = Plain (byteString "default")
132− {-# INLINE toField #-}
133−
13499instance ToField Bool where
135− toField True = Plain (byteString "true")
136− toField False = Plain (byteString "false")
100+ toField True = Plain (fromByteString "true")
101+ toField False = Plain (fromByteString "false")
137102 {-# INLINE toField #-}
138103
139104instance ToField Int8 where
140− toField = Plain . int8Dec
105+ toField = Plain . integral
141106 {-# INLINE toField #-}
142107
143108instance ToField Int16 where
144− toField = Plain . int16Dec
109+ toField = Plain . integral
145110 {-# INLINE toField #-}
146111
147112instance ToField Int32 where
148− toField = Plain . int32Dec
113+ toField = Plain . integral
149114 {-# INLINE toField #-}
150115
151116instance ToField Int where
152− toField = Plain . intDec
117+ toField = Plain . integral
153118 {-# INLINE toField #-}
154119
155120instance ToField Int64 where
156− toField = Plain . int64Dec
121+ toField = Plain . integral
157122 {-# INLINE toField #-}
158123
159124instance ToField Integer where
160− toField = Plain . integerDec
125+ toField = Plain . integral
161126 {-# INLINE toField #-}
162127
163128instance ToField Word8 where
164− toField = Plain . word8Dec
129+ toField = Plain . integral
165130 {-# INLINE toField #-}
166131
167132instance ToField Word16 where
168− toField = Plain . word16Dec
133+ toField = Plain . integral
169134 {-# INLINE toField #-}
170135
171136instance ToField Word32 where
172− toField = Plain . word32Dec
137+ toField = Plain . integral
173138 {-# INLINE toField #-}
174139
175140instance ToField Word where
176− toField = Plain . wordDec
141+ toField = Plain . integral
177142 {-# INLINE toField #-}
178143
179144instance ToField Word64 where
180− toField = Plain . word64Dec
145+ toField = Plain . integral
181146 {-# INLINE toField #-}
182147
183148instance ToField PQ.Oid where
184− toField = Plain . \(PQ.Oid (CUInt x)) -> word32Dec x
149+ toField = Plain . integral . \(PQ.Oid x) -> x
185150 {-# INLINE toField #-}
186151
187152instance ToField Float where
188− toField v | isNaN v || isInfinite v = Plain (inQuotes (floatDec v))
189− | otherwise = Plain (floatDec v)
153+ toField v | isNaN v || isInfinite v = Plain (inQuotes (float v))
154+ | otherwise = Plain (float v)
190155 {-# INLINE toField #-}
191156
192157instance ToField Double where
193− toField v | isNaN v || isInfinite v = Plain (inQuotes (doubleDec v))
194− | otherwise = Plain (doubleDec v)
195− {-# INLINE toField #-}
196−
197−instance ToField Scientific where
198− toField x = toField (LT.toLazyText (scientificBuilder x))
158+ toField v | isNaN v || isInfinite v = Plain (inQuotes (double v))
159+ | otherwise = Plain (double v)
199160 {-# INLINE toField #-}
200161
201162instance ToField (Binary SB.ByteString) where
@@ -206,20 +167,6 @@ instance ToField (Binary LB.ByteString) where
206167 toField (Binary bs) = (EscapeByteA . SB.concat . LB.toChunks) bs
207168 {-# INLINE toField #-}
208169
209−instance ToField Identifier where
210− toField (Identifier bs) = EscapeIdentifier (ST.encodeUtf8 bs)
211− {-# INLINE toField #-}
212−
213−instance ToField QualifiedIdentifier where
214− toField (QualifiedIdentifier (Just s) t) =
215− Many [ EscapeIdentifier (ST.encodeUtf8 s)
216− , Plain (char8 '.')
217− , EscapeIdentifier (ST.encodeUtf8 t)
218− ]
219− toField (QualifiedIdentifier Nothing t) =
220− EscapeIdentifier (ST.encodeUtf8 t)
221− {-# INLINE toField #-}
222−
223170instance ToField SB.ByteString where
224171 toField = Escape
225172 {-# INLINE toField #-}
@@ -233,23 +180,13 @@ instance ToField ST.Text where
233180 {-# INLINE toField #-}
234181
235182instance ToField [Char] where
236− toField = Escape . toByteString . stringUtf8
183+ toField = Escape . toByteString . Utf8.fromString
237184 {-# INLINE toField #-}
238185
239186instance ToField LT.Text where
240187 toField = toField . LT.toStrict
241188 {-# INLINE toField #-}
242189
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−
253190instance ToField UTCTime where
254191 toField = Plain . inQuotes . utcTimeToBuilder
255192 {-# INLINE toField #-}
@@ -286,108 +223,17 @@ instance ToField Date where
286223 toField = Plain . inQuotes . dateToBuilder
287224 {-# INLINE toField #-}
288225
289−instance ToField NominalDiffTime where
290− toField = Plain . inQuotes . nominalDiffTimeToBuilder
291− {-# INLINE toField #-}
292−
293−instance ToField CalendarDiffTime where
294− toField = Plain . inQuotes . calendarDiffTimeToBuilder
295− {-# INLINE toField #-}
296−
297−instance (ToField a) => ToField (PGArray a) where
298− toField pgArray =
299− case fromPGArray pgArray of
300− [] -> Plain (byteString "'{}'")
301− xs -> Many $
302− Plain (byteString "ARRAY[") :
303− (intersperse (Plain (char8 ',')) . map toField $ xs) ++
304− [Plain (char8 ']')]
305− -- Because the ARRAY[...] input syntax is being used, it is possible
306− -- that the use of type-specific separator characters is unnecessary.
307−
308226instance (ToField a) => ToField (Vector a) where
309− toField = toField . PGArray . V.toList
310−
311−instance ToField UUID where
312− toField = Plain . inQuotes . byteString . UUID.toASCIIBytes
313−
314−instance ToField JSON.Value where
315− toField = toField . JSON.encode
316−
317−-- | Convert a Haskell value to JSON using 'JSON.toEncoding'.
318−--
319−-- This can be used as the default implementation for the 'toField'
320−-- method for Haskell types that have a JSON representation in
321−-- PostgreSQL.
322−toJSONField :: JSON.ToJSON a => a -> Action
323−toJSONField = toField . JSON.encode
227+ toField xs = Many $
228+ Plain (fromByteString "ARRAY[") :
229+ (intersperse (Plain (fromChar ',')) . map toField $ V.toList xs) ++
230+ [Plain (fromChar ']')]
231+ -- Because the ARRAY[...] input syntax is being used, it is possible
232+ -- that the use of type-specific separator characters is unnecessary.
324233
325234-- | Surround a string with single-quote characters: \"@'@\"
326235--
327236-- This function /does not/ perform any other escaping.
328237inQuotes :: Builder -> Builder
329238inQuotes b = quote `mappend` b `mappend` quote
330− where quote = char8 '\''
331−
332−interleaveFoldr :: (a -> [b] -> [b]) -> b -> [b] -> [a] -> [b]
333−interleaveFoldr f b bs' as = foldr (\a bs -> b : f a bs) bs' as
334−{-# INLINE interleaveFoldr #-}
335−
336−instance ToRow a => ToField (Values a) where
337− toField (Values types rows) =
338− case rows of
339− [] -> case types of
340− [] -> error norows
341− (_:_) -> values $ typedRow (repeat (lit "null"))
342− types
343− [lit " LIMIT 0)"]
344− (_:_) -> case types of
345− [] -> values $ untypedRows rows [litC ')']
346− (_:_) -> values $ typedRows rows types [litC ')']
347− where
348− funcname = "Database.PostgreSQL.Simple.toField :: Values a -> Action"
349− norows = funcname ++ " either values or types must be non-empty"
350− emptyrow = funcname ++ " each row must contain at least one column"
351− lit = Plain . byteString
352− litC = Plain . char8
353− values x = Many (lit "(VALUES ": x)
354−
355− typedField :: (Action, QualifiedIdentifier) -> [Action] -> [Action]
356− typedField (val,typ) rest = val : lit "::" : toField typ : rest
357−
358− typedRow :: [Action] -> [QualifiedIdentifier] -> [Action] -> [Action]
359− typedRow (val:vals) (typ:typs) rest =
360− litC '(' :
361− typedField (val,typ) ( interleaveFoldr
362− typedField
363− (litC ',')
364− (litC ')' : rest)
365− (zip vals typs) )
366− typedRow _ _ _ = error emptyrow
367−
368− untypedRow :: [Action] -> [Action] -> [Action]
369− untypedRow (val:vals) rest =
370− litC '(' : val :
371− interleaveFoldr
372− (:)
373− (litC ',')
374− (litC ')' : rest)
375− vals
376− untypedRow _ _ = error emptyrow
377−
378− typedRows :: ToRow a => [a] -> [QualifiedIdentifier] -> [Action] -> [Action]
379− typedRows [] _ _ = error funcname
380− typedRows (val:vals) typs rest =
381− typedRow (toRow val) typs (multiRows vals rest)
382−
383− untypedRows :: ToRow a => [a] -> [Action] -> [Action]
384− untypedRows [] _ = error funcname
385− untypedRows (val:vals) rest =
386− untypedRow (toRow val) (multiRows vals rest)
387−
388− multiRows :: ToRow a => [a] -> [Action] -> [Action]
389− multiRows vals rest = interleaveFoldr
390− (untypedRow . toRow)
391− (litC ',')
392− rest
393− vals
239+ where quote = Utf8.fromChar '\''
src/Database/PostgreSQL/Simple/ToField.hs-boot−23
@@ -1,29 +1,6 @@
11module Database.PostgreSQL.Simple.ToField where
22
33import Database.PostgreSQL.Simple.Types
4−import Data.ByteString.Builder(Builder)
5−import Data.ByteString(ByteString)
6−
7−-- | How to render an element when substituting it into a query.
8−data Action =
9− Plain Builder
10− -- ^ Render without escaping or quoting. Use for non-text types
11− -- such as numbers, when you are /certain/ that they will not
12− -- introduce formatting vulnerabilities via use of characters such
13− -- as spaces or \"@'@\".
14− | Escape ByteString
15− -- ^ Escape and enclose in quotes before substituting. Use for all
16− -- text-like types, and anything else that may contain unsafe
17− -- characters when rendered.
18− | EscapeByteA ByteString
19− -- ^ Escape binary data for use as a @bytea@ literal. Include surrounding
20− -- quotes. This is used by the 'Binary' newtype wrapper.
21− | EscapeIdentifier ByteString
22− -- ^ Escape before substituting. Use for all sql identifiers like
23− -- table, column names, etc. This is used by the 'Identifier' newtype
24− -- wrapper.
25− | Many [Action]
26− -- ^ Concatenate a series of rendering actions.
274
285class ToField a
296
src/Database/PostgreSQL/Simple/ToRow.hs+3−129
@@ -1,4 +1,3 @@
1−{-# LANGUAGE DefaultSignatures, FlexibleInstances, FlexibleContexts #-}
21------------------------------------------------------------------------------
32-- |
43-- Module: Database.PostgreSQL.Simple.ToRow
@@ -7,6 +6,7 @@
76-- License: BSD3
87-- Maintainer: Leon P Smith <leon@melding-monads.com>
98-- Stability: experimental
9+-- Portability: portable
1010--
1111-- The 'ToRow' typeclass, for rendering a collection of
1212-- parameters to a SQL query.
@@ -23,33 +23,14 @@ module Database.PostgreSQL.Simple.ToRow
2323
2424import Database.PostgreSQL.Simple.ToField (Action(..), ToField(..))
2525import Database.PostgreSQL.Simple.Types (Only(..), (:.)(..))
26−import GHC.Generics
2726
2827-- | A collection type that can be turned into a list of rendering
2928-- 'Action's.
3029--
31−-- Instances should use the 'toField' method of the 'ToField' class
30+-- Instances should use the 'render' method of the 'Param' class
3231-- 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.
4932class ToRow a where
5033 toRow :: a -> [Action]
51− default toRow :: (Generic a, GToRow (Rep a)) => a -> [Action]
52− toRow = gtoRow . from
5334 -- ^ ToField a collection of values.
5435
5536instance ToRow () where
@@ -105,115 +86,8 @@ instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,
10586 [toField a, toField b, toField c, toField d, toField e, toField f,
10687 toField g, toField h, toField i, toField j]
10788
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−
19889instance (ToField a) => ToRow [a] where
19990 toRow = map toField
20091
20192instance (ToRow a, ToRow b) => ToRow (a :. b) where
202− toRow (a :. b) = toRow a ++ toRow b
203−
204−
205−-- Type class for default implementation of ToRow using generics
206−class GToRow f where
207− gtoRow :: f p -> [Action]
208−
209−instance GToRow f => GToRow (M1 c i f) where
210− gtoRow (M1 x) = gtoRow x
211−
212−instance (GToRow f, GToRow g) => GToRow (f :*: g) where
213− gtoRow (f :*: g) = gtoRow f ++ gtoRow g
214−
215−instance (ToField a) => GToRow (K1 R a) where
216− gtoRow (K1 a) = [toField a]
217−
218−instance GToRow U1 where
219− gtoRow _ = []
93+ toRow (a :. b) = toRow a ++ toRow b
src/Database/PostgreSQL/Simple/ToRow.hs-boot+2−12
@@ -1,18 +1,8 @@
1−{-# LANGUAGE DefaultSignatures, FlexibleInstances, FlexibleContexts #-}
2−module Database.PostgreSQL.Simple.ToRow (
3− ToRow(..)
4− ) where
1+module Database.PostgreSQL.Simple.ToRow where
52
63import Database.PostgreSQL.Simple.Types
74import {-# SOURCE #-} Database.PostgreSQL.Simple.ToField
8−import GHC.Generics
95
10−class ToRow a where
11− toRow :: a -> [Action]
12− default toRow :: (Generic a, GToRow (Rep a)) => a -> [Action]
13− toRow = gtoRow . from
14−
15−class GToRow f where
16− gtoRow :: f p -> [Action]
6+class ToRow a
177
188instance ToField a => ToRow (Only a)
src/Database/PostgreSQL/Simple/Transaction.hs+28−103
@@ -1,14 +1,4 @@
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−------------------------------------------------------------------------------
1+{-# LANGUAGE RecordWildCards #-}
122
133module Database.PostgreSQL.Simple.Transaction
144 (
@@ -17,7 +7,6 @@ module Database.PostgreSQL.Simple.Transaction
177 , withTransactionLevel
188 , withTransactionMode
199 , withTransactionModeRetry
20− , withTransactionModeRetry'
2110 , withTransactionSerializable
2211 , TransactionMode(..)
2312 , IsolationLevel(..)
@@ -31,32 +20,18 @@ module Database.PostgreSQL.Simple.Transaction
3120 , beginMode
3221 , commit
3322 , rollback
34−
35− -- * Savepoint
36− , withSavepoint
37− , Savepoint
38− , newSavepoint
39− , releaseSavepoint
40− , rollbackToSavepoint
41− , rollbackToAndReleaseSavepoint
42−
43− -- * Error predicates
44− , isSerializationError
45− , isNoActiveTransactionError
46− , isFailedTransactionError
4723 ) where
4824
49−import qualified Control.Exception as E
25+import Control.Exception hiding (mask)
5026import qualified Data.ByteString as B
5127import Database.PostgreSQL.Simple.Internal
5228import Database.PostgreSQL.Simple.Types
53−import Database.PostgreSQL.Simple.Errors
54−import Database.PostgreSQL.Simple.Compat (mask, (<>))
29+import Database.PostgreSQL.Simple.Compat(mask)
5530
5631
5732-- | Of the four isolation levels defined by the SQL standard,
5833-- these are the three levels distinguished by PostgreSQL as of version 9.0.
59−-- See <https://www.postgresql.org/docs/9.5/static/transaction-iso.html>
34+-- See <http://www.postgresql.org/docs/9.1/static/transaction-iso.html>
6035-- for more information. Note that prior to PostgreSQL 9.0, 'RepeatableRead'
6136-- was equivalent to 'Serializable'.
6237
@@ -109,8 +84,6 @@ defaultReadWriteMode = DefaultReadWriteMode
10984-- If the action throws /any/ kind of exception (not just a
11085-- PostgreSQL-related exception), the transaction will be rolled back using
11186-- 'rollback', then the exception will be rethrown.
112−--
113−-- For nesting transactions, see 'withSavepoint'.
11487withTransaction :: Connection -> IO a -> IO a
11588withTransaction = withTransactionMode defaultTransactionMode
11689
@@ -131,7 +104,15 @@ withTransactionSerializable =
131104 { isolationLevel = Serializable
132105 , readWriteMode = ReadWrite
133106 }
134− isSerializationError
107+ retryOnNotSerializable
108+ where
109+ retryOnNotSerializable exception =
110+ case exception of
111+ SqlError{..} | sqlState == serialization_failure
112+ -> True
113+ _ -> False
114+ -- http://www.postgresql.org/docs/current/static/errcodes-appendix.html
115+ serialization_failure = "40001"
135116
136117-- | Execute an action inside a SQL transaction with a given isolation level.
137118withTransactionLevel :: IsolationLevel -> Connection -> IO a -> IO a
@@ -143,48 +124,41 @@ withTransactionMode :: TransactionMode -> Connection -> IO a -> IO a
143124withTransactionMode mode conn act =
144125 mask $ \restore -> do
145126 beginMode mode conn
146− r <- restore act `E.onException` rollback_ conn
127+ r <- restore act `onException` rollback conn
147128 commit conn
148129 return r
149130
150−-- | 'withTransactionModeRetry'' but with the exception type pinned to 'SqlError'.
151−withTransactionModeRetry :: TransactionMode -> (SqlError -> Bool) -> Connection -> IO a -> IO a
152−withTransactionModeRetry = withTransactionModeRetry'
153−
154131-- | Like 'withTransactionMode', but also takes a custom callback to
155−-- determine if a transaction should be retried if an exception occurs.
156−-- If the callback returns 'True', then the transaction will be retried.
157−-- If the callback returns 'False', or an exception other than an @e@
132+-- determine if a transaction should be retried if an 'SqlError' occurs.
133+-- If the callback returns True, then the transaction will be retried.
134+-- If the callback returns False, or an exception other than an 'SqlError'
158135-- occurs then the transaction will be rolled back and the exception rethrown.
159136--
160137-- This is used to implement 'withTransactionSerializable'.
161−withTransactionModeRetry' :: forall a e. E.Exception e => TransactionMode -> (e -> Bool) -> Connection -> IO a -> IO a
162−withTransactionModeRetry' mode shouldRetry conn act =
138+withTransactionModeRetry :: TransactionMode -> (SqlError -> Bool) -> Connection -> IO a -> IO a
139+withTransactionModeRetry mode shouldRetry conn act =
163140 mask $ \restore ->
164− retryLoop $ E.try $ do
165− a <- restore act `E.onException` rollback_ conn
141+ retryLoop $ try $ do
142+ a <- restore act
166143 commit conn
167144 return a
168145 where
169− retryLoop :: IO (Either e a) -> IO a
146+ retryLoop :: IO (Either SomeException a) -> IO a
170147 retryLoop act' = do
171148 beginMode mode conn
172149 r <- act'
173150 case r of
174− Left e ->
175− case shouldRetry e of
176− True -> retryLoop act'
177− False -> E.throwIO e
151+ Left e -> do
152+ rollback conn
153+ case fmap shouldRetry (fromException e) of
154+ Just True -> retryLoop act'
155+ _ -> throwIO e
178156 Right a ->
179157 return a
180158
181159-- | Rollback a transaction.
182160rollback :: Connection -> IO ()
183−rollback conn = execute_ conn "ROLLBACK" >> return ()
184−
185−-- | Rollback a transaction, ignoring any @IOErrors@
186−rollback_ :: Connection -> IO ()
187−rollback_ conn = rollback conn `E.catch` \(_ :: IOError) -> return ()
161+rollback conn = execute_ conn "ABORT" >> return ()
188162
189163-- | Commit a transaction.
190164commit :: Connection -> IO ()
@@ -213,52 +187,3 @@ beginMode mode conn = do
213187 DefaultReadWriteMode -> ""
214188 ReadWrite -> " READ WRITE"
215189 ReadOnly -> " READ ONLY"
216−
217−------------------------------------------------------------------------
218−-- Savepoint
219−
220−-- | Create a savepoint, and roll back to it if an error occurs. This may only
221−-- be used inside of a transaction, and provides a sort of
222−-- \"nested transaction\".
223−--
224−-- See <https://www.postgresql.org/docs/9.5/static/sql-savepoint.html>
225−withSavepoint :: Connection -> IO a -> IO a
226−withSavepoint conn body =
227− mask $ \restore -> do
228− sp <- newSavepoint conn
229− r <- restore body `E.onException` rollbackToAndReleaseSavepoint conn sp
230− releaseSavepoint conn sp `E.catch` \err ->
231− if isFailedTransactionError err
232− then rollbackToAndReleaseSavepoint conn sp
233− else E.throwIO err
234− return r
235−
236−-- | Create a new savepoint. This may only be used inside of a transaction.
237−newSavepoint :: Connection -> IO Savepoint
238−newSavepoint conn = do
239− name <- newTempName conn
240− _ <- execute_ conn ("SAVEPOINT " <> name)
241− return (Savepoint name)
242−
243−-- | Destroy a savepoint, but retain its effects.
244−--
245−-- Warning: this will throw a 'SqlError' matching 'isFailedTransactionError' if
246−-- the transaction is aborted due to an error. 'commit' would merely warn and
247−-- roll back.
248−releaseSavepoint :: Connection -> Savepoint -> IO ()
249−releaseSavepoint conn (Savepoint name) =
250− execute_ conn ("RELEASE SAVEPOINT " <> name) >> return ()
251−
252−-- | Roll back to a savepoint. This will not release the savepoint.
253−rollbackToSavepoint :: Connection -> Savepoint -> IO ()
254−rollbackToSavepoint conn (Savepoint name) =
255− execute_ conn ("ROLLBACK TO SAVEPOINT " <> name) >> return ()
256−
257−-- | Roll back to a savepoint and release it. This is like calling
258−-- 'rollbackToSavepoint' followed by 'releaseSavepoint', but avoids a
259−-- round trip to the database server.
260−rollbackToAndReleaseSavepoint :: Connection -> Savepoint -> IO ()
261−rollbackToAndReleaseSavepoint conn (Savepoint name) =
262− execute_ conn sql >> return ()
263− where
264− sql = "ROLLBACK TO SAVEPOINT " <> name <> "; RELEASE SAVEPOINT " <> name
src/Database/PostgreSQL/Simple/TypeInfo.hs+29−94
@@ -8,30 +8,15 @@
88-- Maintainer: Leon P Smith <leon@melding-monads.com>
99-- Stability: experimental
1010--
11−-- This module provides convenient and efficient access to parts of the
12−-- @pg_type@ metatable. At the moment, this requires PostgreSQL 8.4 if
13−-- you need to work with types that do not appear in
14−-- 'Database.PostgreSQL.Simple.TypeInfo.Static'.
15−--
16−-- The current scheme could be more efficient, especially for some use
17−-- cases. In particular, connection pools that use many user-added
18−-- types and connect to a set of servers with identical (or at least
19−-- compatible) @pg_type@ and associated tables could share a common
20−-- typeinfo cache, thus saving memory and communication between the
21−-- client and server.
22−--
2311------------------------------------------------------------------------------
2412
2513module Database.PostgreSQL.Simple.TypeInfo
2614 ( getTypeInfo
15+ , NamedOid(..)
2716 , TypeInfo(..)
28− , Attribute(..)
2917 ) where
3018
31−import qualified Data.ByteString as B
3219import qualified Data.IntMap as IntMap
33−import qualified Data.Vector as V
34−import qualified Data.Vector.Mutable as MV
3520import Control.Concurrent.MVar
3621import Control.Exception (throw)
3722
@@ -39,83 +24,33 @@ import qualified Database.PostgreSQL.LibPQ as PQ
3924import {-# SOURCE #-} Database.PostgreSQL.Simple
4025import Database.PostgreSQL.Simple.Internal
4126import Database.PostgreSQL.Simple.Types
42−import Database.PostgreSQL.Simple.TypeInfo.Types
43−import Database.PostgreSQL.Simple.TypeInfo.Static
44−
45−-- | Returns the metadata of the type with a particular oid. To find
46−-- this data, 'getTypeInfo' first consults postgresql-simple's
47−-- built-in 'staticTypeInfo' table, then checks the connection's
48−-- typeinfo cache. Finally, the database's 'pg_type' table will
49−-- be queried only if necessary, and the result will be stored
50−-- in the connections's cache.
27+import Database.PostgreSQL.Simple.BuiltinTypes
5128
5229getTypeInfo :: Connection -> PQ.Oid -> IO TypeInfo
53−getTypeInfo conn@Connection{..} oid' =
54− case staticTypeInfo oid' of
55− Just name' -> return name'
56− Nothing -> modifyMVar connectionObjects $ getTypeInfo' conn oid'
57−
58−getTypeInfo' :: Connection -> PQ.Oid -> TypeInfoCache
59− -> IO (TypeInfoCache, TypeInfo)
60−getTypeInfo' conn oid' oidmap =
61− case IntMap.lookup (oid2int oid') oidmap of
62− Just typeinfo -> return (oidmap, typeinfo)
63− Nothing -> do
64− names <- query conn "SELECT oid, typcategory, typdelim, typname,\
65− \ typelem, typrelid\
66− \ FROM pg_type WHERE oid = ?"
67− (Only oid')
68− (oidmap', typeInfo) <-
69− case names of
70− [] -> return $ throw (fatalError "invalid type oid")
71− [(typoid, typcategory, typdelim, typname, typelem_, typrelid)] -> do
72− case typcategory of
73− 'A' -> do
74− (oidmap', typelem) <- getTypeInfo' conn typelem_ oidmap
75− let !typeInfo = Array{..}
76− return $! (oidmap', typeInfo)
77− 'R' -> do
78− rngsubtypeOids <- query conn "SELECT rngsubtype\
79− \ FROM pg_range\
80− \ WHERE rngtypid = ?"
81− (Only oid')
82− case rngsubtypeOids of
83− [Only rngsubtype_] -> do
84− (oidmap', rngsubtype) <-
85− getTypeInfo' conn rngsubtype_ oidmap
86− let !typeInfo = Range{..}
87− return $! (oidmap', typeInfo)
88− _ -> fail "range subtype query failed to return exactly one result"
89− 'C' -> do
90− cols <- query conn "SELECT attname, atttypid\
91− \ FROM pg_attribute\
92− \ WHERE attrelid = ?\
93− \ AND attnum > 0\
94− \ AND NOT attisdropped\
95− \ ORDER BY attnum"
96− (Only typrelid)
97− vec <- MV.new $! length cols
98− (oidmap', attributes) <- getAttInfos conn cols oidmap vec 0
99− let !typeInfo = Composite{..}
100− return $! (oidmap', typeInfo)
101− _ -> do
102− let !typeInfo = Basic{..}
103− return $! (oidmap, typeInfo)
104− _ -> fail "typename query returned more than one result"
105− -- oid is a primary key, so the query should
106− -- never return more than one result
107− let !oidmap'' = IntMap.insert (oid2int oid') typeInfo oidmap'
108− return $! (oidmap'', typeInfo)
109−
110−getAttInfos :: Connection -> [(B.ByteString, PQ.Oid)] -> TypeInfoCache
111− -> MV.IOVector Attribute -> Int
112− -> IO (TypeInfoCache, V.Vector Attribute)
113−getAttInfos conn cols oidmap vec n =
114− case cols of
115− [] -> do
116− !attributes <- V.unsafeFreeze vec
117− return $! (oidmap, attributes)
118− ((attname, attTypeOid):xs) -> do
119− (oidmap', atttype) <- getTypeInfo' conn attTypeOid oidmap
120− MV.write vec n $! Attribute{..}
121− getAttInfos conn xs oidmap' vec (n+1)
30+getTypeInfo conn@Connection{..} oid =
31+ case oid2typname oid of
32+ Just name -> return $! TypeInfo { typ = NamedOid oid name
33+ , typelem = Nothing
34+ }
35+ Nothing -> modifyMVar connectionObjects $ \oidmap -> do
36+ case IntMap.lookup (oid2int oid) oidmap of
37+ Just typeinfo -> return (oidmap, typeinfo)
38+ Nothing -> do
39+ names <- query conn "SELECT p.oid, p.typname, c.oid, c.typname\
40+ \ FROM pg_type AS p LEFT OUTER JOIN pg_type AS c\
41+ \ ON c.oid = p.typelem\
42+ \ WHERE p.oid = ?"
43+ (Only oid)
44+ typinf <- case names of
45+ [] -> return $ throw (fatalError "invalid type oid")
46+ [(pOid, pTypName, mbCOid, mbCTypName)] ->
47+ return $! TypeInfo { typ = NamedOid pOid pTypName
48+ , typelem = do
49+ cOid <- mbCOid
50+ cTypName <- mbCTypName
51+ return $ NamedOid cOid cTypName
52+ }
53+ _ -> fail "typename query returned more than one result"
54+ -- oid is a primary key, so the query should
55+ -- never return more than one result
56+ return (IntMap.insert (oid2int oid) typinf oidmap, typinf)
src/Database/PostgreSQL/Simple/TypeInfo/Macro.hsdeleted−53
@@ -1,53 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−#if __GLASGOW_HASKELL__ >= 800
3−{-# LANGUAGE TemplateHaskellQuotes #-}
4−#else
5−{-# LANGUAGE TemplateHaskell #-}
6−#endif
7−
8−------------------------------------------------------------------------------
9−-- |
10−-- Module: Database.PostgreSQL.Simple.TypeInfo.Macro
11−-- Copyright: (c) 2013 Leon P Smith
12−-- License: BSD3
13−-- Maintainer: Leon P Smith <leon@melding-monads.com>
14−-- Stability: experimental
15−--
16−-- A Template Haskell macro for efficiently checking membership in
17−-- a set of type oids.
18−--
19−------------------------------------------------------------------------------
20−
21−module Database.PostgreSQL.Simple.TypeInfo.Macro
22− ( mkCompats
23− , inlineTypoid
24− ) where
25−
26−import Database.PostgreSQL.Simple.TypeInfo.Static
27−import Database.PostgreSQL.Simple.Types (Oid(..))
28−import Language.Haskell.TH
29−
30−-- | Returns an expression that has type @'Oid' -> 'Bool'@, true if the
31−-- oid is equal to any one of the 'typoid's of the given 'TypeInfo's.
32−mkCompats :: [TypeInfo] -> ExpQ
33−mkCompats tys = do
34− x <- newName "x"
35− lamE [conP 'Oid [varP x]] $ caseE (varE x) (map alt tys ++ [catchAll])
36− where
37− alt :: TypeInfo -> MatchQ
38− alt ty = match (inlineTypoidP ty) (normalB [| True |]) []
39−
40− catchAll :: MatchQ
41− catchAll = match wildP (normalB [| False |]) []
42−
43−-- | Literally substitute the 'typoid' of a 'TypeInfo' expression.
44−-- Returns an expression of type 'Oid'. Useful because GHC tends
45−-- not to fold constants.
46−inlineTypoid :: TypeInfo -> ExpQ
47−inlineTypoid ty = conE 'Oid `appE` litE (getTypoid ty)
48−
49−inlineTypoidP :: TypeInfo -> PatQ
50−inlineTypoidP ty = litP (getTypoid ty)
51−
52−getTypoid :: TypeInfo -> Lit
53−getTypoid ty = let (Oid x) = typoid ty in integerL (fromIntegral x)
src/Database/PostgreSQL/Simple/TypeInfo/Static.hs+170−1434
@@ -6,10 +6,6 @@
66-- Maintainer: Leon P Smith <leon@melding-monads.com>
77-- Stability: experimental
88--
9−-- This module contains portions of the @pg_type@ table that are relevant
10−-- to postgresql-simple and are believed to not change between PostgreSQL
11−-- versions.
12−--
139------------------------------------------------------------------------------
1410
1511-- Note that this file is generated by tools/GenTypeInfo.hs, and should
@@ -19,237 +15,63 @@ module Database.PostgreSQL.Simple.TypeInfo.Static
1915 ( TypeInfo(..)
2016 , staticTypeInfo
2117 , bool
22− , boolOid
2318 , bytea
24− , byteaOid
2519 , char
26− , charOid
2720 , name
28− , nameOid
2921 , int8
30− , int8Oid
3122 , int2
32− , int2Oid
3323 , int4
34− , int4Oid
3524 , regproc
36− , regprocOid
3725 , text
38− , textOid
3926 , oid
40− , oidOid
4127 , tid
42− , tidOid
4328 , xid
44− , xidOid
4529 , cid
46− , cidOid
4730 , xml
48− , xmlOid
4931 , point
50− , pointOid
5132 , lseg
52− , lsegOid
5333 , path
54− , pathOid
5534 , box
56− , boxOid
5735 , polygon
58− , polygonOid
5936 , line
60− , lineOid
6137 , cidr
62− , cidrOid
6338 , float4
64− , float4Oid
6539 , float8
66− , float8Oid
40+ , abstime
41+ , reltime
42+ , tinterval
6743 , unknown
68− , unknownOid
6944 , circle
70− , circleOid
7145 , money
72− , moneyOid
7346 , macaddr
74− , macaddrOid
7547 , inet
76− , inetOid
7748 , bpchar
78− , bpcharOid
7949 , varchar
80− , varcharOid
8150 , date
82− , dateOid
8351 , time
84− , timeOid
8552 , timestamp
86− , timestampOid
8753 , timestamptz
88− , timestamptzOid
8954 , interval
90− , intervalOid
9155 , timetz
92− , timetzOid
9356 , bit
94− , bitOid
9557 , varbit
96− , varbitOid
9758 , numeric
98− , numericOid
9959 , refcursor
100− , refcursorOid
10160 , record
102− , recordOid
10361 , 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
11762 , uuid
118− , uuidOid
119− , json
120− , jsonOid
121− , jsonb
122− , jsonbOid
123− , int2vector
124− , int2vectorOid
125− , oidvector
126− , oidvectorOid
127− , array_xml
128− , array_xmlOid
129− , array_json
130− , array_jsonOid
131− , array_line
132− , array_lineOid
133− , array_cidr
134− , array_cidrOid
135− , array_circle
136− , array_circleOid
137− , array_money
138− , array_moneyOid
139− , array_bool
140− , array_boolOid
141− , array_bytea
142− , array_byteaOid
143− , array_char
144− , array_charOid
145− , array_name
146− , array_nameOid
147− , array_int2
148− , array_int2Oid
149− , array_int2vector
150− , array_int2vectorOid
151− , array_int4
152− , array_int4Oid
153− , array_regproc
154− , array_regprocOid
155− , array_text
156− , array_textOid
157− , array_tid
158− , array_tidOid
159− , array_xid
160− , array_xidOid
161− , array_cid
162− , array_cidOid
163− , array_oidvector
164− , array_oidvectorOid
165− , array_bpchar
166− , array_bpcharOid
167− , array_varchar
168− , array_varcharOid
169− , array_int8
170− , array_int8Oid
171− , array_point
172− , array_pointOid
173− , array_lseg
174− , array_lsegOid
175− , array_path
176− , array_pathOid
177− , array_box
178− , array_boxOid
179− , array_float4
180− , array_float4Oid
181− , array_float8
182− , array_float8Oid
183− , array_polygon
184− , array_polygonOid
185− , array_oid
186− , array_oidOid
187− , array_macaddr
188− , array_macaddrOid
189− , array_inet
190− , array_inetOid
191− , array_timestamp
192− , array_timestampOid
193− , array_date
194− , array_dateOid
195− , array_time
196− , array_timeOid
197− , array_timestamptz
198− , array_timestamptzOid
199− , array_interval
200− , array_intervalOid
201− , array_numeric
202− , array_numericOid
203− , array_timetz
204− , array_timetzOid
205− , array_bit
206− , array_bitOid
207− , array_varbit
208− , array_varbitOid
209− , array_refcursor
210− , array_refcursorOid
211− , array_regprocedure
212− , array_regprocedureOid
213− , array_regoper
214− , array_regoperOid
215− , array_regoperator
216− , array_regoperatorOid
217− , array_regclass
218− , array_regclassOid
219− , array_regtype
220− , array_regtypeOid
221− , array_uuid
222− , array_uuidOid
223− , array_jsonb
224− , array_jsonbOid
225− , int4range
226− , int4rangeOid
227− , _int4range
228− , _int4rangeOid
229− , numrange
230− , numrangeOid
231− , _numrange
232− , _numrangeOid
233− , tsrange
234− , tsrangeOid
235− , _tsrange
236− , _tsrangeOid
237− , tstzrange
238− , tstzrangeOid
239− , _tstzrange
240− , _tstzrangeOid
241− , daterange
242− , daterangeOid
243− , _daterange
244− , _daterangeOid
245− , int8range
246− , int8rangeOid
247− , _int8range
248− , _int8rangeOid
24963 ) where
25064
65+import Data.ByteString (ByteString)
25166import Database.PostgreSQL.LibPQ (Oid(..))
252−import Database.PostgreSQL.Simple.TypeInfo.Types
67+
68+data TypeInfo = TypeInfo
69+ { typoid :: {-# UNPACK #-} !Oid
70+ , typcategory :: {-# UNPACK #-} !Char
71+ , typdelim :: {-# UNPACK #-} !Char
72+ , typelem :: !(Maybe TypeInfo)
73+ , typname :: !ByteString
74+ }
25375
25476staticTypeInfo :: Oid -> Maybe TypeInfo
25577staticTypeInfo (Oid x) = case x of
@@ -276,6 +98,9 @@ staticTypeInfo (Oid x) = case x of
27698 650 -> Just cidr
27799 700 -> Just float4
278100 701 -> Just float8
101+ 702 -> Just abstime
102+ 703 -> Just reltime
103+ 704 -> Just tinterval
279104 705 -> Just unknown
280105 718 -> Just circle
281106 790 -> Just money
@@ -295,1508 +120,419 @@ staticTypeInfo (Oid x) = case x of
295120 1790 -> Just refcursor
296121 2249 -> Just record
297122 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
304123 2950 -> Just uuid
305− 114 -> Just json
306− 3802 -> Just jsonb
307− 22 -> Just int2vector
308− 30 -> Just oidvector
309− 143 -> Just array_xml
310− 199 -> Just array_json
311− 629 -> Just array_line
312− 651 -> Just array_cidr
313− 719 -> Just array_circle
314− 791 -> Just array_money
315− 1000 -> Just array_bool
316− 1001 -> Just array_bytea
317− 1002 -> Just array_char
318− 1003 -> Just array_name
319− 1005 -> Just array_int2
320− 1006 -> Just array_int2vector
321− 1007 -> Just array_int4
322− 1008 -> Just array_regproc
323− 1009 -> Just array_text
324− 1010 -> Just array_tid
325− 1011 -> Just array_xid
326− 1012 -> Just array_cid
327− 1013 -> Just array_oidvector
328− 1014 -> Just array_bpchar
329− 1015 -> Just array_varchar
330− 1016 -> Just array_int8
331− 1017 -> Just array_point
332− 1018 -> Just array_lseg
333− 1019 -> Just array_path
334− 1020 -> Just array_box
335− 1021 -> Just array_float4
336− 1022 -> Just array_float8
337− 1027 -> Just array_polygon
338− 1028 -> Just array_oid
339− 1040 -> Just array_macaddr
340− 1041 -> Just array_inet
341− 1115 -> Just array_timestamp
342− 1182 -> Just array_date
343− 1183 -> Just array_time
344− 1185 -> Just array_timestamptz
345− 1187 -> Just array_interval
346− 1231 -> Just array_numeric
347− 1270 -> Just array_timetz
348− 1561 -> Just array_bit
349− 1563 -> Just array_varbit
350− 2201 -> Just array_refcursor
351− 2207 -> Just array_regprocedure
352− 2208 -> Just array_regoper
353− 2209 -> Just array_regoperator
354− 2210 -> Just array_regclass
355− 2211 -> Just array_regtype
356− 2951 -> Just array_uuid
357− 3807 -> Just array_jsonb
358− 3904 -> Just int4range
359− 3905 -> Just _int4range
360− 3906 -> Just numrange
361− 3907 -> Just _numrange
362− 3908 -> Just tsrange
363− 3909 -> Just _tsrange
364− 3910 -> Just tstzrange
365− 3911 -> Just _tstzrange
366− 3912 -> Just daterange
367− 3913 -> Just _daterange
368− 3926 -> Just int8range
369− 3927 -> Just _int8range
370124 _ -> Nothing
371125
372126bool :: TypeInfo
373−bool = Basic {
374− typoid = boolOid,
127+bool = TypeInfo {
128+ typoid = Oid 16,
375129 typcategory = 'B',
376130 typdelim = ',',
131+ typelem = Nothing,
377132 typname = "bool"
378133 }
379134
380−boolOid :: Oid
381−boolOid = Oid 16
382−{-# INLINE boolOid #-}
383−
384135bytea :: TypeInfo
385−bytea = Basic {
386− typoid = byteaOid,
136+bytea = TypeInfo {
137+ typoid = Oid 17,
387138 typcategory = 'U',
388139 typdelim = ',',
140+ typelem = Nothing,
389141 typname = "bytea"
390142 }
391143
392−byteaOid :: Oid
393−byteaOid = Oid 17
394−{-# INLINE byteaOid #-}
395−
396144char :: TypeInfo
397−char = Basic {
398− typoid = charOid,
145+char = TypeInfo {
146+ typoid = Oid 18,
399147 typcategory = 'S',
400148 typdelim = ',',
149+ typelem = Nothing,
401150 typname = "char"
402151 }
403152
404−charOid :: Oid
405−charOid = Oid 18
406−{-# INLINE charOid #-}
407−
408153name :: TypeInfo
409−name = Basic {
410− typoid = nameOid,
154+name = TypeInfo {
155+ typoid = Oid 19,
411156 typcategory = 'S',
412157 typdelim = ',',
158+ typelem = Just char,
413159 typname = "name"
414160 }
415161
416−nameOid :: Oid
417−nameOid = Oid 19
418−{-# INLINE nameOid #-}
419−
420162int8 :: TypeInfo
421−int8 = Basic {
422− typoid = int8Oid,
163+int8 = TypeInfo {
164+ typoid = Oid 20,
423165 typcategory = 'N',
424166 typdelim = ',',
167+ typelem = Nothing,
425168 typname = "int8"
426169 }
427170
428−int8Oid :: Oid
429−int8Oid = Oid 20
430−{-# INLINE int8Oid #-}
431−
432171int2 :: TypeInfo
433−int2 = Basic {
434− typoid = int2Oid,
172+int2 = TypeInfo {
173+ typoid = Oid 21,
435174 typcategory = 'N',
436175 typdelim = ',',
176+ typelem = Nothing,
437177 typname = "int2"
438178 }
439179
440−int2Oid :: Oid
441−int2Oid = Oid 21
442−{-# INLINE int2Oid #-}
443−
444180int4 :: TypeInfo
445−int4 = Basic {
446− typoid = int4Oid,
181+int4 = TypeInfo {
182+ typoid = Oid 23,
447183 typcategory = 'N',
448184 typdelim = ',',
185+ typelem = Nothing,
449186 typname = "int4"
450187 }
451188
452−int4Oid :: Oid
453−int4Oid = Oid 23
454−{-# INLINE int4Oid #-}
455−
456189regproc :: TypeInfo
457−regproc = Basic {
458− typoid = regprocOid,
190+regproc = TypeInfo {
191+ typoid = Oid 24,
459192 typcategory = 'N',
460193 typdelim = ',',
194+ typelem = Nothing,
461195 typname = "regproc"
462196 }
463197
464−regprocOid :: Oid
465−regprocOid = Oid 24
466−{-# INLINE regprocOid #-}
467−
468198text :: TypeInfo
469−text = Basic {
470− typoid = textOid,
199+text = TypeInfo {
200+ typoid = Oid 25,
471201 typcategory = 'S',
472202 typdelim = ',',
203+ typelem = Nothing,
473204 typname = "text"
474205 }
475206
476−textOid :: Oid
477−textOid = Oid 25
478−{-# INLINE textOid #-}
479−
480207oid :: TypeInfo
481−oid = Basic {
482− typoid = oidOid,
208+oid = TypeInfo {
209+ typoid = Oid 26,
483210 typcategory = 'N',
484211 typdelim = ',',
212+ typelem = Nothing,
485213 typname = "oid"
486214 }
487215
488−oidOid :: Oid
489−oidOid = Oid 26
490−{-# INLINE oidOid #-}
491−
492216tid :: TypeInfo
493−tid = Basic {
494− typoid = tidOid,
217+tid = TypeInfo {
218+ typoid = Oid 27,
495219 typcategory = 'U',
496220 typdelim = ',',
221+ typelem = Nothing,
497222 typname = "tid"
498223 }
499224
500−tidOid :: Oid
501−tidOid = Oid 27
502−{-# INLINE tidOid #-}
503−
504225xid :: TypeInfo
505−xid = Basic {
506− typoid = xidOid,
226+xid = TypeInfo {
227+ typoid = Oid 28,
507228 typcategory = 'U',
508229 typdelim = ',',
230+ typelem = Nothing,
509231 typname = "xid"
510232 }
511233
512−xidOid :: Oid
513−xidOid = Oid 28
514−{-# INLINE xidOid #-}
515−
516234cid :: TypeInfo
517−cid = Basic {
518− typoid = cidOid,
235+cid = TypeInfo {
236+ typoid = Oid 29,
519237 typcategory = 'U',
520238 typdelim = ',',
239+ typelem = Nothing,
521240 typname = "cid"
522241 }
523242
524−cidOid :: Oid
525−cidOid = Oid 29
526−{-# INLINE cidOid #-}
527−
528243xml :: TypeInfo
529−xml = Basic {
530− typoid = xmlOid,
244+xml = TypeInfo {
245+ typoid = Oid 142,
531246 typcategory = 'U',
532247 typdelim = ',',
248+ typelem = Nothing,
533249 typname = "xml"
534250 }
535251
536−xmlOid :: Oid
537−xmlOid = Oid 142
538−{-# INLINE xmlOid #-}
539−
540252point :: TypeInfo
541−point = Basic {
542− typoid = pointOid,
253+point = TypeInfo {
254+ typoid = Oid 600,
543255 typcategory = 'G',
544256 typdelim = ',',
257+ typelem = Just float8,
545258 typname = "point"
546259 }
547260
548−pointOid :: Oid
549−pointOid = Oid 600
550−{-# INLINE pointOid #-}
551−
552261lseg :: TypeInfo
553−lseg = Basic {
554− typoid = lsegOid,
262+lseg = TypeInfo {
263+ typoid = Oid 601,
555264 typcategory = 'G',
556265 typdelim = ',',
266+ typelem = Just point,
557267 typname = "lseg"
558268 }
559269
560−lsegOid :: Oid
561−lsegOid = Oid 601
562−{-# INLINE lsegOid #-}
563−
564270path :: TypeInfo
565−path = Basic {
566− typoid = pathOid,
271+path = TypeInfo {
272+ typoid = Oid 602,
567273 typcategory = 'G',
568274 typdelim = ',',
275+ typelem = Nothing,
569276 typname = "path"
570277 }
571278
572−pathOid :: Oid
573−pathOid = Oid 602
574−{-# INLINE pathOid #-}
575−
576279box :: TypeInfo
577−box = Basic {
578− typoid = boxOid,
280+box = TypeInfo {
281+ typoid = Oid 603,
579282 typcategory = 'G',
580283 typdelim = ';',
284+ typelem = Just point,
581285 typname = "box"
582286 }
583287
584−boxOid :: Oid
585−boxOid = Oid 603
586−{-# INLINE boxOid #-}
587−
588288polygon :: TypeInfo
589−polygon = Basic {
590− typoid = polygonOid,
289+polygon = TypeInfo {
290+ typoid = Oid 604,
591291 typcategory = 'G',
592292 typdelim = ',',
293+ typelem = Nothing,
593294 typname = "polygon"
594295 }
595296
596−polygonOid :: Oid
597−polygonOid = Oid 604
598−{-# INLINE polygonOid #-}
599−
600297line :: TypeInfo
601−line = Basic {
602− typoid = lineOid,
298+line = TypeInfo {
299+ typoid = Oid 628,
603300 typcategory = 'G',
604301 typdelim = ',',
302+ typelem = Just float8,
605303 typname = "line"
606304 }
607305
608−lineOid :: Oid
609−lineOid = Oid 628
610−{-# INLINE lineOid #-}
611−
612306cidr :: TypeInfo
613−cidr = Basic {
614− typoid = cidrOid,
307+cidr = TypeInfo {
308+ typoid = Oid 650,
615309 typcategory = 'I',
616310 typdelim = ',',
311+ typelem = Nothing,
617312 typname = "cidr"
618313 }
619314
620−cidrOid :: Oid
621−cidrOid = Oid 650
622−{-# INLINE cidrOid #-}
623−
624315float4 :: TypeInfo
625−float4 = Basic {
626− typoid = float4Oid,
316+float4 = TypeInfo {
317+ typoid = Oid 700,
627318 typcategory = 'N',
628319 typdelim = ',',
320+ typelem = Nothing,
629321 typname = "float4"
630322 }
631323
632−float4Oid :: Oid
633−float4Oid = Oid 700
634−{-# INLINE float4Oid #-}
635−
636324float8 :: TypeInfo
637−float8 = Basic {
638− typoid = float8Oid,
325+float8 = TypeInfo {
326+ typoid = Oid 701,
639327 typcategory = 'N',
640328 typdelim = ',',
329+ typelem = Nothing,
641330 typname = "float8"
642331 }
643332
644−float8Oid :: Oid
645−float8Oid = Oid 701
646−{-# INLINE float8Oid #-}
333+abstime :: TypeInfo
334+abstime = TypeInfo {
335+ typoid = Oid 702,
336+ typcategory = 'D',
337+ typdelim = ',',
338+ typelem = Nothing,
339+ typname = "abstime"
340+ }
341+
342+reltime :: TypeInfo
343+reltime = TypeInfo {
344+ typoid = Oid 703,
345+ typcategory = 'T',
346+ typdelim = ',',
347+ typelem = Nothing,
348+ typname = "reltime"
349+ }
350+
351+tinterval :: TypeInfo
352+tinterval = TypeInfo {
353+ typoid = Oid 704,
354+ typcategory = 'T',
355+ typdelim = ',',
356+ typelem = Nothing,
357+ typname = "tinterval"
358+ }
647359
648360unknown :: TypeInfo
649−unknown = Basic {
650− typoid = unknownOid,
361+unknown = TypeInfo {
362+ typoid = Oid 705,
651363 typcategory = 'X',
652364 typdelim = ',',
365+ typelem = Nothing,
653366 typname = "unknown"
654367 }
655368
656−unknownOid :: Oid
657−unknownOid = Oid 705
658−{-# INLINE unknownOid #-}
659−
660369circle :: TypeInfo
661−circle = Basic {
662− typoid = circleOid,
370+circle = TypeInfo {
371+ typoid = Oid 718,
663372 typcategory = 'G',
664373 typdelim = ',',
374+ typelem = Nothing,
665375 typname = "circle"
666376 }
667377
668−circleOid :: Oid
669−circleOid = Oid 718
670−{-# INLINE circleOid #-}
671−
672378money :: TypeInfo
673−money = Basic {
674− typoid = moneyOid,
379+money = TypeInfo {
380+ typoid = Oid 790,
675381 typcategory = 'N',
676382 typdelim = ',',
383+ typelem = Nothing,
677384 typname = "money"
678385 }
679386
680−moneyOid :: Oid
681−moneyOid = Oid 790
682−{-# INLINE moneyOid #-}
683−
684387macaddr :: TypeInfo
685−macaddr = Basic {
686− typoid = macaddrOid,
388+macaddr = TypeInfo {
389+ typoid = Oid 829,
687390 typcategory = 'U',
688391 typdelim = ',',
392+ typelem = Nothing,
689393 typname = "macaddr"
690394 }
691395
692−macaddrOid :: Oid
693−macaddrOid = Oid 829
694−{-# INLINE macaddrOid #-}
695−
696396inet :: TypeInfo
697−inet = Basic {
698− typoid = inetOid,
397+inet = TypeInfo {
398+ typoid = Oid 869,
699399 typcategory = 'I',
700400 typdelim = ',',
401+ typelem = Nothing,
701402 typname = "inet"
702403 }
703404
704−inetOid :: Oid
705−inetOid = Oid 869
706−{-# INLINE inetOid #-}
707−
708405bpchar :: TypeInfo
709−bpchar = Basic {
710− typoid = bpcharOid,
406+bpchar = TypeInfo {
407+ typoid = Oid 1042,
711408 typcategory = 'S',
712409 typdelim = ',',
410+ typelem = Nothing,
713411 typname = "bpchar"
714412 }
715413
716−bpcharOid :: Oid
717−bpcharOid = Oid 1042
718−{-# INLINE bpcharOid #-}
719−
720414varchar :: TypeInfo
721−varchar = Basic {
722− typoid = varcharOid,
415+varchar = TypeInfo {
416+ typoid = Oid 1043,
723417 typcategory = 'S',
724418 typdelim = ',',
419+ typelem = Nothing,
725420 typname = "varchar"
726421 }
727422
728−varcharOid :: Oid
729−varcharOid = Oid 1043
730−{-# INLINE varcharOid #-}
731−
732423date :: TypeInfo
733−date = Basic {
734− typoid = dateOid,
424+date = TypeInfo {
425+ typoid = Oid 1082,
735426 typcategory = 'D',
736427 typdelim = ',',
428+ typelem = Nothing,
737429 typname = "date"
738430 }
739431
740−dateOid :: Oid
741−dateOid = Oid 1082
742−{-# INLINE dateOid #-}
743−
744432time :: TypeInfo
745−time = Basic {
746− typoid = timeOid,
433+time = TypeInfo {
434+ typoid = Oid 1083,
747435 typcategory = 'D',
748436 typdelim = ',',
437+ typelem = Nothing,
749438 typname = "time"
750439 }
751440
752−timeOid :: Oid
753−timeOid = Oid 1083
754−{-# INLINE timeOid #-}
755−
756441timestamp :: TypeInfo
757−timestamp = Basic {
758− typoid = timestampOid,
442+timestamp = TypeInfo {
443+ typoid = Oid 1114,
759444 typcategory = 'D',
760445 typdelim = ',',
446+ typelem = Nothing,
761447 typname = "timestamp"
762448 }
763449
764−timestampOid :: Oid
765−timestampOid = Oid 1114
766−{-# INLINE timestampOid #-}
767−
768450timestamptz :: TypeInfo
769−timestamptz = Basic {
770− typoid = timestamptzOid,
451+timestamptz = TypeInfo {
452+ typoid = Oid 1184,
771453 typcategory = 'D',
772454 typdelim = ',',
455+ typelem = Nothing,
773456 typname = "timestamptz"
774457 }
775458
776−timestamptzOid :: Oid
777−timestamptzOid = Oid 1184
778−{-# INLINE timestamptzOid #-}
779−
780459interval :: TypeInfo
781−interval = Basic {
782− typoid = intervalOid,
460+interval = TypeInfo {
461+ typoid = Oid 1186,
783462 typcategory = 'T',
784463 typdelim = ',',
464+ typelem = Nothing,
785465 typname = "interval"
786466 }
787467
788−intervalOid :: Oid
789−intervalOid = Oid 1186
790−{-# INLINE intervalOid #-}
791−
792468timetz :: TypeInfo
793−timetz = Basic {
794− typoid = timetzOid,
469+timetz = TypeInfo {
470+ typoid = Oid 1266,
795471 typcategory = 'D',
796472 typdelim = ',',
473+ typelem = Nothing,
797474 typname = "timetz"
798475 }
799476
800−timetzOid :: Oid
801−timetzOid = Oid 1266
802−{-# INLINE timetzOid #-}
803−
804477bit :: TypeInfo
805−bit = Basic {
806− typoid = bitOid,
478+bit = TypeInfo {
479+ typoid = Oid 1560,
807480 typcategory = 'V',
808481 typdelim = ',',
482+ typelem = Nothing,
809483 typname = "bit"
810484 }
811485
812−bitOid :: Oid
813−bitOid = Oid 1560
814−{-# INLINE bitOid #-}
815−
816486varbit :: TypeInfo
817−varbit = Basic {
818− typoid = varbitOid,
487+varbit = TypeInfo {
488+ typoid = Oid 1562,
819489 typcategory = 'V',
820490 typdelim = ',',
491+ typelem = Nothing,
821492 typname = "varbit"
822493 }
823494
824−varbitOid :: Oid
825−varbitOid = Oid 1562
826−{-# INLINE varbitOid #-}
827−
828495numeric :: TypeInfo
829−numeric = Basic {
830− typoid = numericOid,
496+numeric = TypeInfo {
497+ typoid = Oid 1700,
831498 typcategory = 'N',
832499 typdelim = ',',
500+ typelem = Nothing,
833501 typname = "numeric"
834502 }
835503
836−numericOid :: Oid
837−numericOid = Oid 1700
838−{-# INLINE numericOid #-}
839−
840504refcursor :: TypeInfo
841−refcursor = Basic {
842− typoid = refcursorOid,
505+refcursor = TypeInfo {
506+ typoid = Oid 1790,
843507 typcategory = 'U',
844508 typdelim = ',',
509+ typelem = Nothing,
845510 typname = "refcursor"
846511 }
847512
848−refcursorOid :: Oid
849−refcursorOid = Oid 1790
850−{-# INLINE refcursorOid #-}
851−
852513record :: TypeInfo
853−record = Basic {
854− typoid = recordOid,
514+record = TypeInfo {
515+ typoid = Oid 2249,
855516 typcategory = 'P',
856517 typdelim = ',',
518+ typelem = Nothing,
857519 typname = "record"
858520 }
859521
860−recordOid :: Oid
861−recordOid = Oid 2249
862−{-# INLINE recordOid #-}
863−
864522void :: TypeInfo
865−void = Basic {
866− typoid = voidOid,
523+void = TypeInfo {
524+ typoid = Oid 2278,
867525 typcategory = 'P',
868526 typdelim = ',',
527+ typelem = Nothing,
869528 typname = "void"
870529 }
871530
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−
949531uuid :: TypeInfo
950−uuid = Basic {
951− typoid = uuidOid,
532+uuid = TypeInfo {
533+ typoid = Oid 2950,
952534 typcategory = 'U',
953535 typdelim = ',',
536+ typelem = Nothing,
954537 typname = "uuid"
955538 }
956−
957−uuidOid :: Oid
958−uuidOid = Oid 2950
959−{-# INLINE uuidOid #-}
960−
961−json :: TypeInfo
962−json = Basic {
963− typoid = jsonOid,
964− typcategory = 'U',
965− typdelim = ',',
966− typname = "json"
967− }
968−
969−jsonOid :: Oid
970−jsonOid = Oid 114
971−{-# INLINE jsonOid #-}
972−
973−jsonb :: TypeInfo
974−jsonb = Basic {
975− typoid = jsonbOid,
976− typcategory = 'U',
977− typdelim = ',',
978− typname = "jsonb"
979− }
980−
981−jsonbOid :: Oid
982−jsonbOid = Oid 3802
983−{-# INLINE jsonbOid #-}
984−
985−int2vector :: TypeInfo
986−int2vector = Array {
987− typoid = int2vectorOid,
988− typcategory = 'A',
989− typdelim = ',',
990− typname = "int2vector",
991− typelem = int2
992− }
993−
994−int2vectorOid :: Oid
995−int2vectorOid = Oid 22
996−{-# INLINE int2vectorOid #-}
997−
998−oidvector :: TypeInfo
999−oidvector = Array {
1000− typoid = oidvectorOid,
1001− typcategory = 'A',
1002− typdelim = ',',
1003− typname = "oidvector",
1004− typelem = oid
1005− }
1006−
1007−oidvectorOid :: Oid
1008−oidvectorOid = Oid 30
1009−{-# INLINE oidvectorOid #-}
1010−
1011−array_xml :: TypeInfo
1012−array_xml = Array {
1013− typoid = array_xmlOid,
1014− typcategory = 'A',
1015− typdelim = ',',
1016− typname = "_xml",
1017− typelem = xml
1018− }
1019−
1020−array_xmlOid :: Oid
1021−array_xmlOid = Oid 143
1022−{-# INLINE array_xmlOid #-}
1023−
1024−array_json :: TypeInfo
1025−array_json = Array {
1026− typoid = array_jsonOid,
1027− typcategory = 'A',
1028− typdelim = ',',
1029− typname = "_json",
1030− typelem = json
1031− }
1032−
1033−array_jsonOid :: Oid
1034−array_jsonOid = Oid 199
1035−{-# INLINE array_jsonOid #-}
1036−
1037−array_line :: TypeInfo
1038−array_line = Array {
1039− typoid = array_lineOid,
1040− typcategory = 'A',
1041− typdelim = ',',
1042− typname = "_line",
1043− typelem = line
1044− }
1045−
1046−array_lineOid :: Oid
1047−array_lineOid = Oid 629
1048−{-# INLINE array_lineOid #-}
1049−
1050−array_cidr :: TypeInfo
1051−array_cidr = Array {
1052− typoid = array_cidrOid,
1053− typcategory = 'A',
1054− typdelim = ',',
1055− typname = "_cidr",
1056− typelem = cidr
1057− }
1058−
1059−array_cidrOid :: Oid
1060−array_cidrOid = Oid 651
1061−{-# INLINE array_cidrOid #-}
1062−
1063−array_circle :: TypeInfo
1064−array_circle = Array {
1065− typoid = array_circleOid,
1066− typcategory = 'A',
1067− typdelim = ',',
1068− typname = "_circle",
1069− typelem = circle
1070− }
1071−
1072−array_circleOid :: Oid
1073−array_circleOid = Oid 719
1074−{-# INLINE array_circleOid #-}
1075−
1076−array_money :: TypeInfo
1077−array_money = Array {
1078− typoid = array_moneyOid,
1079− typcategory = 'A',
1080− typdelim = ',',
1081− typname = "_money",
1082− typelem = money
1083− }
1084−
1085−array_moneyOid :: Oid
1086−array_moneyOid = Oid 791
1087−{-# INLINE array_moneyOid #-}
1088−
1089−array_bool :: TypeInfo
1090−array_bool = Array {
1091− typoid = array_boolOid,
1092− typcategory = 'A',
1093− typdelim = ',',
1094− typname = "_bool",
1095− typelem = bool
1096− }
1097−
1098−array_boolOid :: Oid
1099−array_boolOid = Oid 1000
1100−{-# INLINE array_boolOid #-}
1101−
1102−array_bytea :: TypeInfo
1103−array_bytea = Array {
1104− typoid = array_byteaOid,
1105− typcategory = 'A',
1106− typdelim = ',',
1107− typname = "_bytea",
1108− typelem = bytea
1109− }
1110−
1111−array_byteaOid :: Oid
1112−array_byteaOid = Oid 1001
1113−{-# INLINE array_byteaOid #-}
1114−
1115−array_char :: TypeInfo
1116−array_char = Array {
1117− typoid = array_charOid,
1118− typcategory = 'A',
1119− typdelim = ',',
1120− typname = "_char",
1121− typelem = char
1122− }
1123−
1124−array_charOid :: Oid
1125−array_charOid = Oid 1002
1126−{-# INLINE array_charOid #-}
1127−
1128−array_name :: TypeInfo
1129−array_name = Array {
1130− typoid = array_nameOid,
1131− typcategory = 'A',
1132− typdelim = ',',
1133− typname = "_name",
1134− typelem = name
1135− }
1136−
1137−array_nameOid :: Oid
1138−array_nameOid = Oid 1003
1139−{-# INLINE array_nameOid #-}
1140−
1141−array_int2 :: TypeInfo
1142−array_int2 = Array {
1143− typoid = array_int2Oid,
1144− typcategory = 'A',
1145− typdelim = ',',
1146− typname = "_int2",
1147− typelem = int2
1148− }
1149−
1150−array_int2Oid :: Oid
1151−array_int2Oid = Oid 1005
1152−{-# INLINE array_int2Oid #-}
1153−
1154−array_int2vector :: TypeInfo
1155−array_int2vector = Array {
1156− typoid = array_int2vectorOid,
1157− typcategory = 'A',
1158− typdelim = ',',
1159− typname = "_int2vector",
1160− typelem = int2vector
1161− }
1162−
1163−array_int2vectorOid :: Oid
1164−array_int2vectorOid = Oid 1006
1165−{-# INLINE array_int2vectorOid #-}
1166−
1167−array_int4 :: TypeInfo
1168−array_int4 = Array {
1169− typoid = array_int4Oid,
1170− typcategory = 'A',
1171− typdelim = ',',
1172− typname = "_int4",
1173− typelem = int4
1174− }
1175−
1176−array_int4Oid :: Oid
1177−array_int4Oid = Oid 1007
1178−{-# INLINE array_int4Oid #-}
1179−
1180−array_regproc :: TypeInfo
1181−array_regproc = Array {
1182− typoid = array_regprocOid,
1183− typcategory = 'A',
1184− typdelim = ',',
1185− typname = "_regproc",
1186− typelem = regproc
1187− }
1188−
1189−array_regprocOid :: Oid
1190−array_regprocOid = Oid 1008
1191−{-# INLINE array_regprocOid #-}
1192−
1193−array_text :: TypeInfo
1194−array_text = Array {
1195− typoid = array_textOid,
1196− typcategory = 'A',
1197− typdelim = ',',
1198− typname = "_text",
1199− typelem = text
1200− }
1201−
1202−array_textOid :: Oid
1203−array_textOid = Oid 1009
1204−{-# INLINE array_textOid #-}
1205−
1206−array_tid :: TypeInfo
1207−array_tid = Array {
1208− typoid = array_tidOid,
1209− typcategory = 'A',
1210− typdelim = ',',
1211− typname = "_tid",
1212− typelem = tid
1213− }
1214−
1215−array_tidOid :: Oid
1216−array_tidOid = Oid 1010
1217−{-# INLINE array_tidOid #-}
1218−
1219−array_xid :: TypeInfo
1220−array_xid = Array {
1221− typoid = array_xidOid,
1222− typcategory = 'A',
1223− typdelim = ',',
1224− typname = "_xid",
1225− typelem = xid
1226− }
1227−
1228−array_xidOid :: Oid
1229−array_xidOid = Oid 1011
1230−{-# INLINE array_xidOid #-}
1231−
1232−array_cid :: TypeInfo
1233−array_cid = Array {
1234− typoid = array_cidOid,
1235− typcategory = 'A',
1236− typdelim = ',',
1237− typname = "_cid",
1238− typelem = cid
1239− }
1240−
1241−array_cidOid :: Oid
1242−array_cidOid = Oid 1012
1243−{-# INLINE array_cidOid #-}
1244−
1245−array_oidvector :: TypeInfo
1246−array_oidvector = Array {
1247− typoid = array_oidvectorOid,
1248− typcategory = 'A',
1249− typdelim = ',',
1250− typname = "_oidvector",
1251− typelem = oidvector
1252− }
1253−
1254−array_oidvectorOid :: Oid
1255−array_oidvectorOid = Oid 1013
1256−{-# INLINE array_oidvectorOid #-}
1257−
1258−array_bpchar :: TypeInfo
1259−array_bpchar = Array {
1260− typoid = array_bpcharOid,
1261− typcategory = 'A',
1262− typdelim = ',',
1263− typname = "_bpchar",
1264− typelem = bpchar
1265− }
1266−
1267−array_bpcharOid :: Oid
1268−array_bpcharOid = Oid 1014
1269−{-# INLINE array_bpcharOid #-}
1270−
1271−array_varchar :: TypeInfo
1272−array_varchar = Array {
1273− typoid = array_varcharOid,
1274− typcategory = 'A',
1275− typdelim = ',',
1276− typname = "_varchar",
1277− typelem = varchar
1278− }
1279−
1280−array_varcharOid :: Oid
1281−array_varcharOid = Oid 1015
1282−{-# INLINE array_varcharOid #-}
1283−
1284−array_int8 :: TypeInfo
1285−array_int8 = Array {
1286− typoid = array_int8Oid,
1287− typcategory = 'A',
1288− typdelim = ',',
1289− typname = "_int8",
1290− typelem = int8
1291− }
1292−
1293−array_int8Oid :: Oid
1294−array_int8Oid = Oid 1016
1295−{-# INLINE array_int8Oid #-}
1296−
1297−array_point :: TypeInfo
1298−array_point = Array {
1299− typoid = array_pointOid,
1300− typcategory = 'A',
1301− typdelim = ',',
1302− typname = "_point",
1303− typelem = point
1304− }
1305−
1306−array_pointOid :: Oid
1307−array_pointOid = Oid 1017
1308−{-# INLINE array_pointOid #-}
1309−
1310−array_lseg :: TypeInfo
1311−array_lseg = Array {
1312− typoid = array_lsegOid,
1313− typcategory = 'A',
1314− typdelim = ',',
1315− typname = "_lseg",
1316− typelem = lseg
1317− }
1318−
1319−array_lsegOid :: Oid
1320−array_lsegOid = Oid 1018
1321−{-# INLINE array_lsegOid #-}
1322−
1323−array_path :: TypeInfo
1324−array_path = Array {
1325− typoid = array_pathOid,
1326− typcategory = 'A',
1327− typdelim = ',',
1328− typname = "_path",
1329− typelem = path
1330− }
1331−
1332−array_pathOid :: Oid
1333−array_pathOid = Oid 1019
1334−{-# INLINE array_pathOid #-}
1335−
1336−array_box :: TypeInfo
1337−array_box = Array {
1338− typoid = array_boxOid,
1339− typcategory = 'A',
1340− typdelim = ';',
1341− typname = "_box",
1342− typelem = box
1343− }
1344−
1345−array_boxOid :: Oid
1346−array_boxOid = Oid 1020
1347−{-# INLINE array_boxOid #-}
1348−
1349−array_float4 :: TypeInfo
1350−array_float4 = Array {
1351− typoid = array_float4Oid,
1352− typcategory = 'A',
1353− typdelim = ',',
1354− typname = "_float4",
1355− typelem = float4
1356− }
1357−
1358−array_float4Oid :: Oid
1359−array_float4Oid = Oid 1021
1360−{-# INLINE array_float4Oid #-}
1361−
1362−array_float8 :: TypeInfo
1363−array_float8 = Array {
1364− typoid = array_float8Oid,
1365− typcategory = 'A',
1366− typdelim = ',',
1367− typname = "_float8",
1368− typelem = float8
1369− }
1370−
1371−array_float8Oid :: Oid
1372−array_float8Oid = Oid 1022
1373−{-# INLINE array_float8Oid #-}
1374−
1375−array_polygon :: TypeInfo
1376−array_polygon = Array {
1377− typoid = array_polygonOid,
1378− typcategory = 'A',
1379− typdelim = ',',
1380− typname = "_polygon",
1381− typelem = polygon
1382− }
1383−
1384−array_polygonOid :: Oid
1385−array_polygonOid = Oid 1027
1386−{-# INLINE array_polygonOid #-}
1387−
1388−array_oid :: TypeInfo
1389−array_oid = Array {
1390− typoid = array_oidOid,
1391− typcategory = 'A',
1392− typdelim = ',',
1393− typname = "_oid",
1394− typelem = oid
1395− }
1396−
1397−array_oidOid :: Oid
1398−array_oidOid = Oid 1028
1399−{-# INLINE array_oidOid #-}
1400−
1401−array_macaddr :: TypeInfo
1402−array_macaddr = Array {
1403− typoid = array_macaddrOid,
1404− typcategory = 'A',
1405− typdelim = ',',
1406− typname = "_macaddr",
1407− typelem = macaddr
1408− }
1409−
1410−array_macaddrOid :: Oid
1411−array_macaddrOid = Oid 1040
1412−{-# INLINE array_macaddrOid #-}
1413−
1414−array_inet :: TypeInfo
1415−array_inet = Array {
1416− typoid = array_inetOid,
1417− typcategory = 'A',
1418− typdelim = ',',
1419− typname = "_inet",
1420− typelem = inet
1421− }
1422−
1423−array_inetOid :: Oid
1424−array_inetOid = Oid 1041
1425−{-# INLINE array_inetOid #-}
1426−
1427−array_timestamp :: TypeInfo
1428−array_timestamp = Array {
1429− typoid = array_timestampOid,
1430− typcategory = 'A',
1431− typdelim = ',',
1432− typname = "_timestamp",
1433− typelem = timestamp
1434− }
1435−
1436−array_timestampOid :: Oid
1437−array_timestampOid = Oid 1115
1438−{-# INLINE array_timestampOid #-}
1439−
1440−array_date :: TypeInfo
1441−array_date = Array {
1442− typoid = array_dateOid,
1443− typcategory = 'A',
1444− typdelim = ',',
1445− typname = "_date",
1446− typelem = date
1447− }
1448−
1449−array_dateOid :: Oid
1450−array_dateOid = Oid 1182
1451−{-# INLINE array_dateOid #-}
1452−
1453−array_time :: TypeInfo
1454−array_time = Array {
1455− typoid = array_timeOid,
1456− typcategory = 'A',
1457− typdelim = ',',
1458− typname = "_time",
1459− typelem = time
1460− }
1461−
1462−array_timeOid :: Oid
1463−array_timeOid = Oid 1183
1464−{-# INLINE array_timeOid #-}
1465−
1466−array_timestamptz :: TypeInfo
1467−array_timestamptz = Array {
1468− typoid = array_timestamptzOid,
1469− typcategory = 'A',
1470− typdelim = ',',
1471− typname = "_timestamptz",
1472− typelem = timestamptz
1473− }
1474−
1475−array_timestamptzOid :: Oid
1476−array_timestamptzOid = Oid 1185
1477−{-# INLINE array_timestamptzOid #-}
1478−
1479−array_interval :: TypeInfo
1480−array_interval = Array {
1481− typoid = array_intervalOid,
1482− typcategory = 'A',
1483− typdelim = ',',
1484− typname = "_interval",
1485− typelem = interval
1486− }
1487−
1488−array_intervalOid :: Oid
1489−array_intervalOid = Oid 1187
1490−{-# INLINE array_intervalOid #-}
1491−
1492−array_numeric :: TypeInfo
1493−array_numeric = Array {
1494− typoid = array_numericOid,
1495− typcategory = 'A',
1496− typdelim = ',',
1497− typname = "_numeric",
1498− typelem = numeric
1499− }
1500−
1501−array_numericOid :: Oid
1502−array_numericOid = Oid 1231
1503−{-# INLINE array_numericOid #-}
1504−
1505−array_timetz :: TypeInfo
1506−array_timetz = Array {
1507− typoid = array_timetzOid,
1508− typcategory = 'A',
1509− typdelim = ',',
1510− typname = "_timetz",
1511− typelem = timetz
1512− }
1513−
1514−array_timetzOid :: Oid
1515−array_timetzOid = Oid 1270
1516−{-# INLINE array_timetzOid #-}
1517−
1518−array_bit :: TypeInfo
1519−array_bit = Array {
1520− typoid = array_bitOid,
1521− typcategory = 'A',
1522− typdelim = ',',
1523− typname = "_bit",
1524− typelem = bit
1525− }
1526−
1527−array_bitOid :: Oid
1528−array_bitOid = Oid 1561
1529−{-# INLINE array_bitOid #-}
1530−
1531−array_varbit :: TypeInfo
1532−array_varbit = Array {
1533− typoid = array_varbitOid,
1534− typcategory = 'A',
1535− typdelim = ',',
1536− typname = "_varbit",
1537− typelem = varbit
1538− }
1539−
1540−array_varbitOid :: Oid
1541−array_varbitOid = Oid 1563
1542−{-# INLINE array_varbitOid #-}
1543−
1544−array_refcursor :: TypeInfo
1545−array_refcursor = Array {
1546− typoid = array_refcursorOid,
1547− typcategory = 'A',
1548− typdelim = ',',
1549− typname = "_refcursor",
1550− typelem = refcursor
1551− }
1552−
1553−array_refcursorOid :: Oid
1554−array_refcursorOid = Oid 2201
1555−{-# INLINE array_refcursorOid #-}
1556−
1557−array_regprocedure :: TypeInfo
1558−array_regprocedure = Array {
1559− typoid = array_regprocedureOid,
1560− typcategory = 'A',
1561− typdelim = ',',
1562− typname = "_regprocedure",
1563− typelem = regprocedure
1564− }
1565−
1566−array_regprocedureOid :: Oid
1567−array_regprocedureOid = Oid 2207
1568−{-# INLINE array_regprocedureOid #-}
1569−
1570−array_regoper :: TypeInfo
1571−array_regoper = Array {
1572− typoid = array_regoperOid,
1573− typcategory = 'A',
1574− typdelim = ',',
1575− typname = "_regoper",
1576− typelem = regoper
1577− }
1578−
1579−array_regoperOid :: Oid
1580−array_regoperOid = Oid 2208
1581−{-# INLINE array_regoperOid #-}
1582−
1583−array_regoperator :: TypeInfo
1584−array_regoperator = Array {
1585− typoid = array_regoperatorOid,
1586− typcategory = 'A',
1587− typdelim = ',',
1588− typname = "_regoperator",
1589− typelem = regoperator
1590− }
1591−
1592−array_regoperatorOid :: Oid
1593−array_regoperatorOid = Oid 2209
1594−{-# INLINE array_regoperatorOid #-}
1595−
1596−array_regclass :: TypeInfo
1597−array_regclass = Array {
1598− typoid = array_regclassOid,
1599− typcategory = 'A',
1600− typdelim = ',',
1601− typname = "_regclass",
1602− typelem = regclass
1603− }
1604−
1605−array_regclassOid :: Oid
1606−array_regclassOid = Oid 2210
1607−{-# INLINE array_regclassOid #-}
1608−
1609−array_regtype :: TypeInfo
1610−array_regtype = Array {
1611− typoid = array_regtypeOid,
1612− typcategory = 'A',
1613− typdelim = ',',
1614− typname = "_regtype",
1615− typelem = regtype
1616− }
1617−
1618−array_regtypeOid :: Oid
1619−array_regtypeOid = Oid 2211
1620−{-# INLINE array_regtypeOid #-}
1621−
1622−array_uuid :: TypeInfo
1623−array_uuid = Array {
1624− typoid = array_uuidOid,
1625− typcategory = 'A',
1626− typdelim = ',',
1627− typname = "_uuid",
1628− typelem = uuid
1629− }
1630−
1631−array_uuidOid :: Oid
1632−array_uuidOid = Oid 2951
1633−{-# INLINE array_uuidOid #-}
1634−
1635−array_jsonb :: TypeInfo
1636−array_jsonb = Array {
1637− typoid = array_jsonbOid,
1638− typcategory = 'A',
1639− typdelim = ',',
1640− typname = "_jsonb",
1641− typelem = jsonb
1642− }
1643−
1644−array_jsonbOid :: Oid
1645−array_jsonbOid = Oid 3807
1646−{-# INLINE array_jsonbOid #-}
1647−
1648−int4range :: TypeInfo
1649−int4range = Range {
1650− typoid = int4rangeOid,
1651− typcategory = 'R',
1652− typdelim = ',',
1653− typname = "int4range",
1654− rngsubtype = int4
1655− }
1656−
1657−int4rangeOid :: Oid
1658−int4rangeOid = Oid 3904
1659−{-# INLINE int4rangeOid #-}
1660−
1661−_int4range :: TypeInfo
1662−_int4range = Array {
1663− typoid = _int4rangeOid,
1664− typcategory = 'A',
1665− typdelim = ',',
1666− typname = "_int4range",
1667− typelem = int4range
1668− }
1669−
1670−_int4rangeOid :: Oid
1671−_int4rangeOid = Oid 3905
1672−{-# INLINE _int4rangeOid #-}
1673−
1674−numrange :: TypeInfo
1675−numrange = Range {
1676− typoid = numrangeOid,
1677− typcategory = 'R',
1678− typdelim = ',',
1679− typname = "numrange",
1680− rngsubtype = numeric
1681− }
1682−
1683−numrangeOid :: Oid
1684−numrangeOid = Oid 3906
1685−{-# INLINE numrangeOid #-}
1686−
1687−_numrange :: TypeInfo
1688−_numrange = Array {
1689− typoid = _numrangeOid,
1690− typcategory = 'A',
1691− typdelim = ',',
1692− typname = "_numrange",
1693− typelem = numrange
1694− }
1695−
1696−_numrangeOid :: Oid
1697−_numrangeOid = Oid 3907
1698−{-# INLINE _numrangeOid #-}
1699−
1700−tsrange :: TypeInfo
1701−tsrange = Range {
1702− typoid = tsrangeOid,
1703− typcategory = 'R',
1704− typdelim = ',',
1705− typname = "tsrange",
1706− rngsubtype = timestamp
1707− }
1708−
1709−tsrangeOid :: Oid
1710−tsrangeOid = Oid 3908
1711−{-# INLINE tsrangeOid #-}
1712−
1713−_tsrange :: TypeInfo
1714−_tsrange = Array {
1715− typoid = _tsrangeOid,
1716− typcategory = 'A',
1717− typdelim = ',',
1718− typname = "_tsrange",
1719− typelem = tsrange
1720− }
1721−
1722−_tsrangeOid :: Oid
1723−_tsrangeOid = Oid 3909
1724−{-# INLINE _tsrangeOid #-}
1725−
1726−tstzrange :: TypeInfo
1727−tstzrange = Range {
1728− typoid = tstzrangeOid,
1729− typcategory = 'R',
1730− typdelim = ',',
1731− typname = "tstzrange",
1732− rngsubtype = timestamptz
1733− }
1734−
1735−tstzrangeOid :: Oid
1736−tstzrangeOid = Oid 3910
1737−{-# INLINE tstzrangeOid #-}
1738−
1739−_tstzrange :: TypeInfo
1740−_tstzrange = Array {
1741− typoid = _tstzrangeOid,
1742− typcategory = 'A',
1743− typdelim = ',',
1744− typname = "_tstzrange",
1745− typelem = tstzrange
1746− }
1747−
1748−_tstzrangeOid :: Oid
1749−_tstzrangeOid = Oid 3911
1750−{-# INLINE _tstzrangeOid #-}
1751−
1752−daterange :: TypeInfo
1753−daterange = Range {
1754− typoid = daterangeOid,
1755− typcategory = 'R',
1756− typdelim = ',',
1757− typname = "daterange",
1758− rngsubtype = date
1759− }
1760−
1761−daterangeOid :: Oid
1762−daterangeOid = Oid 3912
1763−{-# INLINE daterangeOid #-}
1764−
1765−_daterange :: TypeInfo
1766−_daterange = Array {
1767− typoid = _daterangeOid,
1768− typcategory = 'A',
1769− typdelim = ',',
1770− typname = "_daterange",
1771− typelem = daterange
1772− }
1773−
1774−_daterangeOid :: Oid
1775−_daterangeOid = Oid 3913
1776−{-# INLINE _daterangeOid #-}
1777−
1778−int8range :: TypeInfo
1779−int8range = Range {
1780− typoid = int8rangeOid,
1781− typcategory = 'R',
1782− typdelim = ',',
1783− typname = "int8range",
1784− rngsubtype = int8
1785− }
1786−
1787−int8rangeOid :: Oid
1788−int8rangeOid = Oid 3926
1789−{-# INLINE int8rangeOid #-}
1790−
1791−_int8range :: TypeInfo
1792−_int8range = Array {
1793− typoid = _int8rangeOid,
1794− typcategory = 'A',
1795− typdelim = ',',
1796− typname = "_int8range",
1797− typelem = int8range
1798− }
1799−
1800−_int8rangeOid :: Oid
1801−_int8rangeOid = Oid 3927
1802−{-# INLINE _int8rangeOid #-}
src/Database/PostgreSQL/Simple/TypeInfo/Types.hsdeleted−56
@@ -1,56 +0,0 @@
1−------------------------------------------------------------------------------
2−-- |
3−-- Module: Database.PostgreSQL.Simple.TypeInfo.Types
4−-- Copyright: (c) 2013 Leon P Smith
5−-- License: BSD3
6−-- Maintainer: Leon P Smith <leon@melding-monads.com>
7−-- Stability: experimental
8−--
9−------------------------------------------------------------------------------
10−
11−module Database.PostgreSQL.Simple.TypeInfo.Types where
12−
13−import Data.ByteString(ByteString)
14−import Database.PostgreSQL.LibPQ(Oid)
15−import Data.Vector(Vector)
16−
17−-- | A structure representing some of the metadata regarding a PostgreSQL
18−-- type, mostly taken from the @pg_type@ table.
19−
20−data TypeInfo
21−
22− = Basic { typoid :: {-# UNPACK #-} !Oid
23− , typcategory :: {-# UNPACK #-} !Char
24− , typdelim :: {-# UNPACK #-} !Char
25− , typname :: !ByteString
26− }
27−
28− | Array { typoid :: {-# UNPACK #-} !Oid
29− , typcategory :: {-# UNPACK #-} !Char
30− , typdelim :: {-# UNPACK #-} !Char
31− , typname :: !ByteString
32− , typelem :: !TypeInfo
33− }
34−
35− | Range { typoid :: {-# UNPACK #-} !Oid
36− , typcategory :: {-# UNPACK #-} !Char
37− , typdelim :: {-# UNPACK #-} !Char
38− , typname :: !ByteString
39− , rngsubtype :: !TypeInfo
40− }
41−
42− | Composite { typoid :: {-# UNPACK #-} !Oid
43− , typcategory :: {-# UNPACK #-} !Char
44− , typdelim :: {-# UNPACK #-} !Char
45− , typname :: !ByteString
46− , typrelid :: {-# UNPACK #-} !Oid
47− , attributes :: !(Vector Attribute)
48− }
49−
50− deriving (Show)
51−
52−data Attribute
53− = Attribute { attname :: !ByteString
54− , atttype :: !TypeInfo
55− }
56− deriving (Show)
src/Database/PostgreSQL/Simple/Types.hs+34−160
@@ -1,4 +1,4 @@
1−{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, GeneralizedNewtypeDeriving #-}
1+{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, GeneralizedNewtypeDeriving #-}
22
33------------------------------------------------------------------------------
44-- |
@@ -8,6 +8,7 @@
88-- License: BSD3
99-- Maintainer: Leon P Smith <leon@melding-monads.com>
1010-- Stability: experimental
11+-- Portability: portable
1112--
1213-- Basic types.
1314--
@@ -16,43 +17,31 @@
1617module Database.PostgreSQL.Simple.Types
1718 (
1819 Null(..)
19− , Default(..)
2020 , Only(..)
2121 , In(..)
2222 , Binary(..)
23− , Identifier(..)
24− , QualifiedIdentifier(..)
2523 , Query(..)
2624 , Oid(..)
2725 , (:.)(..)
28− , Savepoint(..)
29− , PGArray(..)
30− , Values(..)
3126 ) where
3227
33−import Control.Arrow (first)
34−import Data.ByteString (ByteString)
35−import Data.Hashable (Hashable(hashWithSalt))
36−import Data.Foldable (toList)
37−import Data.Monoid (Monoid(..))
38−import Data.Semigroup
39−import Data.String (IsString(..))
40−import Data.Typeable (Typeable)
41−import Data.ByteString.Builder ( stringUtf8 )
28+import Blaze.ByteString.Builder (toByteString)
29+import Control.Arrow (first)
30+import Data.ByteString (ByteString)
31+import Data.Monoid (Monoid(..))
32+import Data.String (IsString(..))
33+import Data.Typeable (Typeable)
34+import qualified Blaze.ByteString.Builder.Char.Utf8 as Utf8
4235import qualified Data.ByteString as B
43−import Data.Text (Text)
44−import qualified Data.Text as T
45−import Data.Tuple.Only (Only(..))
46−import Database.PostgreSQL.LibPQ (Oid(..))
47−import Database.PostgreSQL.Simple.Compat (toByteString)
36+import Database.PostgreSQL.LibPQ (Oid(..))
4837
4938-- | A placeholder for the SQL @NULL@ value.
5039data Null = Null
5140 deriving (Read, Show, Typeable)
5241
53−-- | A placeholder for the PostgreSQL @DEFAULT@ value.
54−data Default = Default
55− deriving (Read, Show, Typeable)
42+instance Eq Null where
43+ _ == _ = False
44+ _ /= _ = False
5645
5746-- | A query string. This type is intended to make it difficult to
5847-- construct a SQL query by concatenating string fragments, as that is
@@ -84,98 +73,42 @@ instance Read Query where
8473 readsPrec i = fmap (first Query) . readsPrec i
8574
8675instance IsString Query where
87− fromString = Query . toByteString . stringUtf8
88−
89−instance Semigroup Query where
90− Query a <> Query b = Query (B.append a b)
91− {-# INLINE (<>) #-}
92− sconcat xs = Query (B.concat $ map fromQuery $ toList xs)
76+ fromString = Query . toByteString . Utf8.fromString
9377
9478instance Monoid Query where
9579 mempty = Query B.empty
80+ mappend (Query a) (Query b) = Query (B.append a b)
81+ {-# INLINE mappend #-}
9682
97−-- | Wrap a list of values for use in an @IN@ clause. Replaces a
98−-- single \"@?@\" character with a parenthesized list of rendered
99−-- values.
100−--
101−-- Example:
102−--
103−-- > query c "select * from whatever where id in ?" (Only (In [3,4,5]))
104−--
105−-- Note that @In []@ expands to @(null)@, which works as expected in
106−-- the query above, but evaluates to the logical null value on every
107−-- row instead of @TRUE@. This means that changing the query above
108−-- to @... id NOT in ?@ and supplying the empty list as the parameter
109−-- returns zero rows, instead of all of them as one would expect.
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:
83+-- | A single-value \"collection\".
11484--
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.
85+-- This is useful if you need to supply a single parameter to a SQL
86+-- query, or extract a single column from a SQL result.
12087--
121−-- > query c "select * from whatever where id not in ?"
122−-- > (Only (Values ["int4"] [] :: Values (Only Int)))
88+-- Parameter example:
12389--
90+-- @query c \"select x from scores where x > ?\" ('Only' (42::Int))@
12491--
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:
92+-- Result example:
12893--
129−-- > query c "select * from whatever where coalesce(id NOT in ?, TRUE)"
130−-- > (Only (In [] :: In [Int]))
94+-- @xs <- query_ c \"select id from users\"
95+--forM_ xs $ \\('Only' id) -> {- ... -}@
96+newtype Only a = Only {
97+ fromOnly :: a
98+ } deriving (Eq, Ord, Read, Show, Typeable, Functor)
99+
100+-- | Wrap a list of values for use in an @IN@ clause. Replaces a
101+-- single \"@?@\" character with a parenthesized list of rendered
102+-- values.
131103--
132−-- > query c "select * from whatever where coalesce(id IN ?, FALSE)"
133−-- > (Only (In [] :: In [Int]))
104+-- Example:
134105--
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−
106+-- > query c "select * from whatever where id in ?" (Only (In [3,4,5]))
142107newtype In a = In a
143108 deriving (Eq, Ord, Read, Show, Typeable, Functor)
144109
145110-- | Wrap binary data for use as a @bytea@ value.
146−newtype Binary a = Binary {fromBinary :: a}
147− deriving (Eq, Ord, Read, Show, Typeable, Functor)
148−
149−-- | Wrap text for use as sql identifier, i.e. a table or column name.
150−newtype Identifier = Identifier {fromIdentifier :: Text}
151− deriving (Eq, Ord, Read, Show, Typeable, IsString)
152−
153−instance Hashable Identifier where
154− hashWithSalt i (Identifier t) = hashWithSalt i t
155−
156−-- | Wrap text for use as (maybe) qualified identifier, i.e. a table
157−-- with schema, or column with table.
158−data QualifiedIdentifier = QualifiedIdentifier (Maybe Text) Text
159− deriving (Eq, Ord, Read, Show, Typeable)
160−
161−instance Hashable QualifiedIdentifier where
162− hashWithSalt i (QualifiedIdentifier q t) = hashWithSalt i (q, t)
163−
164−-- | @\"foo.bar\"@ will get turned into
165−-- @QualifiedIdentifier (Just \"foo\") \"bar\"@, while @\"foo\"@ will get
166−-- turned into @QualifiedIdentifier Nothing \"foo\"@. Note this instance
167−-- is for convenience, and does not match postgres syntax. It
168−-- only examines the first period character, and thus cannot be used if the
169−-- qualifying identifier contains a period for example.
170−
171−instance IsString QualifiedIdentifier where
172− fromString str = let (x,y) = T.break (== '.') (fromString str)
173− in if T.null y
174− then QualifiedIdentifier Nothing x
175− else QualifiedIdentifier (Just x) (T.tail y)
176−
177−-- | Wrap a list for use as a PostgreSQL array.
178−newtype PGArray a = PGArray {fromPGArray :: [a]}
111+newtype Binary a = Binary a
179112 deriving (Eq, Ord, Read, Show, Typeable, Functor)
180113
181114-- | A composite type to parse your custom data structures without
@@ -197,62 +130,3 @@ newtype PGArray a = PGArray {fromPGArray :: [a]}
197130data h :. t = h :. t deriving (Eq,Ord,Show,Read,Typeable)
198131
199132infixr 3 :.
200−
201−newtype Savepoint = Savepoint Query
202− deriving (Eq, Ord, Show, Read, Typeable)
203−
204−-- | Represents a @VALUES@ table literal, usable as an alternative to
205−-- 'Database.PostgreSQL.Simple.executeMany' and
206−-- 'Database.PostgreSQL.Simple.returning'. The main advantage is that
207−-- you can parametrize more than just a single @VALUES@ expression.
208−-- For example, here's a query to insert a thing into one table
209−-- and some attributes of that thing into another, returning the
210−-- new id generated by the database:
211−--
212−--
213−-- > query c [sql|
214−-- > WITH new_thing AS (
215−-- > INSERT INTO thing (name) VALUES (?) RETURNING id
216−-- > ), new_attributes AS (
217−-- > INSERT INTO thing_attributes
218−-- > SELECT new_thing.id, attrs.*
219−-- > FROM new_thing JOIN ? attrs ON TRUE
220−-- > ) SELECT * FROM new_thing
221−-- > |] ("foo", Values [ "int4", "text" ]
222−-- > [ ( 1 , "hello" )
223−-- > , ( 2 , "world" ) ])
224−--
225−-- (Note this example uses writable common table expressions,
226−-- which were added in PostgreSQL 9.1)
227−--
228−-- The second parameter gets expanded into the following SQL syntax:
229−--
230−-- > (VALUES (1::"int4",'hello'::"text"),(2,'world'))
231−--
232−-- When the list of attributes is empty, the second parameter expands to:
233−--
234−-- > (VALUES (null::"int4",null::"text") LIMIT 0)
235−--
236−-- By contrast, @executeMany@ and @returning@ don't issue the query
237−-- in the empty case, and simply return @0@ and @[]@ respectively.
238−-- This behavior is usually correct given their intended use cases,
239−-- but would certainly be wrong in the example above.
240−--
241−-- The first argument is a list of postgresql type names. Because this
242−-- is turned into a properly quoted identifier, the type name is case
243−-- sensitive and must be as it appears in the @pg_type@ table. Thus,
244−-- you must write @timestamptz@ instead of @timestamp with time zone@,
245−-- @int4@ instead of @integer@ or @serial@, @_int8@ instead of @bigint[]@,
246−-- etcetera.
247−--
248−-- You may omit the type names, however, if you do so the list
249−-- of values must be non-empty, and postgresql must be able to infer
250−-- the types of the columns from the surrounding context. If the first
251−-- condition is not met, postgresql-simple will throw an exception
252−-- without issuing the query. In the second case, the postgres server
253−-- will return an error which will be turned into a @SqlError@ exception.
254−--
255−-- See <https://www.postgresql.org/docs/9.5/static/sql-values.html> for
256−-- more information.
257−data Values a = Values [QualifiedIdentifier] [a]
258− deriving (Eq, Ord, Show, Read, Typeable)
src/Database/PostgreSQL/Simple/Vector.hsdeleted−45
@@ -1,45 +0,0 @@
1−-- | 'query' variants returning 'V.Vector'.
2−module Database.PostgreSQL.Simple.Vector where
3−
4−import Database.PostgreSQL.Simple (Connection, formatQuery, formatMany)
5−import Database.PostgreSQL.Simple.FromRow (FromRow(..))
6−import Database.PostgreSQL.Simple.ToRow (ToRow(..))
7−import Database.PostgreSQL.Simple.Internal (RowParser, exec)
8−import Database.PostgreSQL.Simple.Internal.PQResultUtils
9−import Database.PostgreSQL.Simple.Types ( Query (..) )
10−
11−import qualified Data.Vector as V
12−
13−-- | Perform a @SELECT@ or other SQL query that is expected to return
14−-- results. All results are retrieved and converted before this
15−-- function returns.
16−query :: (ToRow q, FromRow r) => Connection -> Query -> q -> IO (V.Vector r)
17−query = queryWith fromRow
18−
19−-- | A version of 'query' that does not perform query substitution.
20−query_ :: (FromRow r) => Connection -> Query -> IO (V.Vector r)
21−query_ = queryWith_ fromRow
22−
23−-- | A version of 'query' taking parser as argument
24−queryWith :: ToRow q => RowParser r -> Connection -> Query -> q -> IO (V.Vector r)
25−queryWith parser conn template qs = do
26− result <- exec conn =<< formatQuery conn template qs
27− finishQueryWithV parser conn template result
28−
29−-- | A version of 'query_' taking parser as argument
30−queryWith_ :: RowParser r -> Connection -> Query -> IO (V.Vector r)
31−queryWith_ parser conn q@(Query que) = do
32− result <- exec conn que
33− finishQueryWithV parser conn q result
34−
35−-- | Execute @INSERT ... RETURNING@, @UPDATE ... RETURNING@, or other SQL
36−-- query that accepts multi-row input and is expected to return results.
37−returning :: (ToRow q, FromRow r) => Connection -> Query -> [q] -> IO (V.Vector r)
38−returning = returningWith fromRow
39−
40−-- | A version of 'returning' taking parser as argument
41−returningWith :: (ToRow q) => RowParser r -> Connection -> Query -> [q] -> IO (V.Vector r)
42−returningWith _ _ _ [] = return V.empty
43−returningWith parser conn q qs = do
44− result <- exec conn =<< formatMany conn q qs
45− finishQueryWithV parser conn q result
src/Database/PostgreSQL/Simple/Vector/Unboxed.hsdeleted−44
@@ -1,44 +0,0 @@
1−module Database.PostgreSQL.Simple.Vector.Unboxed where
2−
3−import Database.PostgreSQL.Simple (Connection, formatQuery, formatMany)
4−import Database.PostgreSQL.Simple.FromRow (FromRow(..))
5−import Database.PostgreSQL.Simple.ToRow (ToRow(..))
6−import Database.PostgreSQL.Simple.Internal (RowParser, exec)
7−import Database.PostgreSQL.Simple.Internal.PQResultUtils
8−import Database.PostgreSQL.Simple.Types ( Query (..) )
9−
10−import qualified Data.Vector.Unboxed as VU
11−
12−-- | Perform a @SELECT@ or other SQL query that is expected to return
13−-- results. All results are retrieved and converted before this
14−-- function returns.
15−query :: (ToRow q, FromRow r, VU.Unbox r) => Connection -> Query -> q -> IO (VU.Vector r)
16−query = queryWith fromRow
17−
18−-- | A version of 'query' that does not perform query substitution.
19−query_ :: (FromRow r, VU.Unbox r) => Connection -> Query -> IO (VU.Vector r)
20−query_ = queryWith_ fromRow
21−
22−-- | A version of 'query' taking parser as argument
23−queryWith :: (ToRow q, VU.Unbox r) => RowParser r -> Connection -> Query -> q -> IO (VU.Vector r)
24−queryWith parser conn template qs = do
25− result <- exec conn =<< formatQuery conn template qs
26− finishQueryWithVU parser conn template result
27−
28−-- | A version of 'query_' taking parser as argument
29−queryWith_ :: VU.Unbox r => RowParser r -> Connection -> Query -> IO (VU.Vector r)
30−queryWith_ parser conn q@(Query que) = do
31− result <- exec conn que
32− finishQueryWithVU parser conn q result
33−
34−-- | Execute @INSERT ... RETURNING@, @UPDATE ... RETURNING@, or other SQL
35−-- query that accepts multi-row input and is expected to return results.
36−returning :: (ToRow q, FromRow r, VU.Unbox r) => Connection -> Query -> [q] -> IO (VU.Vector r)
37−returning = returningWith fromRow
38−
39−-- | A version of 'returning' taking parser as argument
40−returningWith :: (ToRow q, VU.Unbox r) => RowParser r -> Connection -> Query -> [q] -> IO (VU.Vector r)
41−returningWith _ _ _ [] = return VU.empty
42−returningWith parser conn q qs = do
43− result <- exec conn =<< formatMany conn q qs
44− finishQueryWithVU parser conn q result
test/Common.hs+2−2
@@ -1,6 +1,6 @@
11module Common (
22 module Database.PostgreSQL.Simple,
3− module Test.Tasty.HUnit,
3+ module Test.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.Tasty.HUnit
11+import Test.HUnit
1212
1313import qualified Crypto.Hash.MD5 as MD5
1414import qualified Data.ByteString.Base16 as Base16
test/Exception.hsdeleted−70
@@ -1,70 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE ScopedTypeVariables #-}
4−
5−module Exception (testExceptions) where
6−
7−import Database.PostgreSQL.Simple
8−import Test.Tasty.HUnit (Assertion, assertBool)
9−import Common (TestEnv)
10−import Control.Exception (Exception (..), SomeException)
11−import Data.Maybe (isJust)
12−import Data.Either (isLeft)
13−import Control.Exception (throwIO, try)
14−
15−testExceptions :: TestEnv -> Assertion
16−testExceptions _ = do
17− let sqlError = SqlError
18− { sqlState = ""
19− , sqlExecStatus = FatalError
20− , sqlErrorMsg = ""
21− , sqlErrorDetail = ""
22− , sqlErrorHint = ""
23− }
24− let sqlEx :: SomeException = toException sqlError
25− assertBool "SqlError is SomePostgreSqlException" $ isJust (fromException sqlEx :: Maybe SomePostgreSqlException)
26− assertBool "SqlError is SqlError" $ isJust (fromException sqlEx :: Maybe SqlError)
27− eSqlError :: Either SqlError () <- try $ throwIO sqlEx
28− assertBool "Can catch SqlError" $ isLeft eSqlError
29− eSqlPostgreSqlEx :: Either SomePostgreSqlException () <- try $ throwIO sqlEx
30− assertBool "Can catch SomePostgreSqlException from SqlError" $ isLeft eSqlPostgreSqlEx
31−
32− let formatError = FormatError
33− { fmtMessage = ""
34− , fmtQuery = ""
35− , fmtParams = []
36− }
37− let formatEx :: SomeException = toException formatError
38− assertBool "FormatError is SomePostgreSqlException" $ isJust (fromException formatEx :: Maybe SomePostgreSqlException)
39− assertBool "FormatError is FormatError" $ isJust (fromException formatEx :: Maybe FormatError)
40− eFormatError :: Either FormatError () <- try $ throwIO formatEx
41− assertBool "Can catch FormatError" $ isLeft eFormatError
42− eFormatPostreSqlEx :: Either SomePostgreSqlException () <- try $ throwIO formatEx
43− assertBool "Can catch SomePostgreSqlException from FormatError" $ isLeft eFormatPostreSqlEx
44−
45− let queryError = QueryError
46− { qeMessage = ""
47− , qeQuery = ""
48− }
49− let queryEx :: SomeException = toException queryError
50− assertBool "QueryError is SomePostgreSqlException" $ isJust (fromException queryEx :: Maybe SomePostgreSqlException)
51− assertBool "QueryError is QueryError" $ isJust (fromException queryEx :: Maybe QueryError)
52− eQueryError :: Either QueryError () <- try $ throwIO queryEx
53− assertBool "Can catch QueryError" $ isLeft eQueryError
54− eQueryPostgreSqlEx :: Either SomePostgreSqlException () <- try $ throwIO queryEx
55− assertBool "Can catch SomePostgreSqlException from QueryError" $ isLeft eQueryPostgreSqlEx
56−
57− let resultError = Incompatible
58− { errSQLType = ""
59− , errSQLTableOid = Nothing
60− , errSQLField = ""
61− , errHaskellType = ""
62− , errMessage = ""
63− }
64− let resultEx :: SomeException = toException resultError
65− assertBool "ResultError is SomePostgreSqlException" $ isJust (fromException resultEx :: Maybe SomePostgreSqlException)
66− assertBool "ResultError is ResultError" $ isJust (fromException resultEx :: Maybe ResultError)
67− eResultEx :: Either ResultError () <- try $ throwIO resultEx
68− assertBool "Can catch ResultError" $ isLeft eResultEx
69− eResultPostgreSqlEx :: Either SomePostgreSqlException () <- try $ throwIO resultEx
70− assertBool "Can catch SomePostgreSqlException from ResultError" $ isLeft eResultPostgreSqlEx
test/Inspection.hsdeleted−79
@@ -1,79 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE TemplateHaskell #-}
3−{-# OPTIONS_GHC -dsuppress-idinfo -dsuppress-coercions -dsuppress-type-applications -dsuppress-module-prefixes -dsuppress-type-signatures #-}
4−-- {-# OPTIONS_GHC -dsuppress-uniques #-}
5−{-# OPTIONS_GHC -fplugin=Test.Inspection.Plugin #-}
6−module Main where
7−
8−import Test.Inspection
9−import Test.Tasty
10−import Test.Tasty.HUnit
11−
12−import qualified Database.PostgreSQL.LibPQ as PQ
13−import Database.PostgreSQL.Simple.FromField
14−import Database.PostgreSQL.Simple.TypeInfo as TI
15−import Database.PostgreSQL.Simple.TypeInfo.Macro
16−import qualified Database.PostgreSQL.Simple.TypeInfo.Static as TI
17−
18−-------------------------------------------------------------------------------
19−-- Inspection tests
20−-------------------------------------------------------------------------------
21−
22−-- # doesn't work :(
23−#define TH_MKCOMPATS3(a,b,c) $(mkCompats [TI.a,TI.b,TI.c])
24−#define IN_MKCOMPATS3(a,b,c) (eq TI.a \/ eq TI.b \/ eq TI.c)
25−
26−#define TH_INLINETYPOID(n) eq $(inlineTypoid TI.n)
27−#define IN_INLINETYPOID(n) eq TI.n
28−
29−-- eta-expansion is required
30−lhs01, rhs01 :: PQ.Oid -> Bool
31−lhs01 = TH_MKCOMPATS3(name,text,char)
32−rhs01 = IN_MKCOMPATS3(nameOid,textOid,charOid)
33−
34−lhs02, rhs02 :: PQ.Oid -> Bool
35−lhs02 = TH_INLINETYPOID(name)
36−rhs02 = IN_INLINETYPOID(nameOid)
37−
38−eq :: PQ.Oid -> PQ.Oid -> Bool
39−eq = (==)
40−{-# INLINE eq #-}
41−
42−infixr 2 \/
43−(\/) :: (PQ.Oid -> Bool)
44− -> (PQ.Oid -> Bool)
45− -> (PQ.Oid -> Bool)
46−f \/ g = \x -> f x || g x
47−{-# INLINE (\/) #-}
48−
49−inspectionTests :: TestTree
50−inspectionTests = testGroup "inspection"
51− [ testCase "mkCompats" $
52− assertSuccess $(inspectTest $ 'lhs01 === 'rhs01)
53−
54− -- byteaOid isn't inlined?
55− , testCase "inlineTypoid" $
56−#if __GLASGOW_HASKELL__ >= 808
57− assertSuccess
58−#else
59− assertFailure'
60−#endif
61− $(inspectTest $ 'lhs02 ==- 'rhs02)
62− ]
63−
64−assertSuccess :: Result -> IO ()
65−assertSuccess (Success _) = return ()
66−assertSuccess (Failure err) = assertFailure err
67−
68−assertFailure' :: Result -> IO ()
69−assertFailure' (Success err) = assertFailure err
70−assertFailure' (Failure _) = return ()
71−
72−-------------------------------------------------------------------------------
73−-- Main
74−-------------------------------------------------------------------------------
75−
76−main :: IO ()
77−main = defaultMain $ testGroup "tests"
78− [ inspectionTests
79− ]
test/Interval.hsdeleted−176
@@ -1,176 +0,0 @@
1−{-# LANGUAGE QuasiQuotes #-}
2−
3−{-
4−
5−Testing strategies:
6−
7−fromString . toString == id ** Todo?
8−
9−toString . fromString == almost id ** Todo?
10−
11−postgresql -> haskell -> postgresql * Done
12−
13−haskell -> postgresql -> haskell ** Todo?
14−
15−But still, what we really want to establish is that the two values
16−correspond; for example, a conversion that consistently added hour
17−when printed to a string and subtracted an hour when parsed from string
18−would still pass these tests.
19−
20−
21−Right now, we are checking that 1400+ timestamps in the range of 1860 to
22−2060 round trip from postgresql to haskell and back in 5 different timezones.
23−In addition to UTC, the four timezones were selected so that 2 have a positive
24−offset, and 2 have a negative offset, and that 2 have an offset of a
25−whole number of hours, while the other two do not.
26−
27−It may be worth adding a few more timezones to ensure better test coverage.
28−
29−We are checking a handful of selected timestamps to ensure we hit
30−various corner-cases in the code, in addition to 1400 timestamps randomly
31−generated with granularity of seconds down to microseconds in powers of ten.
32−
33−-}
34−
35−module Interval (testInterval) where
36−
37−import Common
38−import Control.Monad(forM_, replicateM_)
39−import Data.Time.Compat
40−import Data.Time.LocalTime.Compat (CalendarDiffTime(..))
41−import Data.ByteString(ByteString)
42−import Database.PostgreSQL.Simple.SqlQQ
43−
44−data IntervalTestCase = IntervalTestCase
45− { label :: String
46− , inputMonths :: Integer
47− , inputSeconds :: NominalDiffTime
48− , asText :: String
49− }
50− deriving (Eq, Show)
51−
52−testInterval :: TestEnv -> Assertion
53−testInterval env@TestEnv{..} = do
54−
55− initializeTable env
56−
57− let milliseconds = 0.001
58− seconds = 1
59− minutes = 60 * seconds
60− hours = 60 * minutes
61− days = 24 * hours
62− weeks = 7 * days
63− months = 1
64− years = 12 * months
65−
66− mapM (checkRoundTrip env)
67− [ IntervalTestCase
68− { label = "zero"
69− , inputMonths = 0
70− , inputSeconds = 0
71− , asText = "PT0"
72− }
73− , IntervalTestCase
74− { label = "1 year"
75− , inputMonths = 1 * years
76− , inputSeconds = 0
77− , asText = "P1Y"
78− }
79− , IntervalTestCase
80− { label = "2 months"
81− , inputMonths = 2 * months
82− , inputSeconds = 0
83− , asText = "P2M"
84− }
85− , IntervalTestCase
86− { label = "3 weeks"
87− , inputMonths = 0
88− , inputSeconds = 3 * weeks
89− , asText = "P3W"
90− }
91− , IntervalTestCase
92− { label = "4 days"
93− , inputMonths = 0
94− , inputSeconds = 4 * days
95− , asText = "P4D"
96− }
97− , IntervalTestCase
98− { label = "5 hours"
99− , inputMonths = 0
100− , inputSeconds = 5 * hours
101− , asText = "PT5H"
102− }
103− , IntervalTestCase
104− { label = "6 minutes"
105− , inputMonths = 0
106− , inputSeconds = 6 * minutes
107− , asText = "PT6M"
108− }
109− , IntervalTestCase
110− { label = "7 seconds"
111− , inputMonths = 0
112− , inputSeconds = 7 * seconds
113− , asText = "PT7S"
114− }
115− , IntervalTestCase
116− { label = "8 milliseconds"
117− , inputMonths = 0
118− , inputSeconds = 8 * milliseconds
119− , asText = "PT0.008S"
120− }
121− , IntervalTestCase
122− { label = "combination of intervals (day-size or bigger)"
123− , inputMonths = 2 * years + 4 * months
124− , inputSeconds = 3 * weeks + 5 * days
125− , asText = "P2Y4M3W5D"
126− }
127− , IntervalTestCase
128− { label = "combination of intervals (smaller than day-size)"
129− , inputMonths = 0
130− , inputSeconds = 18 * hours + 56 * minutes + 23 * seconds + 563 * milliseconds
131− , asText = "PT18H56M23.563S"
132− }
133− , IntervalTestCase
134− { label = "full combination of intervals"
135− , inputMonths = 2 * years + 4 * months
136− , inputSeconds = 3 * weeks + 5 * days + 18 * hours + 56 * minutes + 23 * seconds + 563 * milliseconds
137− , asText = "P2Y4M3W5DT18H56M23.563S"
138− }
139− ]
140−
141− return ()
142−
143−initializeTable :: TestEnv -> IO ()
144−initializeTable TestEnv{..} = withTransaction conn $ do
145− execute_ conn
146− [sql| CREATE TEMPORARY TABLE testinterval
147− ( id serial, sample interval, PRIMARY KEY(id) ) |]
148−
149− return ()
150−
151−checkRoundTrip :: TestEnv -> IntervalTestCase -> IO ()
152−checkRoundTrip TestEnv{..} IntervalTestCase{..} = do
153−
154− let input = CalendarDiffTime
155− { ctMonths = inputMonths
156− , ctTime = inputSeconds
157− }
158−
159− [(returnedId :: Int, output :: CalendarDiffTime)] <- query conn [sql|
160− INSERT INTO testinterval (sample)
161− VALUES (?)
162− RETURNING id, sample
163− |] (Only input)
164−
165− assertBool ("CalendarDiffTime did not round-trip from Haskell to SQL and back (" ++ label ++ ")") $
166− output == input
167−
168− [(Only isExpectedIso)] <- query conn [sql|
169− SELECT sample = (?)::interval
170− FROM testinterval
171− WHERE id = ?
172− |] (asText, returnedId)
173−
174− assertBool ("CalendarDiffTime inserted did not match ISO8601 equivalent \"" ++ asText ++ "\". (" ++ label ++ ")")
175− isExpectedIso
176−
test/Main.hs+28−574
@@ -1,95 +1,27 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DeriveGeneric #-}
3−{-# LANGUAGE DeriveDataTypeable #-}
4−{-# LANGUAGE DoAndIfThenElse #-}
5−{-# LANGUAGE ScopedTypeVariables #-}
6−#if __GLASGOW_HASKELL__ >= 806
7−{-# LANGUAGE DerivingStrategies #-}
8−{-# LANGUAGE DerivingVia #-}
9−{-# LANGUAGE DeriveAnyClass #-}
10−#endif
11−module Main (main) where
12−
131import Common
14−import Database.PostgreSQL.Simple.Copy
15−import Database.PostgreSQL.Simple.ToField (ToField)
16−import Database.PostgreSQL.Simple.FromField (FromField)
17−import Database.PostgreSQL.Simple.HStore
18−import Database.PostgreSQL.Simple.Newtypes
19−import Database.PostgreSQL.Simple.Internal (breakOnSingleQuestionMark)
20−import Database.PostgreSQL.Simple.Types(Query(..),Values(..), PGArray(..))
21−import qualified Database.PostgreSQL.Simple.Transaction as ST
22−
23−import Control.Applicative
242import Control.Exception as E
253import Control.Monad
26−import Data.Char
27−import Data.Foldable (toList)
28−import Data.List (concat, sort)
29−import Data.IORef
30−import Data.Monoid ((<>))
31−import Data.String (fromString)
32−import Data.Typeable
33−import GHC.Generics (Generic)
34−
35−import Data.Aeson
364import Data.ByteString (ByteString)
375import qualified Data.ByteString as B
38−import qualified Data.ByteString.Char8 as BS8
39−import qualified Data.ByteString.Lazy.Char8 as BL
40−import Data.CaseInsensitive (CI)
41−import qualified Data.CaseInsensitive as CI
42−import Data.Map (Map)
43−import qualified Data.Map as Map
44−import Data.Text(Text)
45−import qualified Data.Text.Encoding as T
46−import qualified Data.Vector as V
47−import System.FilePath
48−import System.Timeout(timeout)
49−import Data.Time.Compat (getCurrentTime, diffUTCTime)
50−import System.Environment (getEnvironment)
6+import System.Exit (exitFailure)
7+import System.IO
518
52−import Test.Tasty
53−import Test.Tasty.Golden
549import Notify
5510import Serializable
5611import Time
57−import Interval
58−import Exception (testExceptions)
5912
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
13+tests :: [TestEnv -> Test]
14+tests =
15+ [ TestLabel "Bytea" . testBytea
16+ , TestLabel "ExecuteMany" . testExecuteMany
17+ , TestLabel "Fold" . testFold
18+ , TestLabel "Notify" . testNotify
19+ , TestLabel "Serializable" . testSerializable
20+ , TestLabel "Time" . testTime
8921 ]
9022
91−testBytea :: TestEnv -> TestTree
92−testBytea TestEnv{..} = testGroup "Bytea"
23+testBytea :: TestEnv -> Test
24+testBytea TestEnv{..} = TestList
9325 [ testStr "empty" []
9426 , testStr "\"hello\"" $ map (fromIntegral . fromEnum) ("hello" :: String)
9527 , testStr "ascending" [0..255]
@@ -98,7 +30,7 @@ testBytea TestEnv{..} = testGroup "Bytea"
9830 , testStr "descending, doubled up" $ doubleUp [255,254..0]
9931 ]
10032 where
101− testStr label bytes = testCase label $ do
33+ testStr label bytes = TestLabel label $ TestCase $ do
10234 let bs = B.pack bytes
10335
10436 [Only h] <- query conn "SELECT md5(?::bytea)" [Binary bs]
@@ -109,8 +41,8 @@ testBytea TestEnv{..} = testGroup "Bytea"
10941
11042 doubleUp = concatMap (\x -> [x, x])
11143
112−testExecuteMany :: TestEnv -> Assertion
113−testExecuteMany TestEnv{..} = do
44+testExecuteMany :: TestEnv -> Test
45+testExecuteMany TestEnv{..} = TestCase $ do
11446 execute_ conn "CREATE TEMPORARY TABLE tmp_executeMany (i INT, t TEXT, b BYTEA)"
11547
11648 let rows :: [(Int, String, Binary ByteString)]
@@ -127,54 +59,12 @@ testExecuteMany TestEnv{..} = do
12759
12860 return ()
12961
130−testFold :: TestEnv -> Assertion
131−testFold TestEnv{..} = do
62+testFold :: TestEnv -> Test
63+testFold TestEnv{..} = TestCase $ do
13264 xs <- fold_ conn "SELECT generate_series(1,10000)"
13365 [] $ \xs (Only x) -> return (x:xs)
13466 reverse xs @?= ([1..10000] :: [Int])
13567
136− ref <- newIORef []
137− forEach conn "SELECT * FROM generate_series(1,?) a, generate_series(1,?) b"
138− (100 :: Int, 50 :: Int) $ \(a :: Int, b :: Int) -> do
139− xs <- readIORef ref
140− writeIORef ref $! (a,b):xs
141− xs <- readIORef ref
142− reverse xs @?= [(a,b) | b <- [1..50], a <- [1..100]]
143−
144− -- Make sure fold propagates our exception.
145− ref <- newIORef []
146− True <- expectError (== TestException) $
147− forEach_ conn "SELECT generate_series(1,10)" $ \(Only a) ->
148− if a == 5 then do
149− -- Cause a SQL error to trip up CLOSE.
150− True <- expectError isSyntaxError $
151− execute_ conn "asdf"
152− True <- expectError ST.isFailedTransactionError $
153− (query_ conn "SELECT 1" :: IO [(Only Int)])
154− throwIO TestException
155− else do
156− xs <- readIORef ref
157− writeIORef ref $! (a :: Int) : xs
158− xs <- readIORef ref
159− reverse xs @?= [1..4]
160−
161− withTransaction conn $ replicateM_ 2 $ do
162− xs <- fold_ conn "VALUES (1), (2), (3), (4), (5)"
163− [] $ \xs (Only x) -> return (x:xs)
164− reverse xs @?= ([1..5] :: [Int])
165−
166− ref <- newIORef []
167− forEach_ conn "SELECT generate_series(1,101)" $ \(Only a) ->
168− forEach_ conn "SELECT generate_series(1,55)" $ \(Only b) -> do
169− xs <- readIORef ref
170− writeIORef ref $! (a :: Int, b :: Int) : xs
171− xs <- readIORef ref
172− reverse xs @?= [(a,b) | a <- [1..101], b <- [1..55]]
173−
174− xs <- fold_ conn "SELECT 1 WHERE FALSE"
175− [] $ \xs (Only x) -> return (x:xs)
176− xs @?= ([] :: [Int])
177−
17868 -- TODO: add more complete tests, e.g.:
17969 --
18070 -- * Fold in a transaction
@@ -185,464 +75,28 @@ testFold TestEnv{..} = do
18575
18676 return ()
18777
188−queryFailure :: forall a. (FromField a, Typeable a, Show a)
189− => Connection -> Query -> a -> Assertion
190−queryFailure conn q resultType = do
191− x :: Either SomeException [Only a] <- E.try $ query_ conn q
192− case x of
193− Left _ -> return ()
194− Right val -> assertFailure ("Did not fail as expected: "
195− ++ show q
196− ++ " :: "
197− ++ show (typeOf resultType)
198− ++ " -> " ++ show val)
199−
200−testArray :: TestEnv -> Assertion
201−testArray TestEnv{..} = do
202− xs <- query_ conn "SELECT '{1,2,3,4}'::_int4"
203− xs @?= [Only (V.fromList [1,2,3,4 :: Int])]
204− xs <- query_ conn "SELECT '{{1,2},{3,4}}'::_int4"
205− xs @?= [Only (V.fromList [V.fromList [1,2],
206− V.fromList [3,4 :: Int]])]
207− queryFailure conn "SELECT '{1,2,3,4}'::_int4" (undefined :: V.Vector Bool)
208− queryFailure conn "SELECT '{{1,2},{3,4}}'::_int4" (undefined :: V.Vector Int)
209−
210−testNullableArray :: TestEnv -> Assertion
211−testNullableArray TestEnv{..} = do
212− xs <- query_ conn "SELECT '{sometext, \"NULL\"}'::_text"
213− xs @?= [Only (V.fromList ["sometext", "NULL" :: Text])]
214− xs <- query_ conn "SELECT '{sometext, NULL}'::_text"
215− xs @?= [Only (V.fromList [Just "sometext", Nothing :: Maybe Text])]
216− queryFailure conn "SELECT '{sometext, NULL}'::_text" (undefined :: V.Vector Text)
217−
218−testHStore :: TestEnv -> Assertion
219−testHStore TestEnv{..} = do
220− execute_ conn "CREATE EXTENSION IF NOT EXISTS hstore"
221− roundTrip []
222− roundTrip [("foo","bar"),("bar","baz"),("baz","hello")]
223− roundTrip [("fo\"o","bar"),("b\\ar","baz"),("baz","\"value\\with\"escapes")]
224− where
225− roundTrip :: [(Text,Text)] -> Assertion
226− roundTrip xs = do
227− let m = Only (HStoreMap (Map.fromList xs))
228− m' <- query conn "SELECT ?::hstore" m
229− [m] @?= m'
230−
231−testCIText :: TestEnv -> Assertion
232−testCIText TestEnv{..} = do
233− execute_ conn "CREATE EXTENSION IF NOT EXISTS citext"
234− roundTrip (CI.mk "")
235− roundTrip (CI.mk "UPPERCASE")
236− roundTrip (CI.mk "lowercase")
237− where
238− roundTrip :: (CI Text) -> Assertion
239− roundTrip cit = do
240− let toPostgres = Only cit
241− fromPostgres <- query conn "SELECT ?::citext" toPostgres
242− [toPostgres] @?= fromPostgres
243−
244−testJSON :: TestEnv -> Assertion
245−testJSON TestEnv{..} = do
246− roundTrip (Map.fromList [] :: Map Text Text)
247− roundTrip (Map.fromList [("foo","bar"),("bar","baz"),("baz","hello")] :: Map Text Text)
248− roundTrip (Map.fromList [("fo\"o","bar"),("b\\ar","baz"),("baz","\"value\\with\"escapes")] :: Map Text Text)
249− roundTrip (V.fromList [1,2,3,4,5::Int])
250− roundTrip ("foo" :: Text)
251− roundTrip (42 :: Int)
252− where
253− roundTrip :: ToJSON a => a -> Assertion
254− roundTrip a = do
255− let js = Only (toJSON a)
256− js' <- query conn "SELECT ?::json" js
257− [js] @?= js'
258−
259−testAeson :: TestEnv -> Assertion
260−testAeson TestEnv{..} = do
261− roundTrip (Map.fromList [] :: Map Text Text)
262− roundTrip (Map.fromList [("foo","bar"),("bar","baz"),("baz","hello")] :: Map Text Text)
263− roundTrip (Map.fromList [("fo\"o","bar"),("b\\ar","baz"),("baz","\"value\\with\"escapes")] :: Map Text Text)
264− roundTrip (V.fromList [1,2,3,4,5::Int])
265− roundTrip ("foo" :: Text)
266− roundTrip (42 :: Int)
267− where
268− roundTrip :: (Eq a, Show a, Typeable a, ToJSON a, FromJSON a)=> a -> Assertion
269− roundTrip x = do
270− y <- query conn "SELECT ?::json" (Only (Aeson x))
271− [Only (Aeson x)] @?= y
272−
273−testDerivingVia :: TestEnv -> Assertion
274−testDerivingVia TestEnv{..} = do
275−#if __GLASGOW_HASKELL__ <806
276− return ()
277−#else
278− roundTrip $ DerivingVia1 42 "Meaning of Life"
279− where
280− roundTrip :: (Eq a, Show a, Typeable a, ToField a, FromField a)=> a -> Assertion
281− roundTrip x = do
282− y <- query conn "SELECT ?::json" (Only x)
283− [Only x] @?= y
284−
285−data DerivingVia1 = DerivingVia1 Int String
286− deriving stock (Eq, Show, Generic)
287− deriving anyclass (FromJSON, ToJSON)
288− deriving (ToField, FromField) via Aeson DerivingVia1
289−
290−#endif
291−
292−
293−testQM :: TestEnv -> Assertion
294−testQM TestEnv{..} = do
295− -- Just test on a single string
296− let testQuery' b = "testing for ?" <> b <> " and making sure "
297− testQueryDoubleQM = testQuery' "?"
298− testQueryRest = "? is substituted"
299− testQuery = fromString $ testQueryDoubleQM <> testQueryRest
300− -- expect the entire first part with double QMs replaced with literal '?'
301− expected = (fromString $ testQuery' "", fromString testQueryRest)
302− tried = breakOnSingleQuestionMark testQuery
303− errMsg = concat
304− [ "Failed to break on single question mark exclusively:\n"
305− , "expected: ", show expected
306− , "result: ", show tried
307− ]
308− assertBool errMsg $ tried == expected
309−
310− -- Let's also test the question mark operators in action
311− -- ? -> Does the string exist as a top-level key within the JSON value?
312− positiveQuery "SELECT ?::jsonb ?? ?" (testObj, "foo" :: Text)
313− negativeQuery "SELECT ?::jsonb ?? ?" (testObj, "baz" :: Text)
314− negativeQuery "SELECT ?::jsonb ?? ?" (toJSON numArray, "1" :: Text)
315− -- ?| -> Do any of these array strings exist as top-level keys?
316− positiveQuery "SELECT ?::jsonb ??| ?" (testObj, PGArray ["nope","bar","6" :: Text])
317− negativeQuery "SELECT ?::jsonb ??| ?" (testObj, PGArray ["nope","6" :: Text])
318− negativeQuery "SELECT ?::jsonb ??| ?" (toJSON numArray, PGArray ["1","2","6" :: Text])
319− -- ?& -> Do all of these array strings exist as top-level keys?
320− positiveQuery "SELECT ?::jsonb ??& ?" (testObj, PGArray ["foo","bar","quux" :: Text])
321− positiveQuery "SELECT ?::jsonb ??& ?" (testObj, PGArray ["foo","bar" :: Text])
322− negativeQuery "SELECT ?::jsonb ??& ?" (testObj, PGArray ["foo","bar","baz" :: Text])
323− negativeQuery "SELECT ?::jsonb ??& ?" (toJSON numArray, PGArray ["1","2","3","4","5" :: Text])
324− -- Format error for 2 question marks, not 4
325− True <- expectError (isFormatError 2) $
326− (query conn "SELECT ?::jsonb ?? ?" $ Only testObj :: IO [Only Bool])
327− return ()
328− where positiveQuery :: ToRow a => Query -> a -> Assertion
329− positiveQuery = boolQuery True
330− negativeQuery :: ToRow a => Query -> a -> Assertion
331− negativeQuery = boolQuery False
332− numArray :: [Int]
333− numArray = [1,2,3,4,5]
334− boolQuery :: ToRow a => Bool -> Query -> a -> Assertion
335− boolQuery b t x = do
336− a <- query conn t x
337− [Only b] @?= a
338− testObj = toJSON (Map.fromList [("foo",toJSON (1 :: Int))
339− ,("bar",String "baz")
340− ,("quux",toJSON [1 :: Int,2,3,4,5])] :: Map Text Value
341− )
342−
343−testSavepoint :: TestEnv -> Assertion
344−testSavepoint TestEnv{..} = do
345− True <- expectError ST.isNoActiveTransactionError $
346− withSavepoint conn $ return ()
347−
348− let getRows :: IO [Int]
349− getRows = map fromOnly <$> query_ conn "SELECT a FROM tmp_savepoint ORDER BY a"
350− withTransaction conn $ do
351− execute_ conn "CREATE TEMPORARY TABLE tmp_savepoint (a INT UNIQUE)"
352− execute_ conn "INSERT INTO tmp_savepoint VALUES (1)"
353− [1] <- getRows
354−
355− withSavepoint conn $ do
356− execute_ conn "INSERT INTO tmp_savepoint VALUES (2)"
357− [1,2] <- getRows
358− return ()
359− [1,2] <- getRows
360−
361− withSavepoint conn $ do
362− execute_ conn "INSERT INTO tmp_savepoint VALUES (3)"
363− [1,2,3] <- getRows
364− True <- expectError isUniqueViolation $
365− execute_ conn "INSERT INTO tmp_savepoint VALUES (2)"
366− True <- expectError ST.isFailedTransactionError getRows
367−
368− -- Body returning successfully after handling error,
369− -- but 'withSavepoint' will roll back without complaining.
370− return ()
371− -- Rolling back clears the error condition.
372− [1,2] <- getRows
373−
374− -- 'withSavepoint' will roll back after an exception, even if the
375− -- exception wasn't SQL-related.
376− True <- expectError (== TestException) $
377− withSavepoint conn $ do
378− execute_ conn "INSERT INTO tmp_savepoint VALUES (3)"
379− [1,2,3] <- getRows
380− throwIO TestException
381− [1,2] <- getRows
382−
383− -- Nested savepoint can be rolled back while the
384− -- outer effects are retained.
385− withSavepoint conn $ do
386− execute_ conn "INSERT INTO tmp_savepoint VALUES (3)"
387− True <- expectError isUniqueViolation $
388− withSavepoint conn $ do
389− execute_ conn "INSERT INTO tmp_savepoint VALUES (4)"
390− [1,2,3,4] <- getRows
391− execute_ conn "INSERT INTO tmp_savepoint VALUES (4)"
392− [1,2,3] <- getRows
393− return ()
394− [1,2,3] <- getRows
395−
396− return ()
397−
398− -- Transaction committed successfully, even though there were errors
399− -- (but we rolled them back).
400− [1,2,3] <- getRows
401−
402− return ()
403−
404−testUnicode :: TestEnv -> Assertion
405−testUnicode TestEnv{..} = do
406− let q = Query . T.encodeUtf8 -- Handle encoding ourselves to ensure
407− -- the table gets created correctly.
408− let messages = map Only ["привет","мир"] :: [Only Text]
409− execute_ conn (q "CREATE TEMPORARY TABLE ру́сский (сообщение TEXT)")
410− executeMany conn "INSERT INTO ру́сский (сообщение) VALUES (?)" messages
411− messages' <- query_ conn "SELECT сообщение FROM ру́сский"
412− sort messages @?= sort messages'
413−
414−testValues :: TestEnv -> Assertion
415−testValues TestEnv{..} = do
416− execute_ conn "CREATE TEMPORARY TABLE values_test (x int, y text)"
417− test (Values ["int4","text"] [])
418− test (Values ["int4","text"] [(1,"hello")])
419− test (Values ["int4","text"] [(1,"hello"),(2,"world")])
420− test (Values ["int4","text"] [(1,"hello"),(2,"world"),(3,"goodbye")])
421− test (Values [] [(1,"hello")])
422− test (Values [] [(1,"hello"),(2,"world")])
423− test (Values [] [(1,"hello"),(2,"world"),(3,"goodbye")])
424− where
425− test :: Values (Int, Text) -> Assertion
426− test table@(Values _ vals) = do
427− execute conn "INSERT INTO values_test ?" (Only table)
428− vals' <- query_ conn "DELETE FROM values_test RETURNING *"
429− sort vals @?= sort vals'
430−
431−
432−testCopy :: TestEnv -> Assertion
433−testCopy TestEnv{..} = do
434− execute_ conn "CREATE TEMPORARY TABLE copy_test (x int, y text)"
435− copy_ conn "COPY copy_test FROM STDIN (FORMAT CSV)"
436− mapM_ (putCopyData conn) copyRows
437− putCopyEnd conn
438− copy_ conn "COPY copy_test FROM STDIN (FORMAT CSV)"
439− mapM_ (putCopyData conn) abortRows
440− putCopyError conn "aborted"
441− -- Hmm, does postgres always produce \n as an end-of-line here, or
442− -- are there cases where it will use a \r\n as well?
443− copy_ conn "COPY copy_test TO STDOUT (FORMAT CSV)"
444− rows <- loop []
445− sort rows @?= sort copyRows
446− -- Now, let's just verify that the connection state is back to ready,
447− -- so that we can issue more queries:
448− [Only (x::Int)] <- query_ conn "SELECT 2 + 2"
449− x @?= 4
450− -- foldCopyData
451− copy_ conn "COPY copy_test TO STDOUT (FORMAT CSV)"
452− (acc, count) <- foldCopyData conn
453− (\acc row -> return (row:acc))
454− (\acc count -> return (acc, count))
455− []
456− sort acc @?= sort copyRows
457− count @?= 2
458− where
459− copyRows = ["1,foo\n"
460− ,"2,bar\n"]
461− abortRows = ["3,baz\n"]
462− loop rows = do
463− mrow <- getCopyData conn
464− case mrow of
465− CopyOutDone _ -> return rows
466− CopyOutRow row -> loop (row:rows)
467−
468−testCopyFailures :: TestEnv -> TestTree
469−testCopyFailures env = testGroup "Copy failures"
470− $ map ($ env)
471− [ testCopyUniqueConstraintError
472− , testCopyMalformedError
473− ]
474−
475−goldenTest :: TestName -> IO BL.ByteString -> TestTree
476−goldenTest testName =
477− goldenVsStringDiff testName diff (resultsDir </> fileName<.>"expected")
478− where
479− resultsDir = "test" </> "results"
480− fileName = map normalize testName
481− normalize c | not (isAlpha c) = '-'
482− | otherwise = c
483− diff ref new = ["diff", "-u", ref, new]
484−
485−-- | Test that we provide a sensible error message on failure
486−testCopyUniqueConstraintError :: TestEnv -> TestTree
487−testCopyUniqueConstraintError TestEnv{..} =
488− goldenTest "unique constraint violation"
489− $ handle (\(SomeException exc) -> return $ BL.pack $ show exc) $ do
490− execute_ conn "CREATE TEMPORARY TABLE copy_unique_constraint_error_test (x int PRIMARY KEY, y text)"
491− copy_ conn "COPY copy_unique_constraint_error_test FROM STDIN (FORMAT CSV)"
492− mapM_ (putCopyData conn) copyRows
493− _n <- putCopyEnd conn
494− return BL.empty
495− where
496− copyRows = ["1,foo\n"
497− ,"2,bar\n"
498− ,"1,baz\n"]
499−
500−testCopyMalformedError :: TestEnv -> TestTree
501−testCopyMalformedError TestEnv{..} =
502− goldenTest "malformed input"
503− $ handle (\(SomeException exc) -> return $ BL.pack $ show exc) $ do
504− execute_ conn "CREATE TEMPORARY TABLE copy_malformed_input_error_test (x int PRIMARY KEY, y text)"
505− copy_ conn "COPY copy_unique_constraint_error_test FROM STDIN (FORMAT CSV)"
506− mapM_ (putCopyData conn) copyRows
507− _n <- putCopyEnd conn
508− return BL.empty
509− where
510− copyRows = ["1,foo\n"
511− ,"2,bar\n"
512− ,"z,baz\n"]
513−
514−testTimeout :: TestEnv -> Assertion
515−testTimeout TestEnv{..} =
516− withConn $ \c -> do
517− start_t <- getCurrentTime
518− res <- timeout 200000 $ do
519− withTransaction c $ do
520− query_ c "SELECT pg_sleep(1)" :: IO [Only ()]
521− end_t <- getCurrentTime
522− assertBool "Timeout did not occur" (res == Nothing)
523−#if !defined(mingw32_HOST_OS)
524−-- At the moment, you cannot timely abandon queries with async exceptions on
525−-- Windows.
526− let d = end_t `diffUTCTime` start_t
527− assertBool "Timeout didn't work in a timely fashion" (0.1 < d && d < 0.6)
528−#endif
529−
530−testDouble :: TestEnv -> Assertion
531−testDouble TestEnv{..} = do
532− [Only (x :: Double)] <- query_ conn "SELECT 'NaN'::float8"
533− assertBool "expected NaN" (isNaN x)
534− [Only (x :: Double)] <- query_ conn "SELECT 'Infinity'::float8"
535− x @?= (1 / 0)
536− [Only (x :: Double)] <- query_ conn "SELECT '-Infinity'::float8"
537− x @?= (-1 / 0)
538−
539−
540−testGeneric1 :: TestEnv -> Assertion
541−testGeneric1 TestEnv{..} = do
542− roundTrip conn (Gen1 123)
543− where
544− roundTrip conn x0 = do
545− r <- query conn "SELECT ?::int" (x0 :: Gen1)
546− r @?= [x0]
547−
548−testGeneric2 :: TestEnv -> Assertion
549−testGeneric2 TestEnv{..} = do
550− roundTrip conn (Gen2 123 "asdf")
551− where
552− roundTrip conn x0 = do
553− r <- query conn "SELECT ?::int, ?::text" x0
554− r @?= [x0]
555−
556−testGeneric3 :: TestEnv -> Assertion
557−testGeneric3 TestEnv{..} = do
558− roundTrip conn (Gen3 123 "asdf" True)
559− where
560− roundTrip conn x0 = do
561− r <- query conn "SELECT ?::int, ?::text, ?::bool" x0
562− r @?= [x0]
563−
564−data Gen1 = Gen1 Int
565− deriving (Show,Eq,Generic)
566−instance FromRow Gen1
567−instance ToRow Gen1
568−
569−data Gen2 = Gen2 Int Text
570− deriving (Show,Eq,Generic)
571−instance FromRow Gen2
572−instance ToRow Gen2
573−
574−data Gen3 = Gen3 Int Text Bool
575− deriving (Show,Eq,Generic)
576−instance FromRow Gen3
577−instance ToRow Gen3
578−
579−data TestException
580− = TestException
581− deriving (Eq, Show, Typeable)
582−
583−instance Exception TestException
584−
585−expectError :: Exception e => (e -> Bool) -> IO a -> IO Bool
586−expectError p io =
587− (io >> return False) `E.catch` \ex ->
588− if p ex then return True else throwIO ex
589−
590−isUniqueViolation :: SqlError -> Bool
591−isUniqueViolation SqlError{..} = sqlState == "23505"
592−
593−isSyntaxError :: SqlError -> Bool
594−isSyntaxError SqlError{..} = sqlState == "42601"
595−
596−isFormatError :: Int -> FormatError -> Bool
597−isFormatError i FormatError{..}
598− | null fmtMessage = False
599− | otherwise = fmtMessage == concat [ show i
600− , " single '?' characters, but "
601− , show (length fmtParams)
602− , " parameters"
603− ]
60478------------------------------------------------------------------------
60579
60680-- | Action for connecting to the database that will be used for testing.
60781--
60882-- Note that some tests, such as Notify, use multiple connections, and assume
60983-- that 'testConnect' connects to the same database every time it is called.
610−withTestEnv :: ByteString -> (TestEnv -> IO a) -> IO a
611−withTestEnv connstr cb =
612− withConn $ \conn -> do
613− -- currently required for interval to work.
614− -- we also test that this doesn't interfere with anything else
615− execute_ conn "SET intervalstyle TO 'iso_8601'"
84+testConnect :: IO Connection
85+testConnect = connectPostgreSQL ""
61686
87+withTestEnv :: (TestEnv -> IO a) -> IO a
88+withTestEnv cb =
89+ withConn $ \conn ->
61790 cb TestEnv
61891 { conn = conn
61992 , withConn = withConn
62093 }
62194 where
622− withConn = bracket (connectPostgreSQL connstr) close
95+ withConn = bracket testConnect close
62396
62497main :: IO ()
625−main = withConnstring $ \connstring -> do
626− withTestEnv connstring (defaultMain . tests)
627−
628−withConnstring :: (BS8.ByteString -> IO ()) -> IO ()
629−withConnstring kont = do
630− env <- getEnvironment
631− case lookup "DATABASE_CONNSTRING" env of
632− Just s -> kont (BS8.pack (special s))
633− Nothing -> case lookup "GITHUB_ACTIONS" env of
634− Just "true" -> kont (BS8.pack gha)
635− _ -> putStrLn "Set DATABASE_CONNSTRING environment variable"
636− where
637− -- https://www.appveyor.com/docs/services-databases/
638− special "appveyor" = "dbname='TestDb' user='postgres' password='Password12!'"
639− special "travis" = ""
640− special s = s
641−
642− gha = unwords
643− [ "dbname='postgres'"
644− , "user='postgres'"
645− , "password='postgres'"
646− , "host='postgres'"
647− , "port=5432"
648− ]
98+main = do
99+ mapM_ (`hSetBuffering` LineBuffering) [stdout, stderr]
100+ Counts{cases, tried, errors, failures} <-
101+ withTestEnv $ \env -> runTestTT $ TestList $ map ($ env) tests
102+ when (cases /= tried || errors /= 0 || failures /= 0) $ exitFailure
test/Notify.hs+2−1
@@ -14,8 +14,9 @@ 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 -> Assertion
17+testNotify :: TestEnv -> Test
1818testNotify TestEnv{..} =
19+ TestCase $
1920 withConn $ \conn2 -> do
2021 execute_ conn "LISTEN foo"
2122 execute_ conn "LISTEN bar"
test/Serializable.hs+2−2
@@ -4,7 +4,6 @@ import Common
44import Control.Concurrent
55import Control.Exception as E
66import Data.IORef
7−import Database.PostgreSQL.Simple.Transaction
87
98initCounter :: Connection -> IO ()
109initCounter conn = do
@@ -23,8 +22,9 @@ putCounter conn n = do
2322 1 <- execute conn "UPDATE testSerializableCounter SET n=?" (Only n)
2423 return ()
2524
26−testSerializable :: TestEnv -> Assertion
25+testSerializable :: TestEnv -> Test
2726testSerializable TestEnv{..} =
27+ TestCase $
2828 withConn $ \conn2 -> do
2929 initCounter conn
3030
test/Time.hs+15−63
@@ -17,82 +17,42 @@ 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−
3320-}
3421
3522module Time (testTime) where
3623
3724import Common
3825import Control.Monad(forM_, replicateM_)
39−import Data.Time.Compat
26+import Data.Time
4027import Data.ByteString(ByteString)
4128import Database.PostgreSQL.Simple.SqlQQ
4229
4330numTests :: Int
4431numTests = 200
4532
46−testTime :: TestEnv -> Assertion
47−testTime env@TestEnv{..} = do
33+testTime :: TestEnv -> Test
34+testTime env@TestEnv{..} = TestCase $ do
4835 initializeTable env
4936 execute_ conn "SET timezone TO 'UTC'"
50− checkRoundTrips env "1860-01-01 00:00:00+00"
51− execute_ conn "SET timezone TO 'America/Chicago'" -- -5:00
52− checkRoundTrips env "1883-11-18 12:00:00-06"
53− execute_ conn "SET timezone TO 'Asia/Tokyo'" -- +9:00
54− checkRoundTrips env "1888-01-01 00:00:00+09"
55− execute_ conn "SET timezone TO 'Asia/Kathmandu'" -- +5:45
56− checkRoundTrips env "1919-12-31 23:48:44+05:30"
57− execute_ conn "SET timezone TO 'America/St_Johns'" -- -3:30
58− checkRoundTrips env "1935-03-30 00:00:52-03:30"
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
5946
6047initializeTable :: TestEnv -> IO ()
6148initializeTable TestEnv{..} = withTransaction conn $ do
6249 execute_ conn
6350 [sql| CREATE TEMPORARY TABLE testtime
6451 ( 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−
9252 let pop :: ByteString -> Double -> IO () = \x y ->
9353 replicateM_ numTests $ execute conn
9454 [sql| INSERT INTO testtime (y) VALUES
95− ('1860-01-01 00:00:00+00'::timestamptz
55+ ('1936-01-01 00:00:00+00'::timestamptz
9656 + ?::interval * ROUND(RANDOM() * ?)) |] (x,y)
9757 pop "1 microsecond" 6.3113904e15
9858 pop "10 microseconds" 6.3113904e14
@@ -102,18 +62,10 @@ initializeTable TestEnv{..} = withTransaction conn $ do
10262 pop "100 milliseconds" 6.3113904e10
10363 pop "1 second" 6.3113904e9
10464
105−checkRoundTrips :: TestEnv -> ByteString -> IO ()
106−checkRoundTrips TestEnv{..} limit = do
65+checkRoundTrips :: TestEnv -> IO ()
66+checkRoundTrips TestEnv{..} = do
10767 yxs :: [(UTCTime, Int)] <- query_ conn [sql| SELECT y, x FROM testtime |]
10868 forM_ yxs $ \yx -> do
10969 res <- query conn [sql| SELECT y=? FROM testtime WHERE x=? |] yx
11070 assertBool "UTCTime did not round-trip from SQL to Haskell and back" $
11171 res == [Only True]
112−
113− yxs :: [(ZonedTime, Int)] <- query conn [sql|
114− SELECT y, x FROM testtime WHERE y > ?
115− |] (Only limit)
116− forM_ yxs $ \yx -> do
117− res <- query conn [sql| SELECT y=? FROM testtime WHERE x=? |] yx
118− assertBool "ZonedTime did not round-trip from SQL to Haskell and back" $
119− res == [Only True]
test/results/malformed-input.expecteddeleted−4
@@ -1,4 +0,0 @@
1−user error (Database.PostgreSQL.Simple.Copy.putCopyEnd: failed to parse command status
2−Connection error: ERROR: invalid input syntax for type integer: "z"
3−CONTEXT: COPY copy_unique_constraint_error_test, line 3, column x: "z"
4−)
test/results/unique-constraint-violation.expecteddeleted−5
@@ -1,5 +0,0 @@
1−user error (Database.PostgreSQL.Simple.Copy.putCopyEnd: failed to parse command status
2−Connection error: ERROR: duplicate key value violates unique constraint "copy_unique_constraint_error_test_pkey"
3−DETAIL: Key (x)=(1) already exists.
4−CONTEXT: COPY copy_unique_constraint_error_test, line 3
5−)
tools/GenBuiltinTypes.hsnew file+180
@@ -0,0 +1,180 @@
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+|]
88+
89+instance IsString Blaze.Builder where
90+ fromString = Blaze.fromByteString . fromString
91+
92+main = do
93+ conn <- connectPostgreSQL ""
94+ xs <- query conn "SELECT typname::text, oid::int\
95+ \ FROM pg_type\
96+ \ WHERE typname IN ?"
97+ (Only (In (sort (map fst builtins))))
98+ close conn
99+ let oidmap = Map.fromList xs :: Map
100+ L.writeFile "../src/Database/PostgreSQL/Simple/BuiltinTypes.hs"
101+ (Blaze.toLazyByteString (renderFile oidmap builtins))
102+
103+padCons str = fromString (replicate (len - B.length str) ' ')
104+ where
105+ len = maximum (map (B.length . snd) builtins)
106+
107+renderOid oidmap x
108+ = case Map.lookup x oidmap of
109+ Nothing -> error (B.unpack x)
110+ Just (show -> n) -> fromString (replicate (4 - length n) ' ')
111+ ++ fromString n
112+
113+renderOid' oidmap x
114+ = case Map.lookup x oidmap of
115+ Nothing -> error (B.unpack x)
116+ Just (show -> n) -> fromString n
117+ ++ fromString (replicate (4 - length n) ' ')
118+
119+bs = Blaze.fromByteString
120+
121+renderFile :: Map -> [(B.ByteString,B.ByteString)] -> Blaze.Builder
122+renderFile oidmap builtins = ([longstring|
123+{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}
124+
125+------------------------------------------------------------------------------
126+-- |
127+-- Module: Database.PostgreSQL.Simple.BuiltinTypes
128+-- Copyright: (c) 2011-2012 Leon P Smith
129+-- License: BSD3
130+-- Maintainer: Leon P Smith <leon@melding-monads.com>
131+-- Stability: experimental
132+--
133+------------------------------------------------------------------------------
134+
135+-- Note that this file is generated by tools/GenBuiltinTypes.hs, and should
136+-- not be edited directly
137+
138+module Database.PostgreSQL.Simple.BuiltinTypes
139+ ( BuiltinType (..)
140+ , builtin2oid
141+ , oid2builtin
142+ , builtin2typname
143+ , oid2typname
144+ ) where
145+
146+import Data.Typeable
147+import Data.ByteString (ByteString)
148+import qualified Database.PostgreSQL.LibPQ as PQ
149+
150+data BuiltinType
151+ = |] ++ mconcat (intersperse "\n | " (map (Blaze.fromByteString . snd) builtins)) ++ [longstring|
152+
153+ deriving (Eq, Ord, Enum, Bounded, Read, Show, Typeable)
154+
155+builtin2oid :: BuiltinType -> PQ.Oid
156+builtin2oid typ = PQ.Oid $ case typ of
157+|] ++ mconcat [mconcat [ " ", bs y, padCons y, " -> "
158+ , renderOid oidmap x, "\n" ]
159+ | (x,y) <- builtins ] ++ [longstring|
160+
161+oid2builtin :: PQ.Oid -> Maybe BuiltinType
162+oid2builtin (PQ.Oid x) = case x of
163+|] ++ mconcat [mconcat [ " ", renderOid' oidmap x, " -> Just ", bs y, "\n" ]
164+ | (x,y) <- builtins ] ++ [longstring|
165+ _ -> Nothing
166+
167+builtin2typname :: BuiltinType -> ByteString
168+builtin2typname typ = case typ of
169+|] ++ mconcat [mconcat [ " ", bs y, padCons y, " -> ", bs x, "\n"]
170+ | (x,y) <- builtins] ++ [longstring|
171+
172+oid2typname :: PQ.Oid -> Maybe ByteString
173+oid2typname (PQ.Oid x) = case x of
174+|] ++ mconcat [mconcat [ " ", renderOid' oidmap x, " -> Just ", bs x, "\n" ]
175+ | (x,y) <- builtins ]
176+ ++ " _ -> Nothing\n"
177+ ++ mconcat [mconcat [ "\n"
178+ , bs x, " :: ByteString\n"
179+ , bs x, " = \"", bs x, "\"\n"]
180+ | (x,_y) <- builtins ])
tools/GenTypeInfo.hs+52−177
@@ -21,9 +21,6 @@
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−-- @
2724------------------------------------------------------------------------------
2825
2926{-# LANGUAGE OverloadedStrings, QuasiQuotes, ViewPatterns, RecordWildCards #-}
@@ -41,10 +38,12 @@ import Database.PostgreSQL.Simple.FromRow
4138import Database.PostgreSQL.Simple.Ok
4239import Database.PostgreSQL.Simple.Types(Oid(..))
4340import Database.PostgreSQL.Simple.SqlQQ
44−import qualified Data.ByteString.Char8 as B8
41+import qualified Data.ByteString.Char8 as B
4542import Data.ByteString(ByteString)
4643import qualified Data.ByteString.Lazy as L
47−import qualified Data.ByteString.Builder as Blaze
44+import qualified Blaze.ByteString.Builder as Blaze
45+import qualified Blaze.ByteString.Builder.ByteString as Blaze
46+import qualified Blaze.ByteString.Builder.Char8 as Blaze
4847import Data.String
4948import Data.List ( sort, intersperse )
5049import qualified Data.Map as Map
@@ -64,17 +63,18 @@ data TypeInfo = TypeInfo
6463 , typdelim :: Char
6564 , typname :: ByteString
6665 , typelem :: Oid
67− , rngsubtype :: Maybe Oid
6866 }
6967
70−instance FromRow TypeInfo where
71− fromRow = TypeInfo <$> field <*> field <*> field <*> field <*> field <*> field
68+instance FromRow TypeInfo where
69+ fromRow = TypeInfo <$> field <*> charF <*> charF <*> field <*> field
70+ where charF = fieldWith (\_f dat -> Ok (B.head (unJust dat)))
71+ unJust (Just x) = x
7272
73−type NameMap = Map.Map B8.ByteString TypeInfo
73+type NameMap = Map.Map B.ByteString TypeInfo
7474
7575type OidMap = Map.Map Oid TypeInfo
7676
77−type TypeName = (B8.ByteString, B8.ByteString)
77+type TypeName = (B.ByteString, B.ByteString)
7878
7979type TypeNames = [TypeName]
8080
@@ -105,6 +105,9 @@ line
105105cidr
106106float4
107107float8
108+abstime
109+reltime
110+tinterval
108111unknown
109112circle
110113money
@@ -124,118 +127,47 @@ numeric
124127refcursor
125128record
126129void
127−_record array_record
128−regprocedure
129−regoper
130−regoperator
131−regclass
132−regtype
133130uuid
134−json
135−jsonb
136−int2vector
137−oidvector
138−_xml array_xml
139−_json array_json
140−_line array_line
141−_cidr array_cidr
142−_circle array_circle
143−_money array_money
144−_bool array_bool
145−_bytea array_bytea
146−_char array_char
147−_name array_name
148−_int2 array_int2
149−_int2vector array_int2vector
150−_int4 array_int4
151−_regproc array_regproc
152−_text array_text
153−_tid array_tid
154−_xid array_xid
155−_cid array_cid
156−_oidvector array_oidvector
157−_bpchar array_bpchar
158−_varchar array_varchar
159−_int8 array_int8
160−_point array_point
161−_lseg array_lseg
162−_path array_path
163−_box array_box
164−_float4 array_float4
165−_float8 array_float8
166−_polygon array_polygon
167−_oid array_oid
168−_macaddr array_macaddr
169−_inet array_inet
170−_timestamp array_timestamp
171−_date array_date
172−_time array_time
173−_timestamptz array_timestamptz
174−_interval array_interval
175−_numeric array_numeric
176−_timetz array_timetz
177−_bit array_bit
178−_varbit array_varbit
179−_refcursor array_refcursor
180−_regprocedure array_regprocedure
181−_regoper array_regoper
182−_regoperator array_regoperator
183−_regclass array_regclass
184−_regtype array_regtype
185−_uuid array_uuid
186−_jsonb array_jsonb
187−int4range
188−_int4range
189−numrange
190−_numrange
191−tsrange
192−_tsrange
193−tstzrange
194−_tstzrange
195−daterange
196−_daterange
197−int8range
198−_int8range
199131|]
200132
133+instance IsString Blaze.Builder where
134+ fromString = Blaze.fromByteString . fromString
135+
201136connectionString = "dbname=postgres"
202137
203138withPostgreSQL = bracket (connectPostgreSQL connectionString) close
204139
205140getTypeInfos :: TypeNames -> IO (OidMap, NameMap)
206141getTypeInfos typnames = withPostgreSQL $ \conn -> do
207− infos <- query conn [sql|
208− WITH types AS
209− (SELECT oid, typcategory, typdelim, typname, typelem
210− FROM pg_type WHERE typname IN ?)
211− SELECT types.*, rngsubtype FROM types LEFT JOIN pg_range ON oid = rngtypid
212− |] (Only (In (sort (map pg typnames))))
142+ infos <- query conn [sql|
143+ SELECT oid, typcategory, typdelim, typname, typelem
144+ FROM pg_type
145+ WHERE typname IN ?
146+ |]
147+ (Only (In (sort (map pg typnames))))
213148 loop conn (oidMap infos) (nameMap infos) infos
214149 where
215150 oidMap = Map.fromList . map (typoid &&& id)
216151 nameMap = Map.fromList . map (typname &&& id)
217152 loop conn oids names infos = do
218− let unknowns = [ x | x <- map typelem infos ++
219− [ x | Just x <- map rngsubtype infos ],
153+ let unknowns = [ x | x <- map typelem infos,
220154 x /= Oid 0,
221155 not (Map.member x oids) ]
222156 case unknowns of
223157 [] -> return (oids, names)
224158 (_:_) -> do
225159 infos' <- query conn [sql|
226− WITH types AS
227− (SELECT oid, typcategory, typdelim, typname, typelem
228− FROM pg_type WHERE oid IN ?)
229− SELECT types.*, rngsubtype
230− FROM types LEFT JOIN pg_range ON oid = rngtypid
231− |] (Only (In (sort unknowns)))
160+ SELECT oid, typcategory, typdelim, typname, typelem
161+ FROM pg_type
162+ WHERE oid IN ?
163+ |] (Only (In (sort unknowns)))
232164 let oids' = oids `Map.union` oidMap infos'
233165 names' = names `Map.union` nameMap infos'
234166 loop conn oids' names' infos'
235167
236168main = do
237169 (oidmap, namemap) <- getTypeInfos typeNames
238− L.writeFile "src/Database/PostgreSQL/Simple/TypeInfo/Static.hs"
170+ L.writeFile "../src/Database/PostgreSQL/Simple/TypeInfo/Static.hs"
239171 (Blaze.toLazyByteString (renderFile oidmap namemap typeNames))
240172
241173
@@ -244,7 +176,7 @@ showOid (Oid n) = show n
244176renderOid :: NameMap -> TypeName -> Blaze.Builder
245177renderOid byName name
246178 = case Map.lookup (pg name) byName of
247− Nothing -> error (B8.unpack (pg name))
179+ Nothing -> error (B.unpack (pg name))
248180 Just (showOid . typoid -> n) -> fromString n
249181 ++ fromString (replicate (4 - length n) ' ')
250182
@@ -255,83 +187,13 @@ renderElem byOid elemOid
255187 Nothing -> error ("oid not found: " ++ show elemOid)
256188 Just x -> "Just " ++ bs (typname x)
257189
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−
328190-- FIXME: add in any names that we need that we didn't specify, (i.e.
329191-- the "unknowns" in getTypeInfos
330192-- and munge them into a valid haskell identifier if needed.
331193getNames :: NameMap -> TypeNames -> TypeNames
332194getNames _ x = x
333195
334−bs = Blaze.byteString
196+bs = Blaze.fromByteString
335197
336198pg = fst
337199
@@ -347,10 +209,6 @@ renderFile byOid byName names = ([longstring|
347209-- Maintainer: Leon P Smith <leon@melding-monads.com>
348210-- Stability: experimental
349211--
350−-- This module contains portions of the @pg_type@ table that are relevant
351−-- to postgresql-simple and are believed to not change between PostgreSQL
352−-- versions.
353−--
354212------------------------------------------------------------------------------
355213
356214-- Note that this file is generated by tools/GenTypeInfo.hs, and should
@@ -359,13 +217,20 @@ renderFile byOid byName names = ([longstring|
359217module Database.PostgreSQL.Simple.TypeInfo.Static
360218 ( TypeInfo(..)
361219 , staticTypeInfo
362−|] ++ concat [ " , " ++ bs (hs name) ++ "\n"
363− ++ " , " ++ bs (hs name) ++ "Oid\n"
220+|] ++ concat [ " , " ++ bs (hs name) ++ "\n"
364221 | name <- names ] ++ [longstring|
365222 ) where
366223
224+import Data.ByteString (ByteString)
367225import Database.PostgreSQL.LibPQ (Oid(..))
368−import Database.PostgreSQL.Simple.TypeInfo.Types
226+
227+data TypeInfo = TypeInfo
228+ { typoid :: {-# UNPACK #-} !Oid
229+ , typcategory :: {-# UNPACK #-} !Char
230+ , typdelim :: {-# UNPACK #-} !Char
231+ , typelem :: !(Maybe TypeInfo)
232+ , typname :: !ByteString
233+ }
369234
370235staticTypeInfo :: Oid -> Maybe TypeInfo
371236staticTypeInfo (Oid x) = case x of
@@ -376,6 +241,16 @@ staticTypeInfo (Oid x) = case x of
376241 ++ [longstring|
377242 _ -> Nothing
378243|]
379− ++ concat [ renderTypeInfo byOid typeInfo name
244+ ++ concat [concat
245+ [ "\n"
246+ , bs (hs name), " :: TypeInfo\n"
247+ , bs (hs name), " = TypeInfo {\n"
248+ , " typoid = ", fromString (show typoid), ",\n"
249+ , " typcategory = '", Blaze.fromChar typcategory, "',\n"
250+ , " typdelim = '", Blaze.fromChar typdelim, "',\n"
251+ , " typelem = ", renderElem byOid typelem, ",\n"
252+ , " typname = \"", bs typname, "\"\n"
253+ , " }\n"
254+ ]
380255 | name <- getNames byName names
381− , let (Just typeInfo) = Map.lookup (pg name) byName])
256+ , let (Just (TypeInfo{..})) = Map.lookup (pg name) byName])