96bdb9e...master · typeable/postgresql-simple

git.iko.soy/typeable/postgresql-simple

61 files changed+5720−1722

since splitsnapshots

unifiedsplit

.ghcideleted−2

@@ -1,2 +0,0 @@

1−:set -isrc

2−:set Wall

.github/workflows/haskell-ci.ymlnew file+256

@@ -0,0 +1,256 @@

1+# This GitHub workflow config has been generated by a script via

2+#

3+# haskell-ci 'github' 'cabal.project'

4+#

5+# To regenerate the script (for example after adjusting tested-with) run

6+#

7+# haskell-ci regenerate

8+#

9+# For more information, see https://github.com/haskell-CI/haskell-ci

10+#

11+# version: 0.17.20231110

12+#

13+# REGENDATA ("0.17.20231110",["github","cabal.project"])

14+#

15+name: Haskell-CI

16+on:

17+ push:

18+ branches:

19+ - master

20+ pull_request:

21+ branches:

22+ - master

23+jobs:

24+ linux:

25+ name: Haskell-CI - Linux - ${{ matrix.compiler }}

26+ runs-on: ubuntu-20.04

27+ timeout-minutes:

28+ 60

29+ container:

30+ image: buildpack-deps:bionic

31+ services:

32+ postgres:

33+ image: postgres:14

34+ env:

35+ POSTGRES_PASSWORD: postgres

36+ options: --health-cmd pg_isready --health-interval 10s --health-timeout 5s --health-retries 5

37+ continue-on-error: ${{ matrix.allow-failure }}

38+ strategy:

39+ matrix:

40+ include:

41+ - compiler: ghc-9.8.1

42+ compilerKind: ghc

43+ compilerVersion: 9.8.1

44+ setup-method: ghcup

45+ allow-failure: false

46+ - compiler: ghc-9.6.3

47+ compilerKind: ghc

48+ compilerVersion: 9.6.3

49+ setup-method: ghcup

50+ allow-failure: false

51+ - compiler: ghc-9.4.8

52+ compilerKind: ghc

53+ compilerVersion: 9.4.8

54+ setup-method: ghcup

55+ allow-failure: false

56+ - compiler: ghc-9.2.8

57+ compilerKind: ghc

58+ compilerVersion: 9.2.8

59+ setup-method: ghcup

60+ allow-failure: false

61+ - compiler: ghc-9.0.2

62+ compilerKind: ghc

63+ compilerVersion: 9.0.2

64+ setup-method: ghcup

65+ allow-failure: false

66+ - compiler: ghc-8.10.7

67+ compilerKind: ghc

68+ compilerVersion: 8.10.7

69+ setup-method: ghcup

70+ allow-failure: false

71+ - compiler: ghc-8.8.4

72+ compilerKind: ghc

73+ compilerVersion: 8.8.4

74+ setup-method: hvr-ppa

75+ allow-failure: false

76+ - compiler: ghc-8.6.5

77+ compilerKind: ghc

78+ compilerVersion: 8.6.5

79+ setup-method: hvr-ppa

80+ allow-failure: false

81+ fail-fast: false

82+ steps:

83+ - name: apt

84+ run: |

85+ apt-get update

86+ apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5

87+ if [ "${{ matrix.setup-method }}" = ghcup ]; then

88+ mkdir -p "$HOME/.ghcup/bin"

89+ curl -sL https://downloads.haskell.org/ghcup/0.1.20.0/x86_64-linux-ghcup-0.1.20.0 > "$HOME/.ghcup/bin/ghcup"

90+ chmod a+x "$HOME/.ghcup/bin/ghcup"

91+ "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false)

92+ "$HOME/.ghcup/bin/ghcup" install cabal 3.10.2.0 || (cat "$HOME"/.ghcup/logs/*.* && false)

93+ else

94+ apt-add-repository -y 'ppa:hvr/ghc'

95+ apt-get update

96+ apt-get install -y "$HCNAME"

97+ mkdir -p "$HOME/.ghcup/bin"

98+ curl -sL https://downloads.haskell.org/ghcup/0.1.20.0/x86_64-linux-ghcup-0.1.20.0 > "$HOME/.ghcup/bin/ghcup"

99+ chmod a+x "$HOME/.ghcup/bin/ghcup"

100+ "$HOME/.ghcup/bin/ghcup" install cabal 3.10.2.0 || (cat "$HOME"/.ghcup/logs/*.* && false)

101+ fi

102+ env:

103+ HCKIND: ${{ matrix.compilerKind }}

104+ HCNAME: ${{ matrix.compiler }}

105+ HCVER: ${{ matrix.compilerVersion }}

106+ - name: Set PATH and environment variables

107+ run: |

108+ echo "$HOME/.cabal/bin" >> $GITHUB_PATH

109+ echo "LANG=C.UTF-8" >> "$GITHUB_ENV"

110+ echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV"

111+ echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV"

112+ HCDIR=/opt/$HCKIND/$HCVER

113+ if [ "${{ matrix.setup-method }}" = ghcup ]; then

114+ HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER")

115+ HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#')

116+ HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#')

117+ echo "HC=$HC" >> "$GITHUB_ENV"

118+ echo "HCPKG=$HCPKG" >> "$GITHUB_ENV"

119+ echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV"

120+ echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.2.0 -vnormal+nowrap" >> "$GITHUB_ENV"

121+ else

122+ HC=$HCDIR/bin/$HCKIND

123+ echo "HC=$HC" >> "$GITHUB_ENV"

124+ echo "HCPKG=$HCDIR/bin/$HCKIND-pkg" >> "$GITHUB_ENV"

125+ echo "HADDOCK=$HCDIR/bin/haddock" >> "$GITHUB_ENV"

126+ echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.2.0 -vnormal+nowrap" >> "$GITHUB_ENV"

127+ fi

128+

129+ HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')

130+ echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV"

131+ echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV"

132+ echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV"

133+ echo "HEADHACKAGE=false" >> "$GITHUB_ENV"

134+ echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV"

135+ echo "GHCJSARITH=0" >> "$GITHUB_ENV"

136+ env:

137+ HCKIND: ${{ matrix.compilerKind }}

138+ HCNAME: ${{ matrix.compiler }}

139+ HCVER: ${{ matrix.compilerVersion }}

140+ - name: env

141+ run: |

142+ env

143+ - name: write cabal config

144+ run: |

145+ mkdir -p $CABAL_DIR

146+ cat >> $CABAL_CONFIG <<EOF

147+ remote-build-reporting: anonymous

148+ write-ghc-environment-files: never

149+ remote-repo-cache: $CABAL_DIR/packages

150+ logs-dir: $CABAL_DIR/logs

151+ world-file: $CABAL_DIR/world

152+ extra-prog-path: $CABAL_DIR/bin

153+ symlink-bindir: $CABAL_DIR/bin

154+ installdir: $CABAL_DIR/bin

155+ build-summary: $CABAL_DIR/logs/build.log

156+ store-dir: $CABAL_DIR/store

157+ install-dirs user

158+ prefix: $CABAL_DIR

159+ repository hackage.haskell.org

160+ url: http://hackage.haskell.org/

161+ EOF

162+ cat >> $CABAL_CONFIG <<EOF

163+ program-default-options

164+ ghc-options: $GHCJOBS +RTS -M3G -RTS

165+ EOF

166+ cat $CABAL_CONFIG

167+ - name: versions

168+ run: |

169+ $HC --version || true

170+ $HC --print-project-git-commit-id || true

171+ $CABAL --version || true

172+ - name: update cabal index

173+ run: |

174+ $CABAL v2-update -v

175+ - name: install cabal-plan

176+ run: |

177+ mkdir -p $HOME/.cabal/bin

178+ curl -sL https://github.com/haskell-hvr/cabal-plan/releases/download/v0.7.3.0/cabal-plan-0.7.3.0-x86_64-linux.xz > cabal-plan.xz

179+ echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c -

180+ xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan

181+ rm -f cabal-plan.xz

182+ chmod a+x $HOME/.cabal/bin/cabal-plan

183+ cabal-plan --version

184+ - name: checkout

185+ uses: actions/checkout@v3

186+ with:

187+ path: source

188+ - name: initial cabal.project for sdist

189+ run: |

190+ touch cabal.project

191+ echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project

192+ cat cabal.project

193+ - name: sdist

194+ run: |

195+ mkdir -p sdist

196+ $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist

197+ - name: unpack

198+ run: |

199+ mkdir -p unpacked

200+ find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \;

201+ - name: generate cabal.project

202+ run: |

203+ PKGDIR_postgresql_simple="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/postgresql-simple-[0-9.]*')"

204+ echo "PKGDIR_postgresql_simple=${PKGDIR_postgresql_simple}" >> "$GITHUB_ENV"

205+ rm -f cabal.project cabal.project.local

206+ touch cabal.project

207+ touch cabal.project.local

208+ echo "packages: ${PKGDIR_postgresql_simple}" >> cabal.project

209+ echo "package postgresql-simple" >> cabal.project

210+ echo " ghc-options: -Werror=missing-methods" >> cabal.project

211+ cat >> cabal.project <<EOF

212+ allow-newer: cryptohash-md5-0.11.100.1:base

213+ EOF

214+ $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: $_ installed\n" unless /^(postgresql-simple)$/; }' >> cabal.project.local

215+ cat cabal.project

216+ cat cabal.project.local

217+ - name: dump install plan

218+ run: |

219+ $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all

220+ cabal-plan

221+ - name: restore cache

222+ uses: actions/cache/restore@v3

223+ with:

224+ key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }}

225+ path: ~/.cabal/store

226+ restore-keys: ${{ runner.os }}-${{ matrix.compiler }}-

227+ - name: install dependencies

228+ run: |

229+ $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all

230+ $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all

231+ - name: build w/o tests

232+ run: |

233+ $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all

234+ - name: build

235+ run: |

236+ $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always

237+ - name: tests

238+ run: |

239+ $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct

240+ - name: cabal check

241+ run: |

242+ cd ${PKGDIR_postgresql_simple} || false

243+ ${CABAL} -vnormal check

244+ - name: haddock

245+ run: |

246+ $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all

247+ - name: unconstrained build

248+ run: |

249+ rm -f cabal.project.local

250+ $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all

251+ - name: save cache

252+ uses: actions/cache/save@v3

253+ if: always()

254+ with:

255+ key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }}

256+ path: ~/.cabal/store

.github/workflows/simple.ymlnew file+58

@@ -0,0 +1,58 @@

1+name: Simple

2+on:

3+ push:

4+ branches:

5+ - master

6+ pull_request:

7+ branches:

8+ - master

10+jobs:

11+ native:

12+ name: "Simple: GHC ${{ matrix.ghc }} on ${{ matrix.os }}"

13+ runs-on: ${{ matrix.os }}

14+ strategy:

15+ matrix:

16+ os: [macos-latest, windows-latest]

17+ ghc: ['8.10','9.0','9.2','9.4.8','9.6.3','9.8.1']

18+ fail-fast: false

19+ timeout-minutes:

20+ 60

21+ steps:

22+ - name: Set git to use LF

23+ run: |

24+ git config --global core.autocrlf false

25+ git config --global core.eol lf

26+

27+ - name: Set up Haskell

28+ id: setup-haskell

29+ uses: haskell/actions/setup@v2

30+ with:

31+ ghc-version: ${{ matrix.ghc }}

32+ cabal-version: '3.10.2.0'

33+

34+ - name: Set up PostgreSQL

35+ uses: ikalnytskyi/action-setup-postgres@v3

36+ id: postgres

37+ with:

38+ username: ci

39+ password: sw0rdfish

40+ database: test

41+

42+ - name: Checkout

43+ uses: actions/checkout@v3.0.2

44+

45+ - name: Cache

46+ uses: actions/cache@v2.1.3

47+ with:

48+ path: ${{ steps.setup-haskell.outputs.cabal-store }}

49+ key: ${{ runner.os }}-${{ matrix.ghc }}-${{ github.sha }}

50+ restore-keys: ${{ runner.os }}-${{ matrix.ghc }}-

51+

52+ - name: Build

53+ run: cabal build all --enable-tests

54+

55+ - name: Test

56+ run: cabal test all --enable-tests --test-show-details=direct

57+ env:

58+ DATABASE_CONNSTRING: ${{ steps.postgres.outputs.connection-uri }}

.gitignore+8−1

@@ -7,4 +7,11 @@ dist/

77*.o

88\#*\#

99.#*

10−postgresql-simple-*.tar.gz

10+/CHANGELOG.md

11+.cabal-sandbox/

12+.stack-work/

13+cabal.sandbox.config

14+/dist-newstyle

15+.ghc.environment.*

16+cabal.project.local

17+dump-core

CHANGES → CHANGES.mdrenamed+372−51

@@ -1,4 +1,325 @@

1−Version 0.4.7.0 (2014-10-27)

1+### Version 0.7.0.0 (2023-07-31)

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)

2323 * Added support for very old timestamps to UTCTime. Depending on time

3324 zone, very old timestamps can be returned with a offset from UTC that

4325 contains seconds.

@@ -18,24 +339,24 @@ Version 0.4.7.0 (2014-10-27)

18339

19340 Thanks to Michael Snoyman for his assistance with this issue.

20341

21−Version 0.4.6.0 (2014-10-07)

342+### Version 0.4.6.0 (2014-10-07)

22343 * Added an instance ToField NominalDiffTime.

23344

24−Version 0.4.5.0 (2014-09-26)

345+### Version 0.4.5.0 (2014-09-26)

25346 * Added support for retrieving NaN and ±Infinity floating point values

26347 from postgres to the FromField instances for Float, Double, and Rational.

27348 The instance for Scientific is unchanged due to the fact it has no

28349 way of representing these special values. Thanks goes to Tom Nielsen

29350 for reporting the issue.

30351

31−Version 0.4.4.1 (2014-09-07)

352+### Version 0.4.4.1 (2014-09-07)

32353 * Fixed a rather serious bug that prevented the COPY module from working

33354 at all on unix clients since version 0.4.3.0. Thanks goes to

34355 Dmitry Dzhus for reporting the issue.

35356

36357 * Added a regression test for the COPY module to the test suite.

37358

38−Version 0.4.4.0 (2014-08-26)

359+### Version 0.4.4.0 (2014-08-26)

39360 * Added the jsonb type debuting in PostgreSQL 9.4 to the TypeInfo.Static

40361 and Builtin tables, and extended the out-of-box json instances to

41362 be compatible with the new type. Thanks to Tobias Florek for the

@@ -44,7 +365,7 @@ Version 0.4.4.0 (2014-08-26)

44365 * Ported some expanded documentation from mysql-simple, and fixed

45366 a documentation typo.

46367

47−Version 0.4.3.0 (2014-07-10)

368+### Version 0.4.3.0 (2014-07-10)

48369 * connect and exec now use libpq asynchronously on non-Windows platforms.

49370 This means we are using threadWaitRead and threadWaitWrite to

50371 have GHC's IO manager schedule non-blocking C calls to libpq,

@@ -58,7 +379,7 @@ Version 0.4.3.0 (2014-07-10)

58379 that originate from client-side code. However, this goal

59380 isn't perfectly achieved as of yet.

60381

61−Version 0.4.2.3 (2014-06-04)

382+### Version 0.4.2.3 (2014-06-04)

62383 * This is strictly a documentation release, with no code changes.

63384

64385 * Fixed several documentation typos, thanks to Chris Allen and remdezx.

@@ -69,13 +390,13 @@ Version 0.4.2.3 (2014-06-04)

69390

70391 * De-emphasized connect and ConnectInfo in favor of connectPostgreSQL.

71392

72−Version 0.4.2.2 (2014-05-15)

73− * Fixed compatibility with scientific-0.3.*, thanks to Adam Bergmark

393+### Version 0.4.2.2 (2014-05-15)

394+ * Fixed compatibility with scientific-0.3.\*, thanks to Adam Bergmark

74395

75396 * Improved documentation of the FromField module, as well as the fold,

76397 foldWithOptions, executeMany, and returning operators.

77398

78−Version 0.4.2.1 (2014-03-27)

399+### Version 0.4.2.1 (2014-03-27)

79400 * Fixed bug in Values syntax generation

80401

81402 * Improved documentation, including examples of multi-row update,

@@ -83,17 +404,17 @@ Version 0.4.2.1 (2014-03-27)

83404 floating point numbers from the database, and the IsString instance

84405 for QualifiedIdentifier.

85406

86−Version 0.4.2.0 (2014-03-22)

407+### Version 0.4.2.0 (2014-03-22)

87408 * Added ToField and FromField instances for the scientific package

88409

89410 * Changed the Identifier and QualifiedIdentifier to use Text in

90411 order to avoid encoding errors. Technically this requires a

91− major verson bump, but let's pretend 0.4.1.0 didn't happen.

412+ major version bump, but let's pretend 0.4.1.0 didn't happen.

92413

93414 * Removed non-exhaustive cases in the ToField instance for Values,

94415 and tweaked error messages.

95416

96−Version 0.4.1.0 (2014-03-22)

417+### Version 0.4.1.0 (2014-03-22)

97418 * Fixed the parsing of arrays containing null values, courtesy of

98419 Francesco Mazzoli

99420

@@ -105,17 +426,17 @@ Version 0.4.1.0 (2014-03-22)

105426 more general than executeMany and returning. See the

106427 Database.PostgreSQL.Simple.Types.Values data type.

107428

108−Version 0.4.0.2 (2014-01-12)

429+### Version 0.4.0.2 (2014-01-12)

109430 * Tweaked C preprocessor directive to be more portable

110431

111432 * Tweaked testsuite for compatibility with aeson-0.7

112433

113−Version 0.4.0.1 (2013-12-21)

434+### Version 0.4.0.1 (2013-12-21)

114435 * Relaxed dependency on aeson to >= 0.6

115436

116437 * Update the documentation of `fromField`

117438

118−Version 0.4.0.0 (2013-12-21)

439+### Version 0.4.0.0 (2013-12-21)

119440 * Changed the calling code of `fromField` so that it always sends

120441 a copy of the raw data. This should be a small but significant

121442 performance bump for most people most of the time; however it

@@ -131,15 +452,15 @@ Version 0.4.0.0 (2013-12-21)

131452

132453 * Added FromField instances for IORef, MVar, and IOVector.

133454

134−Version 0.3.10.0 (2013-12-17)

455+### Version 0.3.10.0 (2013-12-17)

135456 * Added the queryWith function, courtesy of Leonid Onokhov

136457

137458 * Added the Default type, for representing postgresql's default values

138459

139−Version 0.3.9.1 (2013-10-28)

460+### Version 0.3.9.1 (2013-10-28)

140461 * Removed dependency on hashable

141462

142−Version 0.3.9.0 (2013-10-27)

463+### Version 0.3.9.0 (2013-10-27)

143464 * Added FromField and ToField instances for the `uuid` package,

144465 courtesy of Bas van Dijk.

145466

@@ -149,16 +470,16 @@ Version 0.3.9.0 (2013-10-27)

149470 * Added the fromBinary, fromHStoreMap, and fromHStoreList newtype

150471 unwrapper functions, courtesy of Bas van Dijk.

151472

152−Version 0.3.8.0 (2013-10-11)

473+### Version 0.3.8.0 (2013-10-11)

153474 * Fixed the example code in `FromField`, thanks to Adam Bergmark.

154475

155476 * Added `Notification.getBackendPID`.

156477

157−Version 0.3.7.1 (2013-09-12)

478+### Version 0.3.7.1 (2013-09-12)

158479 * Relaxed the dependency on bytestring-0.10 back to bytestring-0.9,

159480 courtesy of Michael Snoyman

160481

161−Version 0.3.7.0 (2013-09-11)

482+### Version 0.3.7.0 (2013-09-11)

162483 * Added `aeson` as a dependency.

163484

164485 * Added ToField and FromField instances for aeson's JSON.Value type,

@@ -179,7 +500,7 @@ Version 0.3.7.0 (2013-09-11)

179500

180501 * Various documentation fixes.

181502

182−Version 0.3.6.0 (2013-08-19)

503+### Version 0.3.6.0 (2013-08-19)

183504 * Added the json type to BuiltinTypes and TypeInfo.Static, courtesy of

184505 Manuel Gómez.

185506

@@ -190,14 +511,14 @@ Version 0.3.6.0 (2013-08-19)

190511 months from now. Fixed the example code in FromField to reflect

191512 this change.

192513

193−Version 0.3.5.0 (2013-08-09)

514+### Version 0.3.5.0 (2013-08-09)

194515 * Added an FromRow instance for Vector, semantically identical to the

195516 existing FromRow instance for [], courtesy of Doug Beardsley

196517

197518 * Reworked the documentation for the Copy module, and tweaked the

198519 documentation for the LargeObjects module.

199520

200−Version 0.3.4.0 (2013-07-23)

521+### Version 0.3.4.0 (2013-07-23)

201522 * Added direct support for COPY IN and COPY OUT, without having

202523 to use raw postgresql-libpq calls and postgresql-simple's Internal

203524 module.

@@ -206,49 +527,49 @@ Version 0.3.4.0 (2013-07-23)

206527 exception instead of an ErrorCall exception when it fails to fetch

207528 the connection's file descriptor from libpq.

208529

209−Version 0.3.3.2 (2013-06-18)

530+### Version 0.3.3.2 (2013-06-18)

210531 * Optimized the definition of `mconcat` in the Monoid instance for

211532 the Query type, courtesy of Joey Adams.

212533

213−Version 0.3.3.1 (2013-06-06)

534+### Version 0.3.3.1 (2013-06-06)

214535 * `getNotification` now works on Windows, albeit using a one-second

215536 polling loop, courtesy of Joey Adams.

216537

217−Version 0.3.3.0 (2013-05-29)

538+### Version 0.3.3.0 (2013-05-29)

218539 * Fixed two issues with the fold operator: fold would raise the wrong

219540 exception, and gave the database cursor a static name preventing

220541 folds from being nested. Thanks to Joey Adams for his

221542 work on these issues.

222543

223−Version 0.3.2.0 (2013-05-20)

544+### Version 0.3.2.0 (2013-05-20)

224545 * Added a savepoint abstraction to the Transaction module, courtesy

225546 of Joey Adams

226547

227−Version 0.3.1.2 (2013-04-29)

548+### Version 0.3.1.2 (2013-04-29)

228549 * Fixed hstore parser to not unnecessarily reverse the key-value pairs

229550

230−Version 0.3.1.1 (2013-04-29)

551+### Version 0.3.1.1 (2013-04-29)

231552 * Fixed hstore parser to recognize empty hstores, courtesy of Simon

232553 Meier

233554

234−Version 0.3.1.0 (2013-04-26)

555+### Version 0.3.1.0 (2013-04-26)

235556 * Added support for Range and Composite types to the TypeInfo system.

236557

237558 * Added support for hstore types in the Simple.HStore module.

238559

239560 * Improved documentation of the FromField module.

240561

241−Version 0.3.0.1 (2013-03-26)

562+### Version 0.3.0.1 (2013-03-26)

242563 * A large chunk of the documentation inside the FromField module had

243564 silently failed to render in Haddock.

244565

245−Version 0.3.0.0 (2013-03-25)

566+### Version 0.3.0.0 (2013-03-25)

246567 * Added support for PostgreSQL's Array Types. Thanks to Jason Dusek

247568 for his work on this feature.

248569

249570 * Added a brand new TypeInfo system that gives FromField instances

250571 convenient and efficient access to the pg_type metatable. This

251− replaced the older typename cache, and was neccesary to properly

572+ replaced the older typename cache, and was necessary to properly

252573 support postgres array types. Thanks to Bas van Dijk for his

253574 work on this feature.

254575

@@ -284,33 +605,33 @@ Version 0.3.0.0 (2013-03-25)

284605 now stripped out.

285606

286607

287−Version 0.2.4.1 (2012-08-29)

608+### Version 0.2.4.1 (2012-08-29)

288609 * Fixed the documentation of `In`. Thanks to rekado and dstcruz for

289610 pointing this out.

290611

291−Version 0.2.4.0 (2012-08-23)

612+### Version 0.2.4.0 (2012-08-23)

292613 * Added the `withTransactionSerializable` and `withTransactionModeRetry`

293614 operators, thanks to Joey Adams.

294615

295−Version 0.2.3.0 (2012-08-09)

616+### Version 0.2.3.0 (2012-08-09)

296617 * Added the `returning` operator, thanks to Jason Dusek

297618

298−Version 0.2.2.0 (2012-07-26)

619+### Version 0.2.2.0 (2012-07-26)

299620 * Added a ToRow instance for the (:.) type, courtesy of Leonid Onokhov

300621

301622 * Added the type oid for PostgreSQL's `uuid` type to BuiltinTypes

302623

303−Version 0.2.1.0 (2012-07-23)

624+### Version 0.2.1.0 (2012-07-23)

304625 * Added the FromRow.fieldWith operator, thanks to Leonid Onokhov

305626

306627 * Added a type synonym for FieldParser

307628

308−Version 0.2.0.1 (2012-06-21)

629+### Version 0.2.0.1 (2012-06-21)

309630 * Fixed a compatibility problem with PostgreSQL 8.1, which does not allow

310631 clients to set their own value for `standard_conforming_strings`. This

311632 connection variable is still set to `on` for PostgreSQL 8.2 and later.

312633

313−Version 0.2: (2012-06-19)

634+### Version 0.2: (2012-06-19)

314635 * Removed the conversion from `timestamp` to `UTCTime`. Some code will be

315636 broken even though it will still compile.

316637

@@ -319,16 +640,16 @@ Version 0.2: (2012-06-19)

319640 * Exported ToRow/FromRow from Database.PostgreSQL.Simple

320641

321642

322−Version 0.1.4.3: (2012-06-10)

643+### Version 0.1.4.3: (2012-06-10)

323644 * Fix language extensions for compatibility with GHC 7.0

324645

325−Version 0.1.4.2: (2012-06-10)

646+### Version 0.1.4.2: (2012-06-10)

326647 * Fix a wayward dependency on Text.

327648

328−Version 0.1.4.1: (2012-06-10)

649+### Version 0.1.4.1: (2012-06-10)

329650 * Added support for timezones with minutes in their UTC offset.

330651

331−Version 0.1.4: (2012-06-10)

652+### Version 0.1.4: (2012-06-10)

332653 * Removed pcre-light dependency, courtesy of Joey Adams.

333654

334655 * Reworked support for the Time types.

@@ -340,7 +661,7 @@ Version 0.1.4: (2012-06-10)

340661 now the preferred way of dealing with `timestamp` (without time zone).

341662

342663 * `Database.PostgreSQL.Simple.Time` is a new module that offers types

343− that accomodate PostgreSQL's infinities.

664+ that accommodate PostgreSQL's infinities.

344665

345666 * All time-related `FromField`/`ToField` instances are now based on new,

346667 higher-speed parsers and printers instead of those provided by the

@@ -353,13 +674,13 @@ Version 0.1.4: (2012-06-10)

353674 * Renaming some of the type names in `BuiltinTypes`.

354675

355676

356−Version 0.1.3: (2012-05-30)

677+### Version 0.1.3: (2012-05-30)

357678 * Made ZonedTime an instance of FromField and ToField

358679

359680 * Added getNotificationNonBlocking

360681

361682

362−Version 0.1.2: (2012-05-09)

683+### Version 0.1.2: (2012-05-09)

363684 * Switched to libpq-based escaping for bytea types; Binary now works with

364685 PostgreSQL 8 courtesy of Joey Adams.

365686

@@ -372,7 +693,7 @@ Version 0.1.2: (2012-05-09)

372693 * Exported (:.) from Database.PostgreSQL.Simple

373694

374695

375−Version 0.1.1: (2012-05-06)

696+### Version 0.1.1: (2012-05-06)

376697 * Added some preliminary documentation for the Ok, Notification, and

377698 LargeObjects modules

378699

@@ -381,7 +702,7 @@ Version 0.1.1: (2012-05-06)

381702 * Fixed a bug relating to handling the transaction level

382703

383704

384−Version 0.1: (2012-05-04)

705+### Version 0.1: (2012-05-04)

385706 * Renamed several modules, typeclasses, and functions:

386707

387708 QueryParams (renderParams) -> ToRow (toRow)

CONTRIBUTING.mdnew file+13

@@ -0,0 +1,13 @@

1+Patches welcome!

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))

9+- Don't edit `CHANGELOG.md`, rather include a copyable entry in your pull request description. I often process pull requests in bulk, and everyone editing the `CHANGELOG.md` causes unnecessary conflicts.

10+- For the same reason, do not edit `version` or `x-revision`

11+

12+- I use [`stylish-haskell`](https://github.com/jaspervdj/stylish-haskell) to format imports. I encourage you to use it too, when contributing.

13+- General code style is 4 spaces, just look around how it looks, it's not so strict.

CONTRIBUTORS+16

@@ -18,3 +18,19 @@ Adam Bergmark <adam@edea.se>

1818Tobias Florek <tob@butter.sh>

1919Francesco Mazzoli <francesco.mazzoli@erudify.com>

2020Chris Allen <cma@bitemyapp.com>

21+Simon Hengel <sol@typeful.net>

22+Tom Ellis <tom-2013@purelyagile.com>

23+Mike Ledger <mike@quasimal.com>

24+João Cristóvão <jmacristovao@gmail.com>

25+Bardur Arantsson <bardur@scientician.net>

26+Travis Staton <hello@travisstaton.com>

27+Sam Rijs <srijs@airpost.net>

28+Janne Hellsten <jjhellst@gmail.com>

29+Timmy Tofu <timmytofu@users.noreply.github.com>

30+Alexey Khudyakov <alexey.skladnoy@gmail.com>

31+Timo von Holtz <tvh@anchor.com.au>

32+Amit Levy <amit@amitlevy.com>

33+Ben Gamari <ben@smart-cactus.org>

34+Edgar Gomes Araujo <talktoedgar@gmail.com>

35+Erik Hesselink <hesselink@gmail.com>

36+Matvey Aksenov <matvey.aksenov@gmail.com>

README.mdnew file+4

@@ -0,0 +1,4 @@

1+[![Hackage page (downloads and API reference)][hackage-png]][hackage]

3+ [hackage-png]: http://img.shields.io/hackage/v/postgresql-simple.svg

4+ [hackage]: http://hackage.haskell.org/package/postgresql-simple

bench/Select.hsnew file+32

@@ -0,0 +1,32 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+module Main where

4+import Database.PostgreSQL.Simple

5+import qualified Database.PostgreSQL.Simple.Vector as V

6+import qualified Database.PostgreSQL.Simple.Vector.Unboxed as VU

8+import System.Environment (getArgs)

9+import Data.Foldable (Foldable, foldl')

10+import qualified Data.Vector.Unboxed as VU

11+

12+main :: IO ()

13+main = do

14+ args <- getArgs

15+ conn <- connectPostgreSQL ""

16+ case args of

17+ ("vector":_) -> do

18+ result <- V.query_ conn "SELECT * FROM generate_series(1, 10000000);"

19+ print (process result)

20+ ("unboxed":_) -> do

21+ -- dummy column

22+ result <- VU.query_ conn "SELECT (NULL :: VOID), * FROM generate_series(1, 10000000);"

23+ print (process' result)

24+ _ -> do

25+ result <- query_ conn "SELECT * FROM generate_series(1, 10000000);"

26+ print (process result)

27+

28+process :: Foldable f => f (Only Int) -> Int

29+process = foldl' (\x (Only y) -> max x y) 0

30+

31+process' :: VU.Vector ((), Int) -> Int

32+process' = VU.foldl' (\x (_, y) -> max x y) 0

cabal.haskell-cinew file+5

@@ -0,0 +1,5 @@

1+branches: master

2+postgresql: True

4+-- services aren't supported on Travis on macOS

5+-- osx: 8.4.4

cabal.projectnew file+4

@@ -0,0 +1,4 @@

1+packages: .

2+tests: true

4+allow-newer: cryptohash-md5-0.11.100.1:base

cabal.project.local.winnew file+4

@@ -0,0 +1,4 @@

1+constraints: these -assoc

3+package postgresql-libpq

4+ flags: -use-pkg-config

postgresql-simple.cabal+153−94

@@ -1,116 +1,175 @@

1−Name: postgresql-simple

2−Version: 0.4.7.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>

12−Category: Database

13−Build-type: Simple

1+cabal-version: 1.12

2+name: postgresql-simple

3+version: 0.7.0.0

4+x-revision: 1

5+synopsis: Mid-Level PostgreSQL client library

6+description:

7+ Mid-Level PostgreSQL client library, forked from mysql-simple.

148

15−Cabal-version: >= 1.9.2

9+license: BSD3

10+license-file: LICENSE

11+author: Bryan O'Sullivan, Leon P Smith

12+maintainer: Oleg Grenrus <oleg.grenrus@iki.fi>

13+copyright:

1617

18+category: Database

19+build-type: Simple

1720extra-source-files:

18− CONTRIBUTORS

21+ CHANGES.md

22+ CONTRIBUTORS

23+ test/results/malformed-input.expected

24+ test/results/unique-constraint-violation.expected

1925

20−Library

21− hs-source-dirs: src

22− Exposed-modules:

23− Database.PostgreSQL.Simple

24− Database.PostgreSQL.Simple.Arrays

25− Database.PostgreSQL.Simple.BuiltinTypes

26− Database.PostgreSQL.Simple.Copy

27− Database.PostgreSQL.Simple.FromField

28− Database.PostgreSQL.Simple.FromRow

29− Database.PostgreSQL.Simple.LargeObjects

30− Database.PostgreSQL.Simple.HStore

31− Database.PostgreSQL.Simple.HStore.Internal

32− Database.PostgreSQL.Simple.Notification

33− Database.PostgreSQL.Simple.Ok

34− Database.PostgreSQL.Simple.SqlQQ

35− Database.PostgreSQL.Simple.Time

36− Database.PostgreSQL.Simple.Time.Internal

37− Database.PostgreSQL.Simple.ToField

38− Database.PostgreSQL.Simple.ToRow

39− Database.PostgreSQL.Simple.Transaction

40− Database.PostgreSQL.Simple.TypeInfo

41− Database.PostgreSQL.Simple.TypeInfo.Macro

42− Database.PostgreSQL.Simple.TypeInfo.Static

43− Database.PostgreSQL.Simple.Types

44− Database.PostgreSQL.Simple.Errors

45−-- Other-modules:

46− Database.PostgreSQL.Simple.Internal

26+tested-with:

27+ GHC ==8.6.5

28+ || ==8.8.4

29+ || ==8.10.7

30+ || ==9.0.2

31+ || ==9.2.8

32+ || ==9.4.8

33+ || ==9.6.3

34+ || ==9.8.1

4735

48− Other-modules:

49− Database.PostgreSQL.Simple.Compat

50− Database.PostgreSQL.Simple.HStore.Implementation

51− Database.PostgreSQL.Simple.Time.Implementation

52− Database.PostgreSQL.Simple.TypeInfo.Types

36+library

37+ default-language: Haskell2010

38+ hs-source-dirs: src

39+ exposed-modules:

40+ Database.PostgreSQL.Simple

41+ Database.PostgreSQL.Simple.Arrays

42+ Database.PostgreSQL.Simple.Copy

43+ Database.PostgreSQL.Simple.Cursor

44+ Database.PostgreSQL.Simple.Errors

45+ Database.PostgreSQL.Simple.FromField

46+ Database.PostgreSQL.Simple.FromRow

47+ Database.PostgreSQL.Simple.HStore

48+ Database.PostgreSQL.Simple.HStore.Internal

49+ Database.PostgreSQL.Simple.Internal

50+ Database.PostgreSQL.Simple.LargeObjects

51+ Database.PostgreSQL.Simple.Newtypes

52+ Database.PostgreSQL.Simple.Notification

53+ Database.PostgreSQL.Simple.Ok

54+ Database.PostgreSQL.Simple.Range

55+ Database.PostgreSQL.Simple.SqlQQ

56+ Database.PostgreSQL.Simple.Time

57+ Database.PostgreSQL.Simple.Time.Internal

58+ Database.PostgreSQL.Simple.ToField

59+ Database.PostgreSQL.Simple.ToRow

60+ Database.PostgreSQL.Simple.Transaction

61+ Database.PostgreSQL.Simple.TypeInfo

62+ Database.PostgreSQL.Simple.TypeInfo.Macro

63+ Database.PostgreSQL.Simple.TypeInfo.Static

64+ Database.PostgreSQL.Simple.Types

65+ Database.PostgreSQL.Simple.Vector

66+ Database.PostgreSQL.Simple.Vector.Unboxed

5367

54− Build-depends:

55− aeson >= 0.6,

56− attoparsec >= 0.10.3,

57− base < 5,

58− blaze-builder,

59− blaze-textual,

60− bytestring >= 0.9,

61− containers,

62− hashable,

63− postgresql-libpq >= 0.9,

64− template-haskell,

65− text >= 0.11.1,

66− time,

67− transformers,

68− uuid >= 1.3.1,

69− scientific,

70− vector

68+ -- Other-modules:

69+ other-modules:

70+ Database.PostgreSQL.Simple.Compat

71+ Database.PostgreSQL.Simple.HStore.Implementation

72+ Database.PostgreSQL.Simple.Internal.PQResultUtils

73+ Database.PostgreSQL.Simple.Time.Implementation

74+ Database.PostgreSQL.Simple.Time.Internal.Parser

75+ Database.PostgreSQL.Simple.Time.Internal.Printer

76+ Database.PostgreSQL.Simple.TypeInfo.Types

77+

78+ -- GHC bundled libs

79+ build-depends:

80+ base >=4.12.0.0 && <4.20

81+ , bytestring >=0.10.8.2 && <0.13

82+ , containers >=0.6.0.1 && <0.7

83+ , template-haskell >=2.14.0.0 && <2.22

84+ , text >=1.2.3.0 && <1.3 || >=2.0 && <2.2

85+ , time-compat >=1.9.5 && <1.12

86+ , transformers >=0.5.6.2 && <0.7

87+

88+ -- Other dependencies

89+ build-depends:

90+ aeson >=2.1.2.1 && <2.3

91+ , attoparsec >=0.14.4 && <0.15

92+ , case-insensitive >=1.2.1.0 && <1.3

93+ , hashable >=1.4.3.0 && <1.5

94+ , Only >=0.1 && <0.1.1

95+ , postgresql-libpq >=0.10.0.0 && <0.11

96+ , scientific >=0.3.7.0 && <0.4

97+ , uuid-types >=1.0.5 && <1.1

98+ , vector >=0.13.0.0 && <0.14

7199

72− extensions: DoAndIfThenElse, OverloadedStrings, BangPatterns, ViewPatterns

73− TypeOperators

100+ default-extensions:

101+ BangPatterns

102+ DoAndIfThenElse

103+ OverloadedStrings

104+ TypeOperators

105+ ViewPatterns

74106

75− ghc-options: -Wall -fno-warn-name-shadowing

107+ ghc-options: -Wall -fno-warn-name-shadowing

76108

77109source-repository head

78110 type: git

79− location: http://github.com/lpsmith/postgresql-simple

111+ location: http://github.com/haskellari/postgresql-simple

80112

81−source-repository this

82− type: git

83− location: http://github.com/lpsmith/postgresql-simple

84− tag: v0.4.7.0

113+test-suite inspection

114+ default-language: Haskell2010

115+ type: exitcode-stdio-1.0

116+ hs-source-dirs: test

117+ main-is: Inspection.hs

118+ build-depends:

119+ base

120+ , inspection-testing >=0.4.1.1 && <0.6

121+ , postgresql-libpq

122+ , postgresql-simple

123+ , tasty

124+ , tasty-hunit

85125

86126test-suite test

87− type: exitcode-stdio-1.0

88−

89− hs-source-dirs: test

90− main-is: Main.hs

127+ default-language: Haskell2010

128+ type: exitcode-stdio-1.0

129+ hs-source-dirs: test

130+ main-is: Main.hs

91131 other-modules:

92132 Common

133+ Exception

134+ Interval

93135 Notify

94136 Serializable

95137 Time

96138

97− ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind

139+ ghc-options: -threaded

140+ ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind

141+ default-extensions:

142+ NamedFieldPuns

143+ OverloadedStrings

144+ PatternGuards

145+ Rank2Types

146+ RecordWildCards

147+ ScopedTypeVariables

98148

99− extensions: NamedFieldPuns

100− , OverloadedStrings

101− , Rank2Types

102− , RecordWildCards

103− , PatternGuards

104− , ScopedTypeVariables

149+ build-depends:

150+ aeson

151+ , base

152+ , base16-bytestring

153+ , bytestring

154+ , case-insensitive

155+ , containers

156+ , cryptohash-md5 >=0.11.100.1 && <0.12

157+ , filepath

158+ , HUnit

159+ , postgresql-simple

160+ , tasty

161+ , tasty-golden

162+ , tasty-hunit

163+ , text

164+ , time-compat

165+ , vector

105166

106− build-depends: base

107− , aeson

108− , base16-bytestring

109− , bytestring

110− , containers

111− , cryptohash

112− , HUnit

113− , postgresql-simple

114− , text

115− , time

116− , vector

167+benchmark select

168+ default-language: Haskell2010

169+ type: exitcode-stdio-1.0

170+ hs-source-dirs: bench

171+ main-is: Select.hs

172+ build-depends:

173+ base

174+ , postgresql-simple

175+ , vector

sdist.shnew file+25

@@ -0,0 +1,25 @@

1+#!/bin/bash

3+echo "Generating CHANGELOG.md"

4+echo

6+cat <<HEADER > CHANGELOG.md

7+For the full changelog, see

8+<https://github.com/lpsmith/postgresql-simple/blob/master/CHANGES.md>

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+135−174

@@ -42,7 +42,7 @@ module Database.PostgreSQL.Simple

4242 -- ** Modifying multiple rows at once

4343 -- $many

4444

45− -- ** @RETURNING@: modifications that returns results

45+ -- ** @RETURNING@: modifications that return results

4646 -- $returning

4747

4848 -- * Extracting results

@@ -64,15 +64,17 @@ module Database.PostgreSQL.Simple

6464 , Only(..)

6565 , (:.)(..)

6666 -- ** Exceptions

67+ , SomePostgreSqlException(..)

6768 , SqlError(..)

6869 , PQ.ExecStatus(..)

69− , FormatError(fmtMessage, fmtQuery, fmtParams)

70− , QueryError(qeMessage, qeQuery)

71− , ResultError(errSQLType, errHaskellType, errMessage)

70+ , FormatError(..)

71+ , QueryError(..)

72+ , ResultError(..)

7273 -- * Connection management

7374 , Base.connectPostgreSQL

7475 , Base.close

7576 , Base.connect

77+ , Base.withConnect

7678 , Base.ConnectInfo(..)

7779 , Base.defaultConnectInfo

7880 , Base.postgreSQLConnectionString

@@ -93,6 +95,14 @@ module Database.PostgreSQL.Simple

9395 , forEach

9496 , forEach_

9597 , returning

98+ -- ** Queries that stream results taking a parser as an argument

99+ , foldWith

100+ , foldWithOptionsAndParser

101+ , foldWith_

102+ , foldWithOptionsAndParser_

103+ , forEachWith

104+ , forEachWith_

105+ , returningWith

96106 -- * Statements that do not return results

97107 , execute

98108 , execute_

@@ -110,46 +120,27 @@ module Database.PostgreSQL.Simple

110120 , formatQuery

111121 ) where

112122

113−import Blaze.ByteString.Builder

114− ( Builder, fromByteString, toByteString )

115−import Blaze.ByteString.Builder.Char8 (fromChar)

116−import Blaze.Text ( integral )

117−import Control.Applicative ((<$>), pure)

123+import Data.ByteString.Builder (Builder, byteString, char8)

124+import Control.Applicative ((<$>))

118125import Control.Exception as E

119−import Control.Monad (foldM)

120126import Data.ByteString (ByteString)

121127import Data.Int (Int64)

122128import Data.List (intersperse)

123129import Data.Monoid (mconcat)

124−import Data.Typeable (Typeable)

125−import Database.PostgreSQL.Simple.Compat ( (<>) )

130+import Database.PostgreSQL.Simple.Compat ((<>), toByteString)

131+import Database.PostgreSQL.Simple.Cursor

126132import Database.PostgreSQL.Simple.FromField (ResultError(..))

127133import Database.PostgreSQL.Simple.FromRow (FromRow(..))

128−import Database.PostgreSQL.Simple.Ok

129−import Database.PostgreSQL.Simple.ToField (Action(..), inQuotes)

134+import Database.PostgreSQL.Simple.ToField (Action(..))

130135import Database.PostgreSQL.Simple.ToRow (ToRow(..))

131136import Database.PostgreSQL.Simple.Types

132137 ( Binary(..), In(..), Only(..), Query(..), (:.)(..) )

133138import Database.PostgreSQL.Simple.Internal as Base

139+import Database.PostgreSQL.Simple.Internal.PQResultUtils

134140import Database.PostgreSQL.Simple.Transaction

135−import Database.PostgreSQL.Simple.TypeInfo

136141import qualified Database.PostgreSQL.LibPQ as PQ

137142import qualified Data.ByteString.Char8 as B

138−import qualified Data.Text as T

139−import qualified Data.Text.Encoding as TE

140−import Control.Monad.Trans.Reader

141−import Control.Monad.Trans.State.Strict

142−

143−-- | Exception thrown if a 'Query' could not be formatted correctly.

144−-- This may occur if the number of \'@?@\' characters in the query

145−-- string does not match the number of parameters provided.

146−data FormatError = FormatError {

147− fmtMessage :: String

148− , fmtQuery :: Query

149− , fmtParams :: [ByteString]

150− } deriving (Eq, Show, Typeable)

151−

152−instance Exception FormatError

143+

153144

154145-- | Format a query string.

155146--

@@ -186,9 +177,9 @@ formatMany conn q@(Query template) qs = do

186177 case parseTemplate template of

187178 Just (before, qbits, after) -> do

188179 bs <- mapM (buildQuery conn q qbits . toRow) qs

189− return . toByteString . mconcat $ fromByteString before :

190− intersperse (fromChar ',') bs ++

191− [fromByteString after]

180+ return . toByteString . mconcat $ byteString before :

181+ intersperse (char8 ',') bs ++

182+ [byteString after]

192183 Nothing -> fmtError "syntax error in multi-row template" q []

193184

194185-- Split the input string into three pieces, @before@, @qbits@, and @after@,

@@ -286,45 +277,32 @@ parseTemplate template =

286277

287278 skipSpace = B.dropWhile isSpace_ascii

288279

289−escapeStringConn :: Connection -> ByteString -> IO (Either ByteString ByteString)

290−escapeStringConn = escapeWrap PQ.escapeStringConn

291−

292−escapeIdentifier :: Connection -> ByteString -> IO (Either ByteString ByteString)

293−escapeIdentifier = escapeWrap PQ.escapeIdentifier

294−

295−escapeByteaConn :: Connection -> ByteString -> IO (Either ByteString ByteString)

296−escapeByteaConn = escapeWrap PQ.escapeByteaConn

297−

298−escapeWrap :: (PQ.Connection -> ByteString -> IO (Maybe ByteString))

299− -> Connection

300− -> ByteString

301− -> IO (Either ByteString ByteString)

302−escapeWrap f conn s =

303− withConnection conn $ \c ->

304− f c s >>= checkError c

305−

306−checkError :: PQ.Connection -> Maybe a -> IO (Either ByteString a)

307−checkError _ (Just x) = return $ Right x

308−checkError c Nothing = Left . maybe "" id <$> PQ.errorMessage c

309280

310281buildQuery :: Connection -> Query -> ByteString -> [Action] -> IO Builder

311−buildQuery conn q template xs = zipParams (split template) <$> mapM sub xs

312− where err' msg = fmtError (utf8ToString msg) q xs

313− quote = either err' (inQuotes . fromByteString)

314− utf8ToString = T.unpack . TE.decodeUtf8

315− sub (Plain b) = pure b

316− sub (Escape s) = quote <$> escapeStringConn conn s

317− sub (EscapeByteA s) = quote <$> escapeByteaConn conn s

318− sub (EscapeIdentifier s) = either err' fromByteString <$>

319− escapeIdentifier conn s

320− sub (Many ys) = mconcat <$> mapM sub ys

321− split s = fromByteString h : if B.null t then [] else split (B.tail t)

322− where (h,t) = B.break (=='?') s

282+buildQuery conn q template xs =

283+ zipParams (split template) <$> mapM (buildAction conn q xs) xs

284+ where split s =

285+ -- This part escapes double '??'s to make literal '?'s possible

286+ -- in PostgreSQL queries using the JSON operators: @?@, @?|@ and @?&@

287+ let (h,t) = breakOnSingleQuestionMark s

288+ in byteString h

289+ : if B.null t

290+ then []

291+ else split (B.tail t)

323292 zipParams (t:ts) (p:ps) = t <> p <> zipParams ts ps

324293 zipParams [t] [] = t

325− zipParams _ _ = fmtError (show (B.count '?' template) ++

326− " '?' characters, but " ++

294+ zipParams _ _ = fmtError (show countSingleQs ++

295+ " single '?' characters, but " ++

327296 show (length xs) ++ " parameters") q xs

297+ countSingleQs = go 0 template

298+ where go i "" = (i :: Int)

299+ go i bs = case qms of

300+ ("?","?") -> go i nextQMBS

301+ ("?",_) -> go (i+1) nextQMBS

302+ _ -> i

303+ where qms = B.splitAt 1 qmBS

304+ (qmBS,nextQMBS) = B.splitAt 2 qmBS'

305+ qmBS' = B.dropWhile (/= '?') bs

328306

329307-- | Execute an @INSERT@, @UPDATE@, or other SQL query that is not

330308-- expected to return results.

@@ -362,10 +340,10 @@ execute conn template qs = do

362340-- @

363341-- executeMany c [sql|

364342-- UPDATE sometable

365−-- SET sometable.y = upd.y

343+-- SET y = upd.y

366344-- FROM (VALUES (?,?)) as upd(x,y)

367345-- WHERE sometable.x = upd.x

368−-- |] [(1, \"hello\"),(2, \"world\")

346+-- |] [(1, \"hello\"),(2, \"world\")]

369347-- @

370348

371349executeMany :: (ToRow q) => Connection -> Query -> [q] -> IO Int64

@@ -387,10 +365,14 @@ executeMany conn q qs = do

387365--

388366-- Throws 'FormatError' if the query could not be formatted correctly.

389367returning :: (ToRow q, FromRow r) => Connection -> Query -> [q] -> IO [r]

390−returning _ _ [] = return []

391−returning conn q qs = do

368+returning = returningWith fromRow

369+

370+-- | A version of 'returning' taking parser as argument

371+returningWith :: (ToRow q) => RowParser r -> Connection -> Query -> [q] -> IO [r]

372+returningWith _ _ _ [] = return []

373+returningWith parser conn q qs = do

392374 result <- exec conn =<< formatMany conn q qs

393− finishQuery conn q result

375+ finishQueryWith parser conn q result

394376

395377-- | Perform a @SELECT@ or other SQL query that is expected to return

396378-- results. All results are retrieved and converted before this

@@ -465,6 +447,17 @@ fold :: ( FromRow row, ToRow params )

465447 -> IO a

466448fold = foldWithOptions defaultFoldOptions

467449

450+-- | A version of 'fold' taking a parser as an argument

451+foldWith :: ( ToRow params )

452+ => RowParser row

453+ -> Connection

454+ -> Query

455+ -> params

456+ -> a

457+ -> (a -> row -> IO a)

458+ -> IO a

459+foldWith = foldWithOptionsAndParser defaultFoldOptions

460+

468461-- | Number of rows to fetch at a time. 'Automatic' currently defaults

469462-- to 256 rows, although it might be nice to make this more intelligent

470463-- based on e.g. the average size of the rows.

@@ -499,9 +492,21 @@ foldWithOptions :: ( FromRow row, ToRow params )

499492 -> a

500493 -> (a -> row -> IO a)

501494 -> IO a

502−foldWithOptions opts conn template qs a f = do

495+foldWithOptions opts = foldWithOptionsAndParser opts fromRow

496+

497+-- | A version of 'foldWithOptions' taking a parser as an argument

498+foldWithOptionsAndParser :: (ToRow params)

499+ => FoldOptions

500+ -> RowParser row

501+ -> Connection

502+ -> Query

503+ -> params

504+ -> a

505+ -> (a -> row -> IO a)

506+ -> IO a

507+foldWithOptionsAndParser opts parser conn template qs a f = do

503508 q <- formatQuery conn template qs

504− doFold opts conn template (Query q) a f

509+ doFold opts parser conn template (Query q) a f

505510

506511-- | A version of 'fold' that does not perform query substitution.

507512fold_ :: (FromRow r) =>

@@ -512,6 +517,14 @@ fold_ :: (FromRow r) =>

512517 -> IO a

513518fold_ = foldWithOptions_ defaultFoldOptions

514519

520+-- | A version of 'fold_' taking a parser as an argument

521+foldWith_ :: RowParser r

522+ -> Connection

523+ -> Query

524+ -> a

525+ -> (a -> r -> IO a)

526+ -> IO a

527+foldWith_ = foldWithOptionsAndParser_ defaultFoldOptions

515528

516529foldWithOptions_ :: (FromRow r) =>

517530 FoldOptions

@@ -520,18 +533,27 @@ foldWithOptions_ :: (FromRow r) =>

520533 -> a -- ^ Initial state for result consumer.

521534 -> (a -> r -> IO a) -- ^ Result consumer.

522535 -> IO a

523−foldWithOptions_ opts conn query a f = doFold opts conn query query a f

524−

525−

526−doFold :: ( FromRow row )

527− => FoldOptions

536+foldWithOptions_ opts conn query' a f = doFold opts fromRow conn query' query' a f

537+

538+-- | A version of 'foldWithOptions_' taking a parser as an argument

539+foldWithOptionsAndParser_ :: FoldOptions

540+ -> RowParser r

541+ -> Connection

542+ -> Query -- ^ Query.

543+ -> a -- ^ Initial state for result consumer.

544+ -> (a -> r -> IO a) -- ^ Result consumer.

545+ -> IO a

546+foldWithOptionsAndParser_ opts parser conn query' a f = doFold opts parser conn query' query' a f

547+

548+doFold :: FoldOptions

549+ -> RowParser row

528550 -> Connection

529551 -> Query

530552 -> Query

531553 -> a

532554 -> (a -> row -> IO a)

533555 -> IO a

534−doFold FoldOptions{..} conn _template q a0 f = do

556+doFold FoldOptions{..} parser conn _template q a0 f = do

535557 stat <- withConnection conn PQ.transactionStatus

536558 case stat of

537559 PQ.TransIdle -> withTransactionMode transactionMode conn go

@@ -549,28 +571,17 @@ doFold FoldOptions{..} conn _template q a0 f = do

549571 PQ.TransUnknown -> fail "foldWithOpts FIXME: PQ.TransUnknown"

550572 -- Not sure what this means.

551573 where

552− declare = do

553− name <- newTempName conn

554− _ <- execute_ conn $ mconcat

555− [ "DECLARE ", name, " NO SCROLL CURSOR FOR ", q ]

556− return name

557− fetch (Query name) = query_ conn $

558− Query (toByteString (fromByteString "FETCH FORWARD "

559− <> integral chunkSize

560− <> fromByteString " FROM "

561− <> fromByteString name

562− ))

563− close name =

564− (execute_ conn ("CLOSE " <> name) >> return ()) `E.catch` \ex ->

565− -- Don't throw exception if CLOSE failed because the transaction is

566− -- aborted. Otherwise, it will throw away the original error.

567− if isFailedTransactionError ex then return () else throwIO ex

568−

569− go = bracket declare close $ \name ->

570− let loop a = do

571− rs <- fetch name

572− if null rs then return a else foldM f a rs >>= loop

573− in loop a0

574+ declare =

575+ declareCursor conn q

576+ fetch cursor a =

577+ foldForwardWithParser cursor parser chunkSize f a

578+

579+ go = bracket declare closeCursor $ \cursor ->

580+ let loop a = fetch cursor a >>=

581+ \r -> case r of

582+ Left x -> return x

583+ Right x -> loop x

584+ in loop a0

574585

575586-- FIXME: choose the Automatic chunkSize more intelligently

576587-- One possibility is to use the type of the results, although this

@@ -589,87 +600,37 @@ forEach :: (ToRow q, FromRow r) =>

589600 -> q -- ^ Query parameters.

590601 -> (r -> IO ()) -- ^ Result consumer.

591602 -> IO ()

592−forEach conn template qs = fold conn template qs () . const

603+forEach = forEachWith fromRow

593604{-# INLINE forEach #-}

594605

606+-- | A version of 'forEach' taking a parser as an argument

607+forEachWith :: ( ToRow q )

608+ => RowParser r

609+ -> Connection

610+ -> Query

611+ -> q

612+ -> (r -> IO ())

613+ -> IO ()

614+forEachWith parser conn template qs = foldWith parser conn template qs () . const

615+{-# INLINE forEachWith #-}

616+

595617-- | A version of 'forEach' that does not perform query substitution.

596618forEach_ :: (FromRow r) =>

597619 Connection

598620 -> Query -- ^ Query template.

599621 -> (r -> IO ()) -- ^ Result consumer.

600622 -> IO ()

601−forEach_ conn template = fold_ conn template () . const

623+forEach_ = forEachWith_ fromRow

602624{-# INLINE forEach_ #-}

603625

604−forM' :: (Ord n, Num n) => n -> n -> (n -> IO a) -> IO [a]

605−forM' lo hi m = loop hi []

606− where

607− loop !n !as

608− | n < lo = return as

609− | otherwise = do

610− a <- m n

611− loop (n-1) (a:as)

612−

613−finishQuery :: FromRow r => Connection -> Query -> PQ.Result -> IO [r]

614−finishQuery = finishQueryWith fromRow

615−

616−finishQueryWith :: RowParser r -> Connection -> Query -> PQ.Result -> IO [r]

617−finishQueryWith parser conn q result = do

618− status <- PQ.resultStatus result

619− case status of

620− PQ.EmptyQuery ->

621− throwIO $ QueryError "query: Empty query" q

622− PQ.CommandOk -> do

623− throwIO $ QueryError "query resulted in a command response" q

624− PQ.TuplesOk -> do

625− let unCol (PQ.Col x) = fromIntegral x :: Int

626− nrows <- PQ.ntuples result

627− ncols <- PQ.nfields result

628− forM' 0 (nrows-1) $ \row -> do

629− let rw = Row row result

630− okvc <- runConversion (runStateT (runReaderT (unRP parser) rw) 0) conn

631− case okvc of

632− Ok (val,col) | col == ncols -> return val

633− | otherwise -> do

634− vals <- forM' 0 (ncols-1) $ \c -> do

635− tinfo <- getTypeInfo conn =<< PQ.ftype result c

636− v <- PQ.getvalue result row c

637− return ( tinfo

638− , fmap ellipsis v )

639− throw (ConversionFailed

640− (show (unCol ncols) ++ " values: " ++ show vals)

641− Nothing

642− ""

643− (show (unCol col) ++ " slots in target type")

644− "mismatch between number of columns to \

645− \convert and number in target type")

646− Errors [] -> throwIO $ ConversionFailed "" Nothing "" "" "unknown error"

647− Errors [x] -> throwIO x

648− Errors xs -> throwIO $ ManyErrors xs

649− PQ.CopyOut ->

650− throwIO $ QueryError "query: COPY TO is not supported" q

651− PQ.CopyIn ->

652− throwIO $ QueryError "query: COPY FROM is not supported" q

653− PQ.BadResponse -> throwResultError "query" result status

654− PQ.NonfatalError -> throwResultError "query" result status

655− PQ.FatalError -> throwResultError "query" result status

656−

657−ellipsis :: ByteString -> ByteString

658−ellipsis bs

659− | B.length bs > 15 = B.take 10 bs `B.append` "[...]"

660− | otherwise = bs

661−

662−fmtError :: String -> Query -> [Action] -> a

663−fmtError msg q xs = throw FormatError {

664− fmtMessage = msg

665− , fmtQuery = q

666− , fmtParams = map twiddle xs

667− }

668− where twiddle (Plain b) = toByteString b

669− twiddle (Escape s) = s

670− twiddle (EscapeByteA s) = s

671− twiddle (EscapeIdentifier s) = s

672− twiddle (Many ys) = B.concat (map twiddle ys)

626+forEachWith_ :: RowParser r

627+ -> Connection

628+ -> Query

629+ -> (r -> IO ())

630+ -> IO ()

631+forEachWith_ parser conn template = foldWith_ parser conn template () . const

632+{-# INLINE forEachWith_ #-}

633+

673634

674635-- $use

675636--

@@ -941,7 +902,7 @@ fmtError msg q xs = throw FormatError {

941902-- all values of the given PostgreSQL type is considered \"compatible\".

942903-- For instance, you can always extract a PostgreSQL 16-bit @SMALLINT@

943904-- column to a Haskell 'Int'. The Haskell 'Float' type can accurately

944−-- represent a @SMALLINT@, so it is considered compatble with those types.

905+-- represent a @SMALLINT@, so it is considered compatible with those types.

945906--

946907-- * A numeric compatibility check is based only on the type of a

947908-- column, /not/ on its values. For instance, a PostgreSQL 64-bit

src/Database/PostgreSQL/Simple/Arrays.hs+3−3

@@ -17,7 +17,7 @@ import Control.Applicative (Applicative(..), Alternative(..), (<$>))

1717import Data.ByteString.Char8 (ByteString)

1818import qualified Data.ByteString.Char8 as B

1919import Data.Monoid

20−import Data.Attoparsec.Char8

20+import Data.Attoparsec.ByteString.Char8

2121

2222

2323-- | Parse one of three primitive field formats: array, quoted and plain.

@@ -42,9 +42,9 @@ array delim = char '{' *> option [] (arrays <|> strings) <* char '}'

4242quoted :: Parser ByteString

4343quoted = char '"' *> option "" contents <* char '"'

4444 where

45− esc = char '\\' *> (char '\\' <|> char '"')

45+ esc' = char '\\' *> (char '\\' <|> char '"')

4646 unQ = takeWhile1 (notInClass "\"\\")

47− contents = mconcat <$> many (unQ <|> B.singleton <$> esc)

47+ contents = mconcat <$> many (unQ <|> B.singleton <$> esc')

4848

4949-- | Recognizes a plain string literal, not containing quotes or brackets and

5050-- not containing the delimiter character.

src/Database/PostgreSQL/Simple/BuiltinTypes.hsdeleted−428

@@ -1,428 +0,0 @@

1−{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}

2−

3−------------------------------------------------------------------------------

4−-- |

5−-- Module: Database.PostgreSQL.Simple.BuiltinTypes

7−-- License: BSD3

8−-- Maintainer: Leon P Smith <leon@melding-monads.com>

9−-- Stability: experimental

10−--

11−------------------------------------------------------------------------------

12−

13−-- Note that this file is generated by tools/GenBuiltinTypes.hs, and should

14−-- not be edited directly

15−

16−module Database.PostgreSQL.Simple.BuiltinTypes

17− {-# DEPRECATED "Use TypeInfo instead" #-}

18− ( BuiltinType (..)

19− , builtin2oid

20− , oid2builtin

21− , builtin2typname

22− , oid2typname

23− ) where

24−

25−import Data.Typeable

26−import Data.ByteString (ByteString)

27−import qualified Database.PostgreSQL.LibPQ as PQ

28−

29−data BuiltinType

30− = Bool

31− | ByteA

32− | Char

33− | Name

34− | Int8

35− | Int2

36− | Int4

37− | RegProc

38− | Text

39− | Oid

40− | Tid

41− | Xid

42− | Cid

43− | Xml

44− | Point

45− | LSeg

46− | Path

47− | Box

48− | Polygon

49− | Line

50− | Cidr

51− | Float4

52− | Float8

53− | AbsTime

54− | RelTime

55− | TInterval

56− | Unknown

57− | Circle

58− | Money

59− | MacAddr

60− | Inet

61− | BpChar

62− | VarChar

63− | Date

64− | Time

65− | Timestamp

66− | TimestampTZ

67− | Interval

68− | TimeTZ

69− | Bit

70− | VarBit

71− | Numeric

72− | RefCursor

73− | Record

74− | Void

75− | UUID

76− | JSON

77− | JSONB

78− deriving (Eq, Ord, Enum, Bounded, Read, Show, Typeable)

79−

80−builtin2oid :: BuiltinType -> PQ.Oid

81−builtin2oid typ = PQ.Oid $ case typ of

82− Bool -> 16

83− ByteA -> 17

84− Char -> 18

85− Name -> 19

86− Int8 -> 20

87− Int2 -> 21

88− Int4 -> 23

89− RegProc -> 24

90− Text -> 25

91− Oid -> 26

92− Tid -> 27

93− Xid -> 28

94− Cid -> 29

95− Xml -> 142

96− Point -> 600

97− LSeg -> 601

98− Path -> 602

99− Box -> 603

100− Polygon -> 604

101− Line -> 628

102− Cidr -> 650

103− Float4 -> 700

104− Float8 -> 701

105− AbsTime -> 702

106− RelTime -> 703

107− TInterval -> 704

108− Unknown -> 705

109− Circle -> 718

110− Money -> 790

111− MacAddr -> 829

112− Inet -> 869

113− BpChar -> 1042

114− VarChar -> 1043

115− Date -> 1082

116− Time -> 1083

117− Timestamp -> 1114

118− TimestampTZ -> 1184

119− Interval -> 1186

120− TimeTZ -> 1266

121− Bit -> 1560

122− VarBit -> 1562

123− Numeric -> 1700

124− RefCursor -> 1790

125− Record -> 2249

126− Void -> 2278

127− UUID -> 2950

128− JSON -> 114

129− JSONB -> 3802

130−

131−oid2builtin :: PQ.Oid -> Maybe BuiltinType

132−oid2builtin (PQ.Oid x) = case x of

133− 16 -> Just Bool

134− 17 -> Just ByteA

135− 18 -> Just Char

136− 19 -> Just Name

137− 20 -> Just Int8

138− 21 -> Just Int2

139− 23 -> Just Int4

140− 24 -> Just RegProc

141− 25 -> Just Text

142− 26 -> Just Oid

143− 27 -> Just Tid

144− 28 -> Just Xid

145− 29 -> Just Cid

146− 142 -> Just Xml

147− 600 -> Just Point

148− 601 -> Just LSeg

149− 602 -> Just Path

150− 603 -> Just Box

151− 604 -> Just Polygon

152− 628 -> Just Line

153− 650 -> Just Cidr

154− 700 -> Just Float4

155− 701 -> Just Float8

156− 702 -> Just AbsTime

157− 703 -> Just RelTime

158− 704 -> Just TInterval

159− 705 -> Just Unknown

160− 718 -> Just Circle

161− 790 -> Just Money

162− 829 -> Just MacAddr

163− 869 -> Just Inet

164− 1042 -> Just BpChar

165− 1043 -> Just VarChar

166− 1082 -> Just Date

167− 1083 -> Just Time

168− 1114 -> Just Timestamp

169− 1184 -> Just TimestampTZ

170− 1186 -> Just Interval

171− 1266 -> Just TimeTZ

172− 1560 -> Just Bit

173− 1562 -> Just VarBit

174− 1700 -> Just Numeric

175− 1790 -> Just RefCursor

176− 2249 -> Just Record

177− 2278 -> Just Void

178− 2950 -> Just UUID

179− 114 -> Just JSON

180− 3802 -> Just JSONB

181− _ -> Nothing

182−

183−builtin2typname :: BuiltinType -> ByteString

184−builtin2typname typ = case typ of

185− Bool -> bool

186− ByteA -> bytea

187− Char -> char

188− Name -> name

189− Int8 -> int8

190− Int2 -> int2

191− Int4 -> int4

192− RegProc -> regproc

193− Text -> text

194− Oid -> oid

195− Tid -> tid

196− Xid -> xid

197− Cid -> cid

198− Xml -> xml

199− Point -> point

200− LSeg -> lseg

201− Path -> path

202− Box -> box

203− Polygon -> polygon

204− Line -> line

205− Cidr -> cidr

206− Float4 -> float4

207− Float8 -> float8

208− AbsTime -> abstime

209− RelTime -> reltime

210− TInterval -> tinterval

211− Unknown -> unknown

212− Circle -> circle

213− Money -> money

214− MacAddr -> macaddr

215− Inet -> inet

216− BpChar -> bpchar

217− VarChar -> varchar

218− Date -> date

219− Time -> time

220− Timestamp -> timestamp

221− TimestampTZ -> timestamptz

222− Interval -> interval

223− TimeTZ -> timetz

224− Bit -> bit

225− VarBit -> varbit

226− Numeric -> numeric

227− RefCursor -> refcursor

228− Record -> record

229− Void -> void

230− UUID -> uuid

231− JSON -> json

232− JSONB -> jsonb

233−

234−oid2typname :: PQ.Oid -> Maybe ByteString

235−oid2typname (PQ.Oid x) = case x of

236− 16 -> Just bool

237− 17 -> Just bytea

238− 18 -> Just char

239− 19 -> Just name

240− 20 -> Just int8

241− 21 -> Just int2

242− 23 -> Just int4

243− 24 -> Just regproc

244− 25 -> Just text

245− 26 -> Just oid

246− 27 -> Just tid

247− 28 -> Just xid

248− 29 -> Just cid

249− 142 -> Just xml

250− 600 -> Just point

251− 601 -> Just lseg

252− 602 -> Just path

253− 603 -> Just box

254− 604 -> Just polygon

255− 628 -> Just line

256− 650 -> Just cidr

257− 700 -> Just float4

258− 701 -> Just float8

259− 702 -> Just abstime

260− 703 -> Just reltime

261− 704 -> Just tinterval

262− 705 -> Just unknown

263− 718 -> Just circle

264− 790 -> Just money

265− 829 -> Just macaddr

266− 869 -> Just inet

267− 1042 -> Just bpchar

268− 1043 -> Just varchar

269− 1082 -> Just date

270− 1083 -> Just time

271− 1114 -> Just timestamp

272− 1184 -> Just timestamptz

273− 1186 -> Just interval

274− 1266 -> Just timetz

275− 1560 -> Just bit

276− 1562 -> Just varbit

277− 1700 -> Just numeric

278− 1790 -> Just refcursor

279− 2249 -> Just record

280− 2278 -> Just void

281− 2950 -> Just uuid

282− 114 -> Just json

283− 3802 -> Just jsonb

284− _ -> Nothing

285−

286−bool :: ByteString

287−bool = "bool"

288−

289−bytea :: ByteString

290−bytea = "bytea"

291−

292−char :: ByteString

293−char = "char"

294−

295−name :: ByteString

296−name = "name"

297−

298−int8 :: ByteString

299−int8 = "int8"

300−

301−int2 :: ByteString

302−int2 = "int2"

303−

304−int4 :: ByteString

305−int4 = "int4"

306−

307−regproc :: ByteString

308−regproc = "regproc"

309−

310−text :: ByteString

311−text = "text"

312−

313−oid :: ByteString

314−oid = "oid"

315−

316−tid :: ByteString

317−tid = "tid"

318−

319−xid :: ByteString

320−xid = "xid"

321−

322−cid :: ByteString

323−cid = "cid"

324−

325−xml :: ByteString

326−xml = "xml"

327−

328−point :: ByteString

329−point = "point"

330−

331−lseg :: ByteString

332−lseg = "lseg"

333−

334−path :: ByteString

335−path = "path"

336−

337−box :: ByteString

338−box = "box"

339−

340−polygon :: ByteString

341−polygon = "polygon"

342−

343−line :: ByteString

344−line = "line"

345−

346−cidr :: ByteString

347−cidr = "cidr"

348−

349−float4 :: ByteString

350−float4 = "float4"

351−

352−float8 :: ByteString

353−float8 = "float8"

354−

355−abstime :: ByteString

356−abstime = "abstime"

357−

358−reltime :: ByteString

359−reltime = "reltime"

360−

361−tinterval :: ByteString

362−tinterval = "tinterval"

363−

364−unknown :: ByteString

365−unknown = "unknown"

366−

367−circle :: ByteString

368−circle = "circle"

369−

370−money :: ByteString

371−money = "money"

372−

373−macaddr :: ByteString

374−macaddr = "macaddr"

375−

376−inet :: ByteString

377−inet = "inet"

378−

379−bpchar :: ByteString

380−bpchar = "bpchar"

381−

382−varchar :: ByteString

383−varchar = "varchar"

384−

385−date :: ByteString

386−date = "date"

387−

388−time :: ByteString

389−time = "time"

390−

391−timestamp :: ByteString

392−timestamp = "timestamp"

393−

394−timestamptz :: ByteString

395−timestamptz = "timestamptz"

396−

397−interval :: ByteString

398−interval = "interval"

399−

400−timetz :: ByteString

401−timetz = "timetz"

402−

403−bit :: ByteString

404−bit = "bit"

405−

406−varbit :: ByteString

407−varbit = "varbit"

408−

409−numeric :: ByteString

410−numeric = "numeric"

411−

412−refcursor :: ByteString

413−refcursor = "refcursor"

414−

415−record :: ByteString

416−record = "record"

417−

418−void :: ByteString

419−void = "void"

420−

421−uuid :: ByteString

422−uuid = "uuid"

423−

424−json :: ByteString

425−json = "json"

426−

427−jsonb :: ByteString

428−jsonb = "jsonb"

src/Database/PostgreSQL/Simple/Compat.hs+17−21

@@ -5,19 +5,20 @@ module Database.PostgreSQL.Simple.Compat

55 ( mask

66 , (<>)

77 , unsafeDupablePerformIO

8+ , toByteString

9+ , scientificBuilder

10+ , toPico

11+ , fromPico

812 ) where

913

1014import qualified Control.Exception as E

11−import Data.Monoid

12−

13−#if __GLASGOW_HASKELL__ >= 702

15+import Data.ByteString (ByteString)

16+import Data.ByteString.Lazy (toStrict)

17+import Data.ByteString.Builder (Builder, toLazyByteString)

18+import Data.Text.Lazy.Builder.Scientific (scientificBuilder)

1419import System.IO.Unsafe (unsafeDupablePerformIO)

15−#elif __GLASGOW_HASKELL__ >= 611

16−import GHC.IO (unsafeDupablePerformIO)

17−#else

18−import GHC.IOBase (unsafeDupablePerformIO)

19−#endif

20−

20+import Data.Fixed (Pico)

21+import Data.Fixed (Fixed(MkFixed))

2122

2223-- | Like 'E.mask', but backported to base before version 4.3.0.

2324--

@@ -27,19 +28,14 @@ import GHC.IOBase (unsafeDupablePerformIO)

2728-- 'withTransactionMode' function calls the restore callback only once, so we

2829-- don't need that polymorphism.

2930mask :: ((IO a -> IO a) -> IO b) -> IO b

30−#if MIN_VERSION_base(4,3,0)

3131mask io = E.mask $ \restore -> io restore

32−#else

33−mask io = do

34− b <- E.blocked

35− E.block $ io $ \m -> if b then m else E.unblock m

36−#endif

3732{-# INLINE mask #-}

3833

39−#if !MIN_VERSION_base(4,5,0)

40−infixr 6 <>

34+toByteString :: Builder -> ByteString

35+toByteString x = toStrict (toLazyByteString x)

36+

37+toPico :: Integer -> Pico

38+toPico = MkFixed

4139

42−(<>) :: Monoid m => m -> m -> m

43−(<>) = mappend

44−{-# INLINE (<>) #-}

45−#endif

40+fromPico :: Pico -> Integer

41+fromPico (MkFixed i) = i

src/Database/PostgreSQL/Simple/Copy.hs+36−6

@@ -9,7 +9,7 @@

99-- Stability: experimental

1010--

1111-- mid-level support for COPY IN and COPY OUT. See

12−-- <http://www.postgresql.org/docs/9.2/static/sql-copy.html> for

12+-- <https://www.postgresql.org/docs/9.5/static/sql-copy.html> for

1313-- more information.

1414--

1515-- To use this binding, first call 'copy' with an appropriate

@@ -32,6 +32,7 @@ module Database.PostgreSQL.Simple.Copy

3232 ( copy

3333 , copy_

3434 , CopyOutResult(..)

35+ , foldCopyData

3536 , getCopyData

3637 , putCopyData

3738 , putCopyEnd

@@ -48,13 +49,13 @@ import qualified Data.ByteString.Char8 as B

4849import qualified Database.PostgreSQL.LibPQ as PQ

4950import Database.PostgreSQL.Simple

5051import Database.PostgreSQL.Simple.Types

51−import Database.PostgreSQL.Simple.Internal

52+import Database.PostgreSQL.Simple.Internal hiding (result, row)

5253

5354

5455-- | Issue a @COPY FROM STDIN@ or @COPY TO STDOUT@ query. In the former

5556-- case, the connection's state will change to @CopyIn@; in the latter,

5657-- @CopyOut@. The connection must be in the ready state in order

57−-- to call this function. Performs parameter subsitution.

58+-- to call this function. Performs parameter substitution.

5859

5960copy :: ( ToRow params ) => Connection -> Query -> params -> IO ()

6061copy conn template qs = do

@@ -75,15 +76,18 @@ doCopy :: B.ByteString -> Connection -> Query -> B.ByteString -> IO ()

7576doCopy funcName conn template q = do

7677 result <- exec conn q

7778 status <- PQ.resultStatus result

78− let err = throwIO $ QueryError

79− (B.unpack funcName ++ " " ++ show status)

79+ let errMsg msg = throwIO $ QueryError

80+ (B.unpack funcName ++ " " ++ msg)

8081 template

82+ let err = errMsg $ show status

8183 case status of

8284 PQ.EmptyQuery -> err

8385 PQ.CommandOk -> err

8486 PQ.TuplesOk -> err

8587 PQ.CopyOut -> return ()

8688 PQ.CopyIn -> return ()

89+ PQ.CopyBoth -> errMsg "COPY BOTH is not supported"

90+ PQ.SingleTuple -> errMsg "single-row mode is not supported"

8791 PQ.BadResponse -> throwResultError funcName result status

8892 PQ.NonfatalError -> throwResultError funcName result status

8993 PQ.FatalError -> throwResultError funcName result status

@@ -97,6 +101,30 @@ data CopyOutResult

97101 deriving (Eq, Typeable, Show)

98102

99103

104+-- | Fold over @COPY TO STDOUT@ query passing each copied row to an accumulator

105+-- and calling a post-process at the end. A connection must be in the

106+-- @CopyOut@ state in order to call this function.

107+--

108+-- __Example__

109+--

110+-- > (acc, count) <- foldCopyData conn

111+-- > (\acc row -> return (row:acc))

112+-- > (\acc count -> return (acc, count))

113+-- > []

114+

115+foldCopyData

116+ :: Connection -- ^ Database connection

117+ -> (a -> B.ByteString -> IO a) -- ^ Accumulate one row of the result

118+ -> (a -> Int64 -> IO b) -- ^ Post-process accumulator with a count of rows

119+ -> a -- ^ Initial accumulator

120+ -> IO b -- ^ Result

121+foldCopyData conn f g !acc = do

122+ result <- getCopyData conn

123+ case result of

124+ CopyOutRow row -> f acc row >>= foldCopyData conn f g

125+ CopyOutDone count -> g acc count

126+

127+

100128-- | Retrieve some data from a @COPY TO STDOUT@ query. A connection

101129-- must be in the @CopyOut@ state in order to call this function. If this

102130-- returns a 'CopyOutRow', the connection remains in the @CopyOut@ state,

@@ -224,7 +252,9 @@ getCopyCommandTag funcName pqconn = do

224252 consumeResults pqconn

225253 let rowCount = P.string "COPY " *> (P.decimal <* P.endOfInput)

226254 case P.parseOnly rowCount cmdStat of

227− Left _ -> fail errCmdStatusFmt

255+ Left _ -> do mmsg <- PQ.errorMessage pqconn

256+ fail $ errCmdStatusFmt

257+ ++ maybe "" (\msg -> "\nConnection error: "++B.unpack msg) mmsg

228258 Right n -> return $! n

229259 where

230260 errCmdStatus = B.unpack funcName ++ ": failed to fetch command status"

src/Database/PostgreSQL/Simple/Cursor.hsnew file+98

@@ -0,0 +1,98 @@

1+{-# LANGUAGE OverloadedStrings #-}

3+------------------------------------------------------------------------------

4+-- |

5+-- Module: Database.PostgreSQL.Simple.Cursor

8+-- License: BSD3

9+-- Maintainer: Leon P Smith <leon@melding-monads.com>

10+--

11+------------------------------------------------------------------------------

12+

13+module Database.PostgreSQL.Simple.Cursor

14+ (

15+ -- * Types

16+ Cursor

17+ -- * Cursor management

18+ , declareCursor

19+ , closeCursor

20+ -- * Folding over rows from a cursor

21+ , foldForward

22+ , foldForwardWithParser

23+ ) where

24+

25+import Data.ByteString.Builder (intDec)

26+import Control.Applicative ((<$>))

27+import Control.Exception as E

28+import Control.Monad (unless, void)

29+import Data.Monoid (mconcat)

30+import Database.PostgreSQL.Simple.Compat ((<>), toByteString)

31+import Database.PostgreSQL.Simple.FromRow (FromRow(..))

32+import Database.PostgreSQL.Simple.Types (Query(..))

33+import Database.PostgreSQL.Simple.Internal as Base hiding (result, row)

34+import Database.PostgreSQL.Simple.Internal.PQResultUtils

35+import Database.PostgreSQL.Simple.Transaction

36+import qualified Database.PostgreSQL.LibPQ as PQ

37+

38+-- | Cursor within a transaction.

39+data Cursor = Cursor !Query !Connection

40+

41+-- | Declare a temporary cursor. The cursor is given a

42+-- unique name for the given connection.

43+declareCursor :: Connection -> Query -> IO Cursor

44+declareCursor conn q = do

45+ name <- newTempName conn

46+ void $ execute_ conn $ mconcat ["DECLARE ", name, " NO SCROLL CURSOR FOR ", q]

47+ return $ Cursor name conn

48+

49+-- | Close the given cursor.

50+closeCursor :: Cursor -> IO ()

51+closeCursor (Cursor name conn) =

52+ (void $ execute_ conn ("CLOSE " <> name)) `E.catch` \ex ->

53+ -- Don't throw exception if CLOSE failed because the transaction is

54+ -- aborted. Otherwise, it will throw away the original error.

55+ unless (isFailedTransactionError ex) $ throwIO ex

56+

57+-- | Fold over a chunk of rows from the given cursor, calling the

58+-- supplied fold-like function on each row as it is received. In case

59+-- the cursor is exhausted, a 'Left' value is returned, otherwise a

60+-- 'Right' value is returned.

61+foldForwardWithParser :: Cursor -> RowParser r -> Int -> (a -> r -> IO a) -> a -> IO (Either a a)

62+foldForwardWithParser (Cursor name conn) parser chunkSize f a0 = do

63+ let q = "FETCH FORWARD "

64+ <> (toByteString $ intDec chunkSize)

65+ <> " FROM "

66+ <> fromQuery name

67+ result <- exec conn q

68+ status <- PQ.resultStatus result

69+ case status of

70+ PQ.TuplesOk -> do

71+ nrows <- PQ.ntuples result

72+ ncols <- PQ.nfields result

73+ if nrows > 0

74+ then do

75+ let inner a row = do

76+ x <- getRowWith parser row ncols conn result

77+ f a x

78+ Right <$> foldM' inner a0 0 (nrows - 1)

79+ else

80+ return $ Left a0

81+ _ -> throwResultError "foldForwardWithParser" result status

82+

83+-- | Fold over a chunk of rows, calling the supplied fold-like function

84+-- on each row as it is received. In case the cursor is exhausted,

85+-- a 'Left' value is returned, otherwise a 'Right' value is returned.

86+foldForward :: FromRow r => Cursor -> Int -> (a -> r -> IO a) -> a -> IO (Either a a)

87+foldForward cursor = foldForwardWithParser cursor fromRow

88+

89+

90+foldM' :: (Ord n, Num n) => (a -> n -> IO a) -> a -> n -> n -> IO a

91+foldM' f a lo hi = loop a lo

92+ where

93+ loop x !n

94+ | n > hi = return x

95+ | otherwise = do

96+ x' <- f x n

97+ loop x' (n+1)

98+{-# INLINE foldM' #-}

src/Database/PostgreSQL/Simple/Errors.hs+16−12

@@ -25,10 +25,9 @@ module Database.PostgreSQL.Simple.Errors

2525 )

2626 where

2727

28−import Control.Applicative

2928import Control.Exception as E

3029

31−import Data.Attoparsec.Char8

30+import Data.Attoparsec.ByteString.Char8

3231import Data.ByteString (ByteString)

3332import Data.Typeable

3433

@@ -55,19 +54,23 @@ data ConstraintViolation

5554 -- ^ Name of violated constraint

5655 | CheckViolation ByteString ByteString

5756 -- ^ Relation name (usually table), constraint name

57+ | ExclusionViolation ByteString

58+ -- ^ Name of the exclusion violation constraint

5859 deriving (Show, Eq, Ord, Typeable)

5960

6061-- Default instance should be enough

61−instance Exception ConstraintViolation

62+instance Exception ConstraintViolation where

63+ toException = postgresqlExceptionToException

64+ fromException = postgresqlExceptionFromException

6265

6366

6467-- | Tries to convert 'SqlError' to 'ConstrainViolation', checks sqlState and

65−-- succeedes only if able to parse sqlErrorMsg.

68+-- succeeds only if able to parse sqlErrorMsg.

6669--

67−-- > createUser = catchJust constraintViolation catcher $ execute conn ...

70+-- > createUser = handleJust constraintViolation handler $ execute conn ...

6871-- > where

69−-- > catcher UniqueViolation "user_login_key" = ...

70−-- > catcher _ = ...

72+-- > handler (UniqueViolation "user_login_key") = ...

73+-- > handler _ = ...

7174constraintViolation :: SqlError -> Maybe ConstraintViolation

7275constraintViolation e =

7376 case sqlState e of

@@ -75,22 +78,23 @@ constraintViolation e =

7578 "23503" -> uncurry ForeignKeyViolation <$> parseMaybe parseQ2 msg

7679 "23505" -> UniqueViolation <$> parseMaybe parseQ1 msg

7780 "23514" -> uncurry CheckViolation <$> parseMaybe parseQ2 msg

81+ "23P01" -> ExclusionViolation <$> parseMaybe parseQ1 msg

7882 _ -> Nothing

7983 where msg = sqlErrorMsg e

8084

8185

8286-- | Like constraintViolation, but also packs original SqlError.

8387--

84−-- > createUser = catchJust constraintViolationE catcher $ execute conn ...

88+-- > createUser = handleJust constraintViolationE handler $ execute conn ...

8589-- > where

86−-- > catcher (_, UniqueViolation "user_login_key") = ...

87−-- > catcher (e, _) = throwIO e

90+-- > handler (_, UniqueViolation "user_login_key") = ...

91+-- > handler (e, _) = throwIO e

8892--

8993constraintViolationE :: SqlError -> Maybe (SqlError, ConstraintViolation)

9094constraintViolationE e = fmap ((,) e) $ constraintViolation e

9195

9296-- | Catches SqlError, tries to convert to ConstraintViolation, re-throws

93−-- on fail. Provides alternative interface to catchJust

97+-- on fail. Provides alternative interface to 'E.handleJust'

9498--

9599-- > createUser = catchViolation catcher $ execute conn ...

96100-- > where

@@ -121,7 +125,7 @@ parseMaybe p b = either (const Nothing) Just $ parseOnly p b

121125------------------------------------------------------------------------

122126-- Error predicates

123127--

124−-- http://www.postgresql.org/docs/current/static/errcodes-appendix.html

128+-- https://www.postgresql.org/docs/9.5/static/errcodes-appendix.html

125129

126130isSerializationError :: SqlError -> Bool

127131isSerializationError = isSqlState "40001"

src/Database/PostgreSQL/Simple/FromField.hs+191−94

@@ -1,7 +1,8 @@

11{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-}

22{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}

33{-# LANGUAGE PatternGuards, ScopedTypeVariables #-}

4−{-# LANGUAGE RecordWildCards, TemplateHaskell #-}

4+{-# LANGUAGE RecordWildCards #-}

5+{-# LANGUAGE PolyKinds #-}

67{- |

78Module: Database.PostgreSQL.Simple.FromField

@@ -28,10 +29,10 @@ conversion routine, which sacrifices some accuracy for speed. If you

2829need accuracy, consider first converting data to a 'Scientific' or 'Rational'

2930type, and then converting to a floating-point type. If you are defining

3031your own 'Database.PostgreSQL.Simple.FromRow.FromRow' instances, this can be

31−acheived simply by

32+achieved simply by

3233@'fromRational' '<$>' 'Database.PostgreSQL.Simple.FromRow.field'@, although

33−this idiom is additionally compatible with PostgreSQL's @numeric@ type.

34−If this is unacceptable, you may find

34+this idiom is additionally compatible with PostgreSQL's @int8@ and @numeric@

35+types. If this is unacceptable, you may find

3536'Database.PostgreSQL.Simple.FromRow.fieldWith' useful.

3637

3738Also note that while converting to a 'Double' through the 'Scientific' type

@@ -105,23 +106,28 @@ module Database.PostgreSQL.Simple.FromField

105106 , typeOid

106107 , PQ.Oid(..)

107108 , PQ.Format(..)

109+ , pgArrayFieldParser

110+ , attoFieldParser

108111

112+ , optionalField

109113 , fromJSONField

114+ , fromFieldJSONByteString

110115 ) where

111116

112117#include "MachDeps.h"

113118

114−import Control.Applicative ( (<|>), (<$>), pure, (*>) )

119+import Control.Applicative ( Const(Const), (<|>), (<$>), pure, (*>), (<*) )

115120import Control.Concurrent.MVar (MVar, newMVar)

116−import Control.Exception (Exception)

121+import Control.Exception (Exception (toException, fromException))

117122import qualified Data.Aeson as JSON

118123import Data.Attoparsec.ByteString.Char8 hiding (Result)

119124import Data.ByteString (ByteString)

120125import qualified Data.ByteString.Char8 as B

126+import Data.Functor.Identity (Identity(Identity))

121127import Data.Int (Int16, Int32, Int64)

122128import Data.IORef (IORef, newIORef)

123129import Data.Ratio (Ratio)

124−import Data.Time ( UTCTime, ZonedTime, LocalTime, Day, TimeOfDay )

130+import Data.Time.Compat ( UTCTime, ZonedTime, LocalTime, Day, TimeOfDay, CalendarDiffTime )

125131import Data.Typeable (Typeable, typeOf)

126132import Data.Vector (Vector)

127133import Data.Vector.Mutable (IOVector)

@@ -132,7 +138,6 @@ import Database.PostgreSQL.Simple.Ok

132138import Database.PostgreSQL.Simple.Types

133139import Database.PostgreSQL.Simple.TypeInfo as TI

134140import qualified Database.PostgreSQL.Simple.TypeInfo.Static as TI

135−import Database.PostgreSQL.Simple.TypeInfo.Macro as TI

136141import Database.PostgreSQL.Simple.Time

137142import Database.PostgreSQL.Simple.Arrays as Arrays

138143import qualified Database.PostgreSQL.LibPQ as PQ

@@ -142,11 +147,15 @@ import qualified Data.ByteString.Lazy as LB

142147import qualified Data.Text as ST

143148import qualified Data.Text.Encoding as ST

144149import qualified Data.Text.Lazy as LT

145−import Data.UUID (UUID)

146−import qualified Data.UUID as UUID

150+import Data.CaseInsensitive (CI)

151+import qualified Data.CaseInsensitive as CI

152+import Data.UUID.Types (UUID)

153+import qualified Data.UUID.Types as UUID

147154import Data.Scientific (Scientific)

148155import GHC.Real (infinity, notANumber)

149156

157+import qualified Data.Aeson.Types as JSON

158+

150159-- | Exception thrown if conversion from a SQL value to a Haskell

151160-- value fails.

152161data ResultError = Incompatible { errSQLType :: String

@@ -173,7 +182,9 @@ data ResultError = Incompatible { errSQLType :: String

173182 -- between metadata and actual data in a row).

174183 deriving (Eq, Show, Typeable)

175184

176−instance Exception ResultError

185+instance Exception ResultError where

186+ toException = postgresqlExceptionToException

187+ fromException = postgresqlExceptionFromException

177188

178189left :: Exception a => a -> Conversion b

179190left = conversionError

@@ -214,7 +225,7 @@ typename field = typname <$> typeInfo field

214225

215226typeInfo :: Field -> Conversion TypeInfo

216227typeInfo Field{..} = Conversion $ \conn -> do

217− Ok <$> (getTypeInfo conn =<< PQ.ftype result column)

228+ Ok <$> (getTypeInfo conn typeOid)

218229

219230typeInfoByOid :: PQ.Oid -> Conversion TypeInfo

220231typeInfoByOid oid = Conversion $ \conn -> do

@@ -239,9 +250,11 @@ tableOid Field{..} = toMaybeOid (unsafeDupablePerformIO (PQ.ftable result column

239250 then Nothing

240251 else Just x

241252

242−-- | If the column has a table associated with it, this returns the number

243−-- off the associated table column. Numbering starts from 0. Analogous

244−-- to libpq's @PQftablecol@.

253+-- | If the column has a table associated with it, this returns the

254+-- number of the associated table column. Table columns have

255+-- nonzero numbers. Zero is returned if the specified column is not

256+-- a simple reference to a table column, or when using pre-3.0

257+-- protocol. Analogous to libpq's @PQftablecol@.

245258

246259tableColumn :: Field -> Int

247260tableColumn Field{..} = fromCol (unsafeDupablePerformIO (PQ.ftablecol result column))

@@ -257,16 +270,33 @@ format Field{..} = unsafeDupablePerformIO (PQ.fformat result column)

257270-- | void

258271instance FromField () where

259272 fromField f _bs

260− | typeOid f /= $(inlineTypoid TI.void) = returnError Incompatible f ""

273+ | typeOid f /= TI.voidOid = returnError Incompatible f ""

261274 | otherwise = pure ()

262275

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+

263282-- | For dealing with null values. Compatible with any postgresql type

264283-- compatible with type @a@. Note that the type is not checked if

265284-- the value is null, although it is inadvisable to rely on this

266285-- behavior.

267−instance (FromField a) => FromField (Maybe a) where

268− fromField _ Nothing = pure Nothing

269− fromField f bs = Just <$> fromField f bs

286+instance FromField a => FromField (Maybe a) where

287+ fromField = optionalField fromField

288+

289+-- | For dealing with SQL @null@ values outside of the 'FromField' class.

290+-- Alternatively, one could use 'Control.Applicative.optional', but that

291+-- also turns type and conversion errors into 'Nothing', whereas this is

292+-- more specific and turns only @null@ values into 'Nothing'.

293+

294+optionalField :: FieldParser a -> FieldParser (Maybe a)

295+optionalField p f mv =

296+ case mv of

297+ Nothing -> pure Nothing

298+ Just _ -> Just <$> p f mv

299+{-# INLINE optionalField #-}

270300

271301-- | compatible with any data type, but the value must be null

272302instance FromField Null where

@@ -276,30 +306,30 @@ instance FromField Null where

276306-- | bool

277307instance FromField Bool where

278308 fromField f bs

279− | typeOid f /= $(inlineTypoid TI.bool) = returnError Incompatible f ""

309+ | typeOid f /= TI.boolOid = returnError Incompatible f ""

280310 | bs == Nothing = returnError UnexpectedNull f ""

281311 | bs == Just "t" = pure True

282312 | bs == Just "f" = pure False

283313 | otherwise = returnError ConversionFailed f ""

284314

285−-- | \"char\"

315+-- | \"char\", bpchar

286316instance FromField Char where

287− fromField f bs =

288− if typeOid f /= $(inlineTypoid TI.char)

289− then returnError Incompatible f ""

290− else case bs of

317+ fromField f bs0 =

318+ if (eq TI.charOid \/ eq TI.bpcharOid) (typeOid f)

319+ then case bs0 of

291320 Nothing -> returnError UnexpectedNull f ""

292321 Just bs -> if B.length bs /= 1

293322 then returnError ConversionFailed f "length not 1"

294323 else return $! (B.head bs)

324+ else returnError Incompatible f ""

295325

296326-- | int2

297327instance FromField Int16 where

298− fromField = atto ok16 $ signed decimal

328+ fromField = attoFieldParser ok16 $ signed decimal

299329

300330-- | int2, int4

301331instance FromField Int32 where

302− fromField = atto ok32 $ signed decimal

332+ fromField = attoFieldParser ok32 $ signed decimal

303333

304334#if WORD_SIZE_IN_BITS < 64

305335-- | int2, int4, and if compiled as 64-bit code, int8 as well.

@@ -309,37 +339,37 @@ instance FromField Int32 where

309339-- This library was compiled as 64-bit code.

310340#endif

311341instance FromField Int where

312− fromField = atto okInt $ signed decimal

342+ fromField = attoFieldParser okInt $ signed decimal

313343

314344-- | int2, int4, int8

315345instance FromField Int64 where

316− fromField = atto ok64 $ signed decimal

346+ fromField = attoFieldParser ok64 $ signed decimal

317347

318348-- | int2, int4, int8

319349instance FromField Integer where

320− fromField = atto ok64 $ signed decimal

350+ fromField = attoFieldParser ok64 $ signed decimal

321351

322352-- | int2, float4 (Uses attoparsec's 'double' routine, for

323353-- better accuracy convert to 'Scientific' or 'Rational' first)

324354instance FromField Float where

325− fromField = atto ok (realToFrac <$> pg_double)

326− where ok = $(mkCompats [TI.float4,TI.int2])

355+ fromField = attoFieldParser ok (realToFrac <$> pg_double)

356+ where ok = eq TI.float4Oid \/ eq TI.int2Oid

327357

328358-- | int2, int4, float4, float8 (Uses attoparsec's 'double' routine, for

329359-- better accuracy convert to 'Scientific' or 'Rational' first)

330360instance FromField Double where

331− fromField = atto ok pg_double

332− where ok = $(mkCompats [TI.float4,TI.float8,TI.int2,TI.int4])

361+ fromField = attoFieldParser ok pg_double

362+ where ok = eq TI.float4Oid \/ eq TI.float8Oid \/ eq TI.int2Oid \/ eq TI.int4Oid

333363

334−-- | int2, int4, float4, float8, numeric

364+-- | int2, int4, int8, float4, float8, numeric

335365instance FromField (Ratio Integer) where

336− fromField = atto ok pg_rational

337− where ok = $(mkCompats [TI.float4,TI.float8,TI.int2,TI.int4,TI.numeric])

366+ fromField = attoFieldParser ok pg_rational

367+ where ok = eq TI.float4Oid \/ eq TI.float8Oid \/ eq TI.int2Oid \/ eq TI.int4Oid \/ eq TI.int8Oid \/ eq TI.numericOid

338368

339−-- | int2, int4, float4, float8, numeric

369+-- | int2, int4, int8, float4, float8, numeric

340370instance FromField Scientific where

341− fromField = atto ok rational

342− where ok = $(mkCompats [TI.float4,TI.float8,TI.int2,TI.int4,TI.numeric])

371+ fromField = attoFieldParser ok rational

372+ where ok = eq TI.float4Oid \/ eq TI.float8Oid \/ eq TI.int2Oid \/ eq TI.int4Oid \/ eq TI.int8Oid \/ eq TI.numericOid

343373

344374unBinary :: Binary t -> t

345375unBinary (Binary x) = x

@@ -360,13 +390,13 @@ pg_rational

360390

361391-- | bytea, name, text, \"char\", bpchar, varchar, unknown

362392instance FromField SB.ByteString where

363− fromField f dat = if typeOid f == $(inlineTypoid TI.bytea)

393+ fromField f dat = if typeOid f == TI.byteaOid

364394 then unBinary <$> fromField f dat

365395 else doFromField f okText' pure dat

366396

367397-- | oid

368398instance FromField PQ.Oid where

369− fromField f dat = PQ.Oid <$> atto (== $(inlineTypoid TI.oid)) decimal f dat

399+ fromField f dat = PQ.Oid <$> attoFieldParser (== TI.oidOid) decimal f dat

370400

371401-- | bytea, name, text, \"char\", bpchar, varchar, unknown

372402instance FromField LB.ByteString where

@@ -374,7 +404,7 @@ instance FromField LB.ByteString where

374404

375405unescapeBytea :: Field -> SB.ByteString

376406 -> Conversion (Binary SB.ByteString)

377−unescapeBytea f str = case unsafeDupablePerformIO (PQ.unescapeBytea str) of

407+unescapeBytea f str' = case unsafeDupablePerformIO (PQ.unescapeBytea str') of

378408 Nothing -> returnError ConversionFailed f "unescapeBytea failed"

379409 Just str -> pure (Binary str)

380410

@@ -397,54 +427,85 @@ instance FromField ST.Text where

397427instance FromField LT.Text where

398428 fromField f dat = LT.fromStrict <$> fromField f dat

399429

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+

400452-- | name, text, \"char\", bpchar, varchar

401453instance FromField [Char] where

402454 fromField f dat = ST.unpack <$> fromField f dat

403455

404456-- | timestamptz

405457instance FromField UTCTime where

406− fromField = ff $(inlineTypoid TI.timestamptz) "UTCTime" parseUTCTime

458+ fromField = ff TI.timestamptzOid "UTCTime" parseUTCTime

407459

408460-- | timestamptz

409461instance FromField ZonedTime where

410− fromField = ff $(inlineTypoid TI.timestamptz) "ZonedTime" parseZonedTime

462+ fromField = ff TI.timestamptzOid "ZonedTime" parseZonedTime

411463

412464-- | timestamp

413465instance FromField LocalTime where

414− fromField = ff $(inlineTypoid TI.timestamp) "LocalTime" parseLocalTime

466+ fromField = ff TI.timestampOid "LocalTime" parseLocalTime

415467

416468-- | date

417469instance FromField Day where

418− fromField = ff $(inlineTypoid TI.date) "Day" parseDay

470+ fromField = ff TI.dateOid "Day" parseDay

419471

420472-- | time

421473instance FromField TimeOfDay where

422− fromField = ff $(inlineTypoid TI.time) "TimeOfDay" parseTimeOfDay

474+ fromField = ff TI.timeOid "TimeOfDay" parseTimeOfDay

423475

424476-- | timestamptz

425477instance FromField UTCTimestamp where

426− fromField = ff $(inlineTypoid TI.timestamptz) "UTCTimestamp" parseUTCTimestamp

478+ fromField = ff TI.timestamptzOid "UTCTimestamp" parseUTCTimestamp

427479

428480-- | timestamptz

429481instance FromField ZonedTimestamp where

430− fromField = ff $(inlineTypoid TI.timestamptz) "ZonedTimestamp" parseZonedTimestamp

482+ fromField = ff TI.timestamptzOid "ZonedTimestamp" parseZonedTimestamp

431483

432484-- | timestamp

433485instance FromField LocalTimestamp where

434− fromField = ff $(inlineTypoid TI.timestamp) "LocalTimestamp" parseLocalTimestamp

486+ fromField = ff TI.timestampOid "LocalTimestamp" parseLocalTimestamp

435487

436488-- | date

437489instance FromField Date where

438− fromField = ff $(inlineTypoid TI.date) "Date" parseDate

490+ fromField = ff TI.dateOid "Date" parseDate

491+

492+-- | interval. Requires you to configure intervalstyle as @iso_8601@.

493+--

494+-- You can configure intervalstyle on every connection with a @SET@ command,

495+-- but for better performance you may want to configure it permanently in the

496+-- file found with @SHOW config_file;@ .

497+--

498+instance FromField CalendarDiffTime where

499+ fromField = ff TI.intervalOid "CalendarDiffTime" parseCalendarDiffTime

439500

440501ff :: PQ.Oid -> String -> (B8.ByteString -> Either String a)

441502 -> Field -> Maybe B8.ByteString -> Conversion a

442−ff compatOid hsType parse f mstr =

503+ff compatOid hsType parseBS f mstr =

443504 if typeOid f /= compatOid

444505 then err Incompatible ""

445506 else case mstr of

446507 Nothing -> err UnexpectedNull ""

447− Just str -> case parse str of

508+ Just str -> case parseBS str of

448509 Left msg -> err ConversionFailed msg

449510 Right val -> return val

450511 where

@@ -466,27 +527,29 @@ instance (FromField a, FromField b) => FromField (Either a b) where

466527

467528-- | any postgresql array whose elements are compatible with type @a@

468529instance (FromField a, Typeable a) => FromField (PGArray a) where

469− fromField f mdat = do

530+ fromField = pgArrayFieldParser fromField

531+

532+pgArrayFieldParser :: Typeable a => FieldParser a -> FieldParser (PGArray a)

533+pgArrayFieldParser fieldParser f mdat = do

470534 info <- typeInfo f

471535 case info of

472536 TI.Array{} ->

473537 case mdat of

474538 Nothing -> returnError UnexpectedNull f ""

475539 Just dat -> do

476− case parseOnly (fromArray info f) dat of

540+ case parseOnly (fromArray fieldParser info f) dat of

477541 Left err -> returnError ConversionFailed f err

478542 Right conv -> PGArray <$> conv

479543 _ -> returnError Incompatible f ""

480544

481−fromArray :: (FromField a)

482− => TypeInfo -> Field -> Parser (Conversion [a])

483−fromArray typeInfo f = sequence . (parseIt <$>) <$> array delim

545+fromArray :: FieldParser a -> TypeInfo -> Field -> Parser (Conversion [a])

546+fromArray fieldParser typInfo f = sequence . (parseIt <$>) <$> array delim

484547 where

485− delim = typdelim (typelem typeInfo)

486− fElem = f{ typeOid = typoid (typelem typeInfo) }

548+ delim = typdelim (typelem typInfo)

549+ fElem = f{ typeOid = typoid (typelem typInfo) }

487550

488551 parseIt item =

489− fromField f' $ if item' == "NULL" then Nothing else Just item'

552+ fieldParser f' $ if item == Arrays.Plain "NULL" then Nothing else Just item'

490553 where

491554 item' = fmt delim item

492555 f' | Arrays.Array _ <- item = f

@@ -501,7 +564,7 @@ instance (FromField a, Typeable a) => FromField (IOVector a) where

501564-- | uuid

502565instance FromField UUID where

503566 fromField f mbs =

504− if typeOid f /= $(inlineTypoid TI.uuid)

567+ if typeOid f /= TI.uuidOid

505568 then returnError Incompatible f ""

506569 else case mbs of

507570 Nothing -> returnError UnexpectedNull f ""

@@ -510,26 +573,26 @@ instance FromField UUID where

510573 Nothing -> returnError ConversionFailed f "Invalid UUID"

511574 Just uuid -> pure uuid

512575

513−-- | json

576+-- | json, jsonb

514577instance FromField JSON.Value where

515− fromField f mbs =

516− if typeOid f /= $(inlineTypoid TI.json) && typeOid f /= $(inlineTypoid TI.jsonb)

578+ fromField f mbs = parseBS =<< fromFieldJSONByteString f mbs

579+ where parseBS bs = case JSON.eitherDecodeStrict' bs of

580+ Left err -> returnError ConversionFailed f err

581+ Right val -> pure val

582+

583+-- | Return the JSON ByteString directly

584+--

585+-- @since 0.6.3

586+fromFieldJSONByteString :: Field -> Maybe ByteString -> Conversion ByteString

587+fromFieldJSONByteString f mbs =

588+ if typeOid f /= TI.jsonOid && typeOid f /= TI.jsonbOid

517589 then returnError Incompatible f ""

518590 else case mbs of

519591 Nothing -> returnError UnexpectedNull f ""

520− Just bs ->

521−#if MIN_VERSION_aeson(0,6,3)

522− case JSON.eitherDecodeStrict' bs of

523−#elif MIN_VERSION_bytestring(0,10,0)

524− case JSON.eitherDecode' $ LB.fromStrict bs of

525−#else

526− case JSON.eitherDecode' $ LB.fromChunks [bs] of

527−#endif

528− Left err -> returnError ConversionFailed f err

529− Right val -> pure val

592+ Just bs -> pure bs

530593

531594-- | Parse a field to a JSON 'JSON.Value' and convert that into a

532−-- Haskell value using 'JSON.fromJSON'.

595+-- Haskell value using the 'JSON.FromJSON' instance.

533596--

534597-- This can be used as the default implementation for the 'fromField'

535598-- method for Haskell types that have a JSON representation in

@@ -537,14 +600,23 @@ instance FromField JSON.Value where

537600--

538601-- The 'Typeable' constraint is required to show more informative

539602-- 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@

540613fromJSONField :: (JSON.FromJSON a, Typeable a) => FieldParser a

541614fromJSONField f mbBs = do

542615 value <- fromField f mbBs

543− case JSON.fromJSON value of

544− JSON.Error err -> returnError ConversionFailed f $

545− "JSON decoding error: " ++ err

546− JSON.Success x -> pure x

547−

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

548620

549621-- | Compatible with the same set of types as @a@. Note that

550622-- modifying the 'IORef' does not have any effects outside

@@ -561,20 +633,33 @@ instance FromField a => FromField (MVar a) where

561633type Compat = PQ.Oid -> Bool

562634

563635okText, okText', okBinary, ok16, ok32, ok64, okInt :: Compat

564−okText = $( mkCompats [ TI.name, TI.text, TI.char,

565− TI.bpchar, TI.varchar ] )

566−okText' = $( mkCompats [ TI.name, TI.text, TI.char,

567− TI.bpchar, TI.varchar, TI.unknown ] )

568−okBinary = (== $( inlineTypoid TI.bytea ))

569−ok16 = (== $( inlineTypoid TI.int2 ))

570−ok32 = $( mkCompats [TI.int2,TI.int4] )

571−ok64 = $( mkCompats [TI.int2,TI.int4,TI.int8] )

636+okText = eq TI.nameOid \/ eq TI.textOid \/ eq TI.charOid

637+ \/ eq TI.bpcharOid \/ eq TI.varcharOid

638+okText' = eq TI.nameOid \/ eq TI.textOid \/ eq TI.charOid

639+ \/ eq TI.bpcharOid \/ eq TI.varcharOid \/ eq TI.unknownOid

640+okBinary = eq TI.byteaOid

641+ok16 = eq TI.int2Oid

642+ok32 = eq TI.int2Oid \/ eq TI.int4Oid

643+ok64 = eq TI.int2Oid \/ eq TI.int4Oid \/ eq TI.int8Oid

572644#if WORD_SIZE_IN_BITS < 64

573645okInt = ok32

574646#else

575647okInt = ok64

576648#endif

577649

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+

578663doFromField :: forall a . (Typeable a)

579664 => Field -> Compat -> (ByteString -> Conversion a)

580665 -> Maybe ByteString -> Conversion a

@@ -599,10 +684,22 @@ returnError mkErr f msg = do

599684 (show (typeOf (undefined :: a)))

600685 msg

601686

602−atto :: forall a. (Typeable a)

603− => Compat -> Parser a -> Field -> Maybe ByteString

604− -> Conversion a

605−atto types p0 f dat = doFromField f types (go p0) dat

687+-- | Construct a field parser from an attoparsec parser. An 'Incompatible' error is thrown if the

688+-- PostgreSQL oid does not match the specified predicate.

689+--

690+-- @

691+-- instance FromField Int16 where

692+-- fromField = attoFieldParser ok16 (signed decimal)

693+-- @

694+--

695+-- @since 0.6.3

696+attoFieldParser :: forall a. (Typeable a)

697+ => (PQ.Oid -> Bool)

698+ -- ^ Predicate for whether the postgresql type oid is compatible with this parser

699+ -> Parser a

700+ -- ^ An attoparsec parser.

701+ -> FieldParser a

702+attoFieldParser types p0 f dat = doFromField f types (go p0) dat

606703 where

607704 go :: Parser a -> ByteString -> Conversion a

608705 go p s =

src/Database/PostgreSQL/Simple/FromRow.hs+239−6

@@ -1,4 +1,6 @@

1−{-# LANGUAGE RecordWildCards, FlexibleInstances #-}

1+{-# LANGUAGE FlexibleContexts #-}

2+{-# LANGUAGE RecordWildCards, FlexibleInstances, DefaultSignatures #-}

35------------------------------------------------------------------------------

46-- |

@@ -27,7 +29,7 @@ module Database.PostgreSQL.Simple.FromRow

2729 ) where

2830

2931import Prelude hiding (null)

30−import Control.Applicative (Applicative(..), (<$>), (<|>), (*>))

32+import Control.Applicative (Applicative(..), (<$>), (<|>), (*>), liftA2)

3133import Control.Monad (replicateM, replicateM_)

3234import Control.Monad.Trans.State.Strict

3335import Control.Monad.Trans.Reader

@@ -45,13 +47,17 @@ import Database.PostgreSQL.Simple.Ok

4547import Database.PostgreSQL.Simple.Types ((:.)(..), Null)

4648import Database.PostgreSQL.Simple.TypeInfo

4749

50+import GHC.Generics

51+

52+

4853-- | A collection type that can be converted from a sequence of fields.

4954-- Instances are provided for tuples up to 10 elements and lists of any length.

5055--

5156-- Note that instances can be defined outside of postgresql-simple, which is

5257-- often useful. For example, here's an instance for a user-defined pair:

5358--

54−-- @data User = User { name :: String, fileQuota :: Int }

59+-- @

60+-- data User = User { name :: String, fileQuota :: Int }

5561--

5662-- instance 'FromRow' User where

5763-- fromRow = User \<$\> 'field' \<*\> 'field'

@@ -61,13 +67,32 @@ import Database.PostgreSQL.Simple.TypeInfo

6167-- in a single row of the query result. Otherwise, a 'ConversionFailed'

6268-- exception will be thrown.

6369--

64−-- Note that 'field' evaluates it's result to WHNF, so the caveats listed in

70+-- You can also derive 'FromRow' for your data type using GHC generics, like

71+-- this:

72+--

73+-- @

74+-- \{-# LANGUAGE DeriveAnyClass \#-}

75+-- \{-# LANGUAGE DeriveGeneric \#-}

76+--

77+-- import "GHC.Generics" ('GHC.Generics.Generic')

78+-- import "Database.PostgreSQL.Simple" ('FromRow')

79+--

80+-- data User = User { name :: String, fileQuota :: Int }

81+-- deriving ('GHC.Generics.Generic', 'FromRow')

82+-- @

83+--

84+-- Note that this only works for product types (e.g. records) and does not

85+-- support sum types or recursive types.

86+--

87+-- Note that 'field' evaluates its result to WHNF, so the caveats listed in

6588-- mysql-simple and very early versions of postgresql-simple no longer apply.

6689-- Instead, look at the caveats associated with user-defined implementations

6790-- of 'fromField'.

6891

6992class FromRow a where

7093 fromRow :: RowParser a

94+ default fromRow :: (Generic a, GFromRow (Rep a)) => RowParser a

95+ fromRow = to <$> gfromRow

7196

7297getvalue :: PQ.Result -> PQ.Row -> PQ.Column -> Maybe ByteString

7398getvalue result row col = unsafeDupablePerformIO (PQ.getvalue' result row col)

@@ -106,8 +131,8 @@ fieldWith fieldP = RP $ do

106131 else do

107132 let !result = rowresult

108133 !typeOid = unsafeDupablePerformIO (PQ.ftype result column)

109− !field = Field{..}

110− lift (lift (fieldP field (getvalue result row column)))

134+ !field' = Field{..}

135+ lift (lift (fieldP field' (getvalue result row column)))

111136

112137field :: FromField a => RowParser a

113138field = fieldWith fromField

@@ -230,6 +255,196 @@ instance (FromField a, FromField b, FromField c, FromField d, FromField e,

230255 null *> null *> null *> null *> null *> pure Nothing)

231256 <|> (Just <$> fromRow)

232257

258+instance (FromField a, FromField b, FromField c, FromField d, FromField e,

259+ FromField f, FromField g, FromField h, FromField i, FromField j,

260+ FromField k) =>

261+ FromRow (a,b,c,d,e,f,g,h,i,j,k) where

262+ fromRow = (,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field

263+ <*> field <*> field <*> field <*> field <*> field

264+ <*> field

265+

266+instance (FromField a, FromField b, FromField c, FromField d, FromField e,

267+ FromField f, FromField g, FromField h, FromField i, FromField j,

268+ FromField k) =>

269+ FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k)) where

270+ fromRow = (null *> null *> null *> null *> null *>

271+ null *> null *> null *> null *> null *>

272+ null *> pure Nothing)

273+ <|> (Just <$> fromRow)

274+

275+instance (FromField a, FromField b, FromField c, FromField d, FromField e,

276+ FromField f, FromField g, FromField h, FromField i, FromField j,

277+ FromField k, FromField l) =>

278+ FromRow (a,b,c,d,e,f,g,h,i,j,k,l) where

279+ fromRow = (,,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field

280+ <*> field <*> field <*> field <*> field <*> field

281+ <*> field <*> field

282+

283+instance (FromField a, FromField b, FromField c, FromField d, FromField e,

284+ FromField f, FromField g, FromField h, FromField i, FromField j,

285+ FromField k, FromField l) =>

286+ FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l)) where

287+ fromRow = (null *> null *> null *> null *> null *>

288+ null *> null *> null *> null *> null *>

289+ null *> null *> pure Nothing)

290+ <|> (Just <$> fromRow)

291+

292+instance (FromField a, FromField b, FromField c, FromField d, FromField e,

293+ FromField f, FromField g, FromField h, FromField i, FromField j,

294+ FromField k, FromField l, FromField m) =>

295+ FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m) where

296+ fromRow = (,,,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field

297+ <*> field <*> field <*> field <*> field <*> field

298+ <*> field <*> field <*> field

299+

300+instance (FromField a, FromField b, FromField c, FromField d, FromField e,

301+ FromField f, FromField g, FromField h, FromField i, FromField j,

302+ FromField k, FromField l, FromField m) =>

303+ FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l,m)) where

304+ fromRow = (null *> null *> null *> null *> null *>

305+ null *> null *> null *> null *> null *>

306+ null *> null *> null *> pure Nothing)

307+ <|> (Just <$> fromRow)

308+

309+instance (FromField a, FromField b, FromField c, FromField d, FromField e,

310+ FromField f, FromField g, FromField h, FromField i, FromField j,

311+ FromField k, FromField l, FromField m, FromField n) =>

312+ FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n) where

313+ fromRow = (,,,,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field

314+ <*> field <*> field <*> field <*> field <*> field

315+ <*> field <*> field <*> field <*> field

316+

317+instance (FromField a, FromField b, FromField c, FromField d, FromField e,

318+ FromField f, FromField g, FromField h, FromField i, FromField j,

319+ FromField k, FromField l, FromField m, FromField n) =>

320+ FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l,m,n)) where

321+ fromRow = (null *> null *> null *> null *> null *>

322+ null *> null *> null *> null *> null *>

323+ null *> null *> null *> null *> pure Nothing)

324+ <|> (Just <$> fromRow)

325+

326+instance (FromField a, FromField b, FromField c, FromField d, FromField e,

327+ FromField f, FromField g, FromField h, FromField i, FromField j,

328+ FromField k, FromField l, FromField m, FromField n, FromField o) =>

329+ FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) where

330+ fromRow = (,,,,,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field

331+ <*> field <*> field <*> field <*> field <*> field

332+ <*> field <*> field <*> field <*> field <*> field

333+

334+instance (FromField a, FromField b, FromField c, FromField d, FromField e,

335+ FromField f, FromField g, FromField h, FromField i, FromField j,

336+ FromField k, FromField l, FromField m, FromField n, FromField o) =>

337+ FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o)) where

338+ fromRow = (null *> null *> null *> null *> null *>

339+ null *> null *> null *> null *> null *>

340+ null *> null *> null *> null *> null *> pure Nothing)

341+ <|> (Just <$> fromRow)

342+

343+instance (FromField a, FromField b, FromField c, FromField d, FromField e,

344+ FromField f, FromField g, FromField h, FromField i, FromField j,

345+ FromField k, FromField l, FromField m, FromField n, FromField o,

346+ FromField p) =>

347+ FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) where

348+ fromRow = (,,,,,,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field

349+ <*> field <*> field <*> field <*> field <*> field

350+ <*> field <*> field <*> field <*> field <*> field

351+ <*> field

352+

353+instance (FromField a, FromField b, FromField c, FromField d, FromField e,

354+ FromField f, FromField g, FromField h, FromField i, FromField j,

355+ FromField k, FromField l, FromField m, FromField n, FromField o,

356+ FromField p) =>

357+ FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p)) where

358+ fromRow = (null *> null *> null *> null *> null *>

359+ null *> null *> null *> null *> null *>

360+ null *> null *> null *> null *> null *>

361+ null *> pure Nothing)

362+ <|> (Just <$> fromRow)

363+

364+instance (FromField a, FromField b, FromField c, FromField d, FromField e,

365+ FromField f, FromField g, FromField h, FromField i, FromField j,

366+ FromField k, FromField l, FromField m, FromField n, FromField o,

367+ FromField p, FromField q) =>

368+ FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q) where

369+ fromRow = (,,,,,,,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field

370+ <*> field <*> field <*> field <*> field <*> field

371+ <*> field <*> field <*> field <*> field <*> field

372+ <*> field <*> field

373+

374+instance (FromField a, FromField b, FromField c, FromField d, FromField e,

375+ FromField f, FromField g, FromField h, FromField i, FromField j,

376+ FromField k, FromField l, FromField m, FromField n, FromField o,

377+ FromField p, FromField q) =>

378+ FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q)) where

379+ fromRow = (null *> null *> null *> null *> null *>

380+ null *> null *> null *> null *> null *>

381+ null *> null *> null *> null *> null *>

382+ null *> null *> pure Nothing)

383+ <|> (Just <$> fromRow)

384+

385+instance (FromField a, FromField b, FromField c, FromField d, FromField e,

386+ FromField f, FromField g, FromField h, FromField i, FromField j,

387+ FromField k, FromField l, FromField m, FromField n, FromField o,

388+ FromField p, FromField q, FromField r) =>

389+ FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r) where

390+ fromRow = (,,,,,,,,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field

391+ <*> field <*> field <*> field <*> field <*> field

392+ <*> field <*> field <*> field <*> field <*> field

393+ <*> field <*> field <*> field

394+

395+instance (FromField a, FromField b, FromField c, FromField d, FromField e,

396+ FromField f, FromField g, FromField h, FromField i, FromField j,

397+ FromField k, FromField l, FromField m, FromField n, FromField o,

398+ FromField p, FromField q, FromField r) =>

399+ FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r)) where

400+ fromRow = (null *> null *> null *> null *> null *>

401+ null *> null *> null *> null *> null *>

402+ null *> null *> null *> null *> null *>

403+ null *> null *> null *> pure Nothing)

404+ <|> (Just <$> fromRow)

405+

406+instance (FromField a, FromField b, FromField c, FromField d, FromField e,

407+ FromField f, FromField g, FromField h, FromField i, FromField j,

408+ FromField k, FromField l, FromField m, FromField n, FromField o,

409+ FromField p, FromField q, FromField r, FromField s) =>

410+ FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s) where

411+ fromRow = (,,,,,,,,,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field

412+ <*> field <*> field <*> field <*> field <*> field

413+ <*> field <*> field <*> field <*> field <*> field

414+ <*> field <*> field <*> field <*> field

415+

416+instance (FromField a, FromField b, FromField c, FromField d, FromField e,

417+ FromField f, FromField g, FromField h, FromField i, FromField j,

418+ FromField k, FromField l, FromField m, FromField n, FromField o,

419+ FromField p, FromField q, FromField r, FromField s) =>

420+ FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s)) where

421+ fromRow = (null *> null *> null *> null *> null *>

422+ null *> null *> null *> null *> null *>

423+ null *> null *> null *> null *> null *>

424+ null *> null *> null *> null *> pure Nothing)

425+ <|> (Just <$> fromRow)

426+

427+instance (FromField a, FromField b, FromField c, FromField d, FromField e,

428+ FromField f, FromField g, FromField h, FromField i, FromField j,

429+ FromField k, FromField l, FromField m, FromField n, FromField o,

430+ FromField p, FromField q, FromField r, FromField s, FromField t) =>

431+ FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t) where

432+ fromRow = (,,,,,,,,,,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field

433+ <*> field <*> field <*> field <*> field <*> field

434+ <*> field <*> field <*> field <*> field <*> field

435+ <*> field <*> field <*> field <*> field <*> field

436+

437+instance (FromField a, FromField b, FromField c, FromField d, FromField e,

438+ FromField f, FromField g, FromField h, FromField i, FromField j,

439+ FromField k, FromField l, FromField m, FromField n, FromField o,

440+ FromField p, FromField q, FromField r, FromField s, FromField t) =>

441+ FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t)) where

442+ fromRow = (null *> null *> null *> null *> null *>

443+ null *> null *> null *> null *> null *>

444+ null *> null *> null *> null *> null *>

445+ null *> null *> null *> null *> null *> pure Nothing)

446+ <|> (Just <$> fromRow)

447+

233448instance FromField a => FromRow [a] where

234449 fromRow = do

235450 n <- numFieldsRemaining

@@ -252,3 +467,21 @@ instance FromField a => FromRow (Maybe (Vector a)) where

252467

253468instance (FromRow a, FromRow b) => FromRow (a :. b) where

254469 fromRow = (:.) <$> fromRow <*> fromRow

470+

471+

472+

473+-- Type class for default implementation of FromRow using generics

474+class GFromRow f where

475+ gfromRow :: RowParser (f p)

476+

477+instance GFromRow f => GFromRow (M1 c i f) where

478+ gfromRow = M1 <$> gfromRow

479+

480+instance (GFromRow f, GFromRow g) => GFromRow (f :*: g) where

481+ gfromRow = liftA2 (:*:) gfromRow gfromRow

482+

483+instance (FromField a) => GFromRow (K1 R a) where

484+ gfromRow = K1 <$> field

485+

486+instance GFromRow U1 where

487+ gfromRow = pure U1

src/Database/PostgreSQL/Simple/HStore.hs+3−2

@@ -8,14 +8,14 @@

88--

99-- Parsers and printers for hstore, a extended type bundled with

1010-- PostgreSQL providing finite maps from text strings to text strings.

11−-- See <http://www.postgresql.org/docs/9.2/static/hstore.html> for more

11+-- See <https://www.postgresql.org/docs/9.5/static/hstore.html> for more

1212-- information.

1313--

1414-- Note that in order to use this type, a database superuser must

1515-- install it by running a sql script in the share directory. This

1616-- can be done on PostgreSQL 9.1 and later with the command

1717-- @CREATE EXTENSION hstore@. See

18−-- <http://www.postgresql.org/docs/9.2/static/contrib.html> for more

18+-- <https://www.postgresql.org/docs/9.5/static/contrib.html> for more

1919-- information.

2020--

2121------------------------------------------------------------------------------

@@ -28,6 +28,7 @@ module Database.PostgreSQL.Simple.HStore

2828 , toBuilder

2929 , toLazyByteString

3030 , hstore

31+ , parseHStoreList

3132 , ToHStoreText(..)

3233 , HStoreText

3334 ) where

src/Database/PostgreSQL/Simple/HStore/Implementation.hs+27−21

@@ -15,17 +15,13 @@

1515module Database.PostgreSQL.Simple.HStore.Implementation where

1616

1717import Control.Applicative

18−import Blaze.ByteString.Builder as Blaze

19− ( Builder, toLazyByteString, copyByteString )

20−import Blaze.ByteString.Builder.Char8 (fromChar)

2118import qualified Data.Attoparsec.ByteString as P

2219import qualified Data.Attoparsec.ByteString.Char8 as P (isSpace_w8)

2320import qualified Data.ByteString as BS

21+import Data.ByteString.Builder (Builder, byteString, char8)

22+import qualified Data.ByteString.Builder as BU

2423import Data.ByteString.Internal (c2w, w2c)

2524import qualified Data.ByteString.Lazy as BL

26−#if !MIN_VERSION_bytestring(0,10,0)

27−import qualified Data.ByteString.Lazy.Internal as BL (foldrChunks)

28−#endif

2925import Data.Map(Map)

3026import qualified Data.Map as Map

3127import Data.Text(Text)

@@ -35,6 +31,7 @@ import Data.Text.Encoding.Error(UnicodeException)

3531import qualified Data.Text.Lazy as TL

3632import Data.Typeable

3733import Data.Monoid(Monoid(..))

34+import Data.Semigroup

3835import Database.PostgreSQL.Simple.FromField

3936import Database.PostgreSQL.Simple.ToField

4037

@@ -53,26 +50,28 @@ instance ToHStore HStoreBuilder where

5350toBuilder :: HStoreBuilder -> Builder

5451toBuilder x = case x of

5552 Empty -> mempty

56− Comma x -> x

53+ Comma c -> c

5754

5855toLazyByteString :: HStoreBuilder -> BL.ByteString

5956toLazyByteString x = case x of

6057 Empty -> BL.empty

61− Comma x -> Blaze.toLazyByteString x

58+ Comma c -> BU.toLazyByteString c

6259

63−instance Monoid HStoreBuilder where

64− mempty = Empty

65− mappend Empty x = x

66− mappend (Comma a) x

60+instance Semigroup HStoreBuilder where

61+ Empty <> x = x

62+ Comma a <> x

6763 = Comma (a `mappend` case x of

6864 Empty -> mempty

69− Comma b -> fromChar ',' `mappend` b)

65+ Comma b -> char8 ',' `mappend` b)

66+

67+instance Monoid HStoreBuilder where

68+ mempty = Empty

7069

7170class ToHStoreText a where

7271 toHStoreText :: a -> HStoreText

7372

7473-- | Represents escape text, ready to be the key or value to a hstore value

75−newtype HStoreText = HStoreText Builder deriving (Typeable, Monoid)

74+newtype HStoreText = HStoreText Builder deriving (Typeable, Semigroup, Monoid)

7675

7776instance ToHStoreText HStoreText where

7877 toHStoreText = id

@@ -95,24 +94,24 @@ escapeAppend :: BS.ByteString -> Builder -> Builder

9594escapeAppend = loop

9695 where

9796 loop (BS.break quoteNeeded -> (a,b)) rest

98− = copyByteString a `mappend`

97+ = byteString a `mappend`

9998 case BS.uncons b of

10099 Nothing -> rest

101100 Just (c,d) -> quoteChar c `mappend` loop d rest

102101

103102 quoteNeeded c = c == c2w '\"' || c == c2w '\\'

104103 quoteChar c

105− | c == c2w '\"' = copyByteString "\\\""

106− | otherwise = copyByteString "\\\\"

104+ | c == c2w '\"' = byteString "\\\""

105+ | otherwise = byteString "\\\\"

107106

108107hstore :: (ToHStoreText a, ToHStoreText b) => a -> b -> HStoreBuilder

109108hstore (toHStoreText -> (HStoreText key)) (toHStoreText -> (HStoreText val)) =

110− Comma (fromChar '"' `mappend` key `mappend` copyByteString "\"=>\""

111− `mappend` val `mappend` fromChar '"')

109+ Comma (char8 '"' `mappend` key `mappend` byteString "\"=>\""

110+ `mappend` val `mappend` char8 '"')

112111

113112instance ToField HStoreBuilder where

114113 toField Empty = toField (BS.empty)

115− toField (Comma x) = toField (Blaze.toLazyByteString x)

114+ toField (Comma x) = toField (BU.toLazyByteString x)

116115

117116newtype HStoreList = HStoreList {fromHStoreList :: [(Text,Text)]} deriving (Typeable, Show)

118117

@@ -145,7 +144,7 @@ newtype HStoreMap = HStoreMap {fromHStoreMap :: Map Text Text} deriving (Eq, Or

145144

146145instance ToHStore HStoreMap where

147146 toHStore (HStoreMap xs) = Map.foldrWithKey f mempty xs

148− where f k v xs = hstore k v `mappend` xs

147+ where f k v xs' = hstore k v `mappend` xs'

149148

150149instance ToField HStoreMap where

151150 toField xs = toField (toHStore xs)

@@ -154,6 +153,13 @@ instance FromField HStoreMap where

154153 fromField f mdat = convert <$> fromField f mdat

155154 where convert (HStoreList xs) = HStoreMap (Map.fromList xs)

156155

156+parseHStoreList :: BS.ByteString -> Either String HStoreList

157+parseHStoreList dat =

158+ case P.parseOnly (parseHStore <* P.endOfInput) dat of

159+ Left err -> Left (show err)

160+ Right (Left err) -> Left (show err)

161+ Right (Right val) -> Right val

162+

157163parseHStore :: P.Parser (Either UnicodeException HStoreList)

158164parseHStore = do

159165 kvs <- P.sepBy' (skipWhiteSpace *> parseHStoreKeyVal)

src/Database/PostgreSQL/Simple/HStore/Internal.hs−2

@@ -1,5 +1,3 @@

1−{-# OPTIONS_HADDOCK hide #-}

2−

31------------------------------------------------------------------------------

42-- |

53-- Module: Database.PostgreSQL.Simple.HStore.Internal

src/Database/PostgreSQL/Simple/Internal.hs+167−23

@@ -1,10 +1,13 @@

11{-# LANGUAGE CPP, BangPatterns, DoAndIfThenElse, RecordWildCards #-}

2−{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}

2+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}

3+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4+{-# LANGUAGE ExistentialQuantification #-}

5+{-# LANGUAGE InstanceSigs #-}

47------------------------------------------------------------------------------

58-- |

69-- Module: Database.PostgreSQL.Simple.Internal

811-- License: BSD3

912-- Maintainer: Leon P Smith <leon@melding-monads.com>

1013-- Stability: experimental

@@ -25,24 +28,31 @@ import Control.Exception

2528import Control.Concurrent.MVar

2629import Control.Monad(MonadPlus(..))

2730import Data.ByteString(ByteString)

31+import qualified Data.ByteString as B

2832import qualified Data.ByteString.Char8 as B8

33+import Data.ByteString.Builder ( Builder, byteString )

2934import Data.Char (ord)

3035import Data.Int (Int64)

3136import qualified Data.IntMap as IntMap

3237import Data.IORef

3338import Data.Maybe(fromMaybe)

3439import Data.String

40+import qualified Data.Text as T

41+import qualified Data.Text.Encoding as TE

3542import Data.Typeable

3643import Data.Word

3744import Database.PostgreSQL.LibPQ(Oid(..))

3845import qualified Database.PostgreSQL.LibPQ as PQ

3946import Database.PostgreSQL.LibPQ(ExecStatus(..))

47+import Database.PostgreSQL.Simple.Compat ( toByteString )

4048import Database.PostgreSQL.Simple.Ok

49+import Database.PostgreSQL.Simple.ToField (Action(..), inQuotes)

4150import Database.PostgreSQL.Simple.Types (Query(..))

4251import Database.PostgreSQL.Simple.TypeInfo.Types(TypeInfo)

4352import Control.Monad.Trans.State.Strict

4453import Control.Monad.Trans.Reader

4554import Control.Monad.Trans.Class

55+import GHC.Generics

4656import GHC.IO.Exception

4757#if !defined(mingw32_HOST_OS)

4858import Control.Concurrent(threadWaitRead, threadWaitWrite)

@@ -68,7 +78,29 @@ data Connection = Connection {

6878 connectionHandle :: {-# UNPACK #-} !(MVar PQ.Connection)

6979 , connectionObjects :: {-# UNPACK #-} !(MVar TypeInfoCache)

7080 , connectionTempNameCounter :: {-# UNPACK #-} !(IORef Int64)

71− }

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

72104

73105data SqlError = SqlError {

74106 sqlState :: ByteString

@@ -76,12 +108,15 @@ data SqlError = SqlError {

76108 , sqlErrorMsg :: ByteString

77109 , sqlErrorDetail :: ByteString

78110 , sqlErrorHint :: ByteString

79− } deriving (Show, Typeable)

111+ } deriving (Eq, Show, Typeable)

80112

81113fatalError :: ByteString -> SqlError

82114fatalError msg = SqlError "" FatalError msg "" ""

83115

84−instance Exception SqlError

116+instance Exception SqlError where

117+ toException = postgresqlExceptionToException

118+ fromException = postgresqlExceptionFromException

119+

85120

86121-- | Exception thrown if 'query' is used to perform an @INSERT@-like

87122-- operation, or 'execute' is used to perform a @SELECT@-like operation.

@@ -90,7 +125,22 @@ data QueryError = QueryError {

90125 , qeQuery :: Query

91126 } deriving (Eq, Show, Typeable)

92127

93−instance Exception QueryError

128+instance Exception QueryError where

129+ toException = postgresqlExceptionToException

130+ fromException = postgresqlExceptionFromException

131+

132+-- | Exception thrown if a 'Query' could not be formatted correctly.

133+-- This may occur if the number of \'@?@\' characters in the query

134+-- string does not match the number of parameters provided.

135+data FormatError = FormatError {

136+ fmtMessage :: String

137+ , fmtQuery :: Query

138+ , fmtParams :: [ByteString]

139+ } deriving (Eq, Show, Typeable)

140+

141+instance Exception FormatError where

142+ toException = postgresqlExceptionToException

143+ fromException = postgresqlExceptionFromException

94144

95145data ConnectInfo = ConnectInfo {

96146 connectHost :: String

@@ -98,7 +148,7 @@ data ConnectInfo = ConnectInfo {

98148 , connectUser :: String

99149 , connectPassword :: String

100150 , connectDatabase :: String

101− } deriving (Eq,Read,Show,Typeable)

151+ } deriving (Generic,Eq,Read,Show,Typeable)

102152

103153-- | Default information for setting up a connection.

104154--

@@ -132,10 +182,20 @@ defaultConnectInfo = ConnectInfo {

132182connect :: ConnectInfo -> IO Connection

133183connect = connectPostgreSQL . postgreSQLConnectionString

134184

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+

135191-- | Attempt to make a connection based on a libpq connection string.

136−-- See <http://www.postgresql.org/docs/9.3/static/libpq-connect.html>

137−-- for more information. Here is an example with some

138−-- of the most commonly used parameters:

192+-- See <https://www.postgresql.org/docs/9.5/static/libpq-connect.html#LIBPQ-CONNSTRING>

193+-- for more information. Also note that environment variables also affect

194+-- parameters not provided, parameters provided as the empty string, and a

195+-- few other things; see

196+-- <https://www.postgresql.org/docs/9.5/static/libpq-envars.html>

197+-- for details. Here is an example with some of the most commonly used

198+-- parameters:

139199--

140200-- > host='db.somedomain.com' port=5432 ...

141201--

@@ -163,8 +223,9 @@ connect = connectPostgreSQL . postgreSQLConnectionString

163223--

164224-- Omitting @password@ will default to an appropriate password found

165225-- in the @pgpass@ file, or no password at all if a matching line is

166−-- not found. See

167−-- <http://www.postgresql.org/docs/9.3/static/libpq-pgpass.html> for

226+-- not found. The path of the @pgpass@ file may be specified by setting

227+-- the @PGPASSFILE@ environment variable. See

228+-- <https://www.postgresql.org/docs/9.5/static/libpq-pgpass.html> for

168229-- more information regarding this file.

169230--

170231-- As all parameters are optional and the defaults are sensible, the

@@ -182,8 +243,20 @@ connect = connectPostgreSQL . postgreSQLConnectionString

182243-- or production machines, or you will need to use a @pgpass@ file

183244-- with the @password@ or @md5@ authentication methods.

184245--

185−-- See <http://www.postgresql.org/docs/9.3/static/client-authentication.html>

246+-- See <https://www.postgresql.org/docs/9.5/static/client-authentication.html>

186247-- 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.

187260

188261connectPostgreSQL :: ByteString -> IO Connection

189262connectPostgreSQL connstr = do

@@ -197,8 +270,8 @@ connectPostgreSQL connstr = do

197270 let wconn = Connection{..}

198271 version <- PQ.serverVersion conn

199272 let settings

200− | version < 80200 = "SET datestyle TO ISO"

201− | otherwise = "SET standard_conforming_strings TO on;SET datestyle TO ISO"

273+ | version < 80200 = "SET datestyle TO ISO;SET client_encoding TO UTF8"

274+ | otherwise = "SET datestyle TO ISO;SET client_encoding TO UTF8;SET standard_conforming_strings TO on"

202275 _ <- execute_ wconn settings

203276 return wconn

204277 _ -> do

@@ -250,7 +323,7 @@ postgreSQLConnectionString connectInfo = fromString connstr

250323

251324 str name field

252325 | null value = id

253− | otherwise = showString name . quote value . space

326+ | otherwise = showString name . addQuotes value . space

254327 where value = field connectInfo

255328

256329 num name field

@@ -258,7 +331,7 @@ postgreSQLConnectionString connectInfo = fromString connstr

258331 | otherwise = showString name . shows value . space

259332 where value = field connectInfo

260333

261− quote str rest = '\'' : foldr delta ('\'' : rest) str

334+ addQuotes s rest = '\'' : foldr delta ('\'' : rest) s

262335 where

263336 delta c cs = case c of

264337 '\\' -> '\\' : '\\' : cs

@@ -314,6 +387,7 @@ exec conn sql =

314387 Just res -> do

315388 status <- PQ.resultStatus res

316389 case status of

390+ -- FIXME: handle PQ.CopyBoth and PQ.SingleTuple

317391 PQ.EmptyQuery -> getResult h mres'

318392 PQ.CommandOk -> getResult h mres'

319393 PQ.TuplesOk -> getResult h mres'

@@ -334,6 +408,7 @@ finishExecute :: Connection -> Query -> PQ.Result -> IO Int64

334408finishExecute _conn q result = do

335409 status <- PQ.resultStatus result

336410 case status of

411+ -- FIXME: handle PQ.CopyBoth and PQ.SingleTuple

337412 PQ.EmptyQuery -> throwIO $ QueryError "execute: Empty query" q

338413 PQ.CommandOk -> do

339414 ncols <- PQ.nfields result

@@ -344,7 +419,7 @@ finishExecute _conn q result = do

344419 nstr <- PQ.cmdTuples result

345420 return $ case nstr of

346421 Nothing -> 0 -- is this appropriate?

347− Just str -> toInteger str

422+ Just str -> mkInteger str

348423 PQ.TuplesOk -> do

349424 ncols <- PQ.nfields result

350425 throwIO $ QueryError ("execute resulted in " ++ show ncols ++

@@ -357,7 +432,7 @@ finishExecute _conn q result = do

357432 PQ.NonfatalError -> throwResultError "execute" result status

358433 PQ.FatalError -> throwResultError "execute" result status

359434 where

360− toInteger str = B8.foldl' delta 0 str

435+ mkInteger str = B8.foldl' delta 0 str

361436 where

362437 delta acc c =

363438 if '0' <= c && c <= '9'

@@ -372,8 +447,8 @@ throwResultError _ result status = do

372447 PQ.resultErrorField result PQ.DiagMessageDetail

373448 hint <- fromMaybe "" <$>

374449 PQ.resultErrorField result PQ.DiagMessageHint

375− state <- maybe "" id <$> PQ.resultErrorField result PQ.DiagSqlstate

376− throwIO $ SqlError { sqlState = state

450+ state' <- maybe "" id <$> PQ.resultErrorField result PQ.DiagSqlstate

451+ throwIO $ SqlError { sqlState = state'

377452 , sqlExecStatus = status

378453 , sqlErrorMsg = errormsg

379454 , sqlErrorDetail = detail

@@ -442,7 +517,6 @@ instance Alternative Conversion where

442517 Errors _ -> (oka <|>) <$> runConversion mb conn

443518

444519instance Monad Conversion where

445− return a = Conversion $ \_conn -> return (return a)

446520 m >>= f = Conversion $ \conn -> do

447521 oka <- runConversion m conn

448522 case oka of

@@ -457,7 +531,7 @@ conversionMap :: (Ok a -> Ok b) -> Conversion a -> Conversion b

457531conversionMap f m = Conversion $ \conn -> f <$> runConversion m conn

458532

459533conversionError :: Exception err => err -> Conversion a

460−conversionError err = Conversion $ \_ -> return (Errors [SomeException err])

534+conversionError err = Conversion $ \_ -> return (Errors [toException err])

461535

462536newTempName :: Connection -> IO Query

463537newTempName Connection{..} = do

@@ -491,3 +565,73 @@ throwLibPQError :: PQ.Connection -> ByteString -> IO a

491565throwLibPQError conn default_desc = do

492566 msg <- maybe default_desc id <$> PQ.errorMessage conn

493567 throwIO $! libPQError msg

568+

569+

570+fmtError :: String -> Query -> [Action] -> a

571+fmtError msg q xs = throw FormatError {

572+ fmtMessage = msg

573+ , fmtQuery = q

574+ , fmtParams = map twiddle xs

575+ }

576+ where twiddle (Plain b) = toByteString b

577+ twiddle (Escape s) = s

578+ twiddle (EscapeByteA s) = s

579+ twiddle (EscapeIdentifier s) = s

580+ twiddle (Many ys) = B.concat (map twiddle ys)

581+

582+fmtErrorBs :: Query -> [Action] -> ByteString -> a

583+fmtErrorBs q xs msg = fmtError (T.unpack $ TE.decodeUtf8 msg) q xs

584+

585+-- | Quote bytestring or throw 'FormatError'

586+quote :: Query -> [Action] -> Either ByteString ByteString -> Builder

587+quote q xs = either (fmtErrorBs q xs) (inQuotes . byteString)

588+

589+buildAction :: Connection -- ^ Connection for string escaping

590+ -> Query -- ^ Query for message error

591+ -> [Action] -- ^ List of parameters for message error

592+ -> Action -- ^ Action to build

593+ -> IO Builder

594+buildAction _ _ _ (Plain b) = pure b

595+buildAction conn q xs (Escape s) = quote q xs <$> escapeStringConn conn s

596+buildAction conn q xs (EscapeByteA s) = quote q xs <$> escapeByteaConn conn s

597+buildAction conn q xs (EscapeIdentifier s) =

598+ either (fmtErrorBs q xs) byteString <$> escapeIdentifier conn s

599+buildAction conn q xs (Many ys) =

600+ mconcat <$> mapM (buildAction conn q xs) ys

601+

602+checkError :: PQ.Connection -> Maybe a -> IO (Either ByteString a)

603+checkError _ (Just x) = return $ Right x

604+checkError c Nothing = Left . maybe "" id <$> PQ.errorMessage c

605+

606+escapeWrap :: (PQ.Connection -> ByteString -> IO (Maybe ByteString))

607+ -> Connection

608+ -> ByteString

609+ -> IO (Either ByteString ByteString)

610+escapeWrap f conn s =

611+ withConnection conn $ \c ->

612+ f c s >>= checkError c

613+

614+escapeStringConn :: Connection -> ByteString -> IO (Either ByteString ByteString)

615+escapeStringConn = escapeWrap PQ.escapeStringConn

616+

617+escapeIdentifier :: Connection -> ByteString -> IO (Either ByteString ByteString)

618+escapeIdentifier = escapeWrap PQ.escapeIdentifier

619+

620+escapeByteaConn :: Connection -> ByteString -> IO (Either ByteString ByteString)

621+escapeByteaConn = escapeWrap PQ.escapeByteaConn

622+

623+breakOnSingleQuestionMark :: ByteString -> (ByteString, ByteString)

624+breakOnSingleQuestionMark b = go (B8.empty, b)

625+ where go (x,bs) = (x `B8.append` x',bs')

626+ -- seperate from first QM

627+ where tup@(noQ, restWithQ) = B8.break (=='?') bs

628+ -- if end of query, just return

629+ -- else check for second QM in 'go2'

630+ (x', bs') = maybe tup go2 $

631+ -- drop found QM and peek at next char

632+ B8.uncons restWithQ >>= B8.uncons . snd

633+ -- another QM after the first means:

634+ -- take literal QM and keep going.

635+ go2 ('?', t2) = go (noQ `B8.snoc` '?',t2)

636+ -- Anything else means

637+ go2 _ = tup

src/Database/PostgreSQL/Simple/Internal/PQResultUtils.hsnew file+123

@@ -0,0 +1,123 @@

1+{-# LANGUAGE CPP #-}

3+------------------------------------------------------------------------------

4+-- |

5+-- Module: Database.PostgreSQL.Simple.Internal.PQResultUtils

8+-- License: BSD3

9+-- Maintainer: Leon P Smith <leon@melding-monads.com>

10+-- Stability: experimental

11+--

12+------------------------------------------------------------------------------

13+

14+

15+module Database.PostgreSQL.Simple.Internal.PQResultUtils

16+ ( finishQueryWith

17+ , finishQueryWithV

18+ , finishQueryWithVU

19+ , getRowWith

20+ ) where

21+

22+import Control.Exception as E

23+import Data.ByteString (ByteString)

24+import Data.Foldable (for_)

25+import Database.PostgreSQL.Simple.FromField (ResultError(..))

26+import Database.PostgreSQL.Simple.Ok

27+import Database.PostgreSQL.Simple.Types (Query(..))

28+import Database.PostgreSQL.Simple.Internal as Base hiding (result, row)

29+import Database.PostgreSQL.Simple.TypeInfo

30+import qualified Database.PostgreSQL.LibPQ as PQ

31+import qualified Data.ByteString.Char8 as B

32+import qualified Data.Vector as V

33+import qualified Data.Vector.Mutable as MV

34+import qualified Data.Vector.Unboxed as VU

35+import qualified Data.Vector.Unboxed.Mutable as MVU

36+import Control.Monad.Trans.Reader

37+import Control.Monad.Trans.State.Strict

38+

39+finishQueryWith :: RowParser r -> Connection -> Query -> PQ.Result -> IO [r]

40+finishQueryWith parser conn q result = finishQueryWith' q result $ do

41+ nrows <- PQ.ntuples result

42+ ncols <- PQ.nfields result

43+ forM' 0 (nrows-1) $ \row ->

44+ getRowWith parser row ncols conn result

45+

46+finishQueryWithV :: RowParser r -> Connection -> Query -> PQ.Result -> IO (V.Vector r)

47+finishQueryWithV parser conn q result = finishQueryWith' q result $ do

48+ nrows <- PQ.ntuples result

49+ let PQ.Row nrows' = nrows

50+ ncols <- PQ.nfields result

51+ mv <- MV.unsafeNew (fromIntegral nrows')

52+ for_ [ 0 .. nrows-1 ] $ \row -> do

53+ let PQ.Row row' = row

54+ value <- getRowWith parser row ncols conn result

55+ MV.unsafeWrite mv (fromIntegral row') value

56+ V.unsafeFreeze mv

57+

58+finishQueryWithVU :: VU.Unbox r => RowParser r -> Connection -> Query -> PQ.Result -> IO (VU.Vector r)

59+finishQueryWithVU parser conn q result = finishQueryWith' q result $ do

60+ nrows <- PQ.ntuples result

61+ let PQ.Row nrows' = nrows

62+ ncols <- PQ.nfields result

63+ mv <- MVU.unsafeNew (fromIntegral nrows')

64+ for_ [ 0 .. nrows-1 ] $ \row -> do

65+ let PQ.Row row' = row

66+ value <- getRowWith parser row ncols conn result

67+ MVU.unsafeWrite mv (fromIntegral row') value

68+ VU.unsafeFreeze mv

69+

70+finishQueryWith' :: Query -> PQ.Result -> IO a -> IO a

71+finishQueryWith' q result k = do

72+ status <- PQ.resultStatus result

73+ case status of

74+ PQ.TuplesOk -> k

75+ PQ.EmptyQuery -> queryErr "query: Empty query"

76+ PQ.CommandOk -> queryErr "query resulted in a command response (did you mean to use `execute` or forget a RETURNING?)"

77+ PQ.CopyOut -> queryErr "query: COPY TO is not supported"

78+ PQ.CopyIn -> queryErr "query: COPY FROM is not supported"

79+ PQ.CopyBoth -> queryErr "query: COPY BOTH is not supported"

80+ PQ.SingleTuple -> queryErr "query: single-row mode is not supported"

81+ PQ.BadResponse -> throwResultError "query" result status

82+ PQ.NonfatalError -> throwResultError "query" result status

83+ PQ.FatalError -> throwResultError "query" result status

84+ where

85+ queryErr msg = throwIO $ QueryError msg q

86+

87+getRowWith :: RowParser r -> PQ.Row -> PQ.Column -> Connection -> PQ.Result -> IO r

88+getRowWith parser row ncols conn result = do

89+ let rw = Row row result

90+ let unCol (PQ.Col x) = fromIntegral x :: Int

91+ okvc <- runConversion (runStateT (runReaderT (unRP parser) rw) 0) conn

92+ case okvc of

93+ Ok (val,col) | col == ncols -> return val

94+ | otherwise -> do

95+ vals <- forM' 0 (ncols-1) $ \c -> do

96+ tinfo <- getTypeInfo conn =<< PQ.ftype result c

97+ v <- PQ.getvalue result row c

98+ return ( tinfo

99+ , fmap ellipsis v )

100+ throw (ConversionFailed

101+ (show (unCol ncols) ++ " values: " ++ show vals)

102+ Nothing

103+ ""

104+ (show (unCol col) ++ " slots in target type")

105+ "mismatch between number of columns to convert and number in target type")

106+ Errors [] -> throwIO $ ConversionFailed "" Nothing "" "" "unknown error"

107+ Errors [x] -> throwIO x

108+ Errors xs -> throwIO $ ManyErrors xs

109+

110+ellipsis :: ByteString -> ByteString

111+ellipsis bs

112+ | B.length bs > 15 = B.take 10 bs `B.append` "[...]"

113+ | otherwise = bs

114+

115+forM' :: (Ord n, Num n) => n -> n -> (n -> IO a) -> IO [a]

116+forM' lo hi m = loop hi []

117+ where

118+ loop !n !as

119+ | n < lo = return as

120+ | otherwise = do

121+ a <- m n

122+ loop (n-1) (a:as)

123+{-# INLINE forM' #-}

src/Database/PostgreSQL/Simple/LargeObjects.hs+2−2

@@ -7,14 +7,14 @@

77-- Maintainer : leon@melding-monads.com

88--

99-- Support for PostgreSQL's Large Objects; see

10−-- <http://www.postgresql.org/docs/9.1/static/largeobjects.html> for more

10+-- <https://www.postgresql.org/docs/9.5/static/largeobjects.html> for more

1111-- information.

1212--

1313-- Note that Large Object File Descriptors are only valid within a single

1414-- database transaction, so if you are interested in using anything beyond

1515-- 'loCreat', 'loCreate', and 'loUnlink', you will need to run the entire

1616-- sequence of functions in a transaction. As 'loImport' and 'loExport'

17−-- are simply C functions that call 'loCreat', 'loOpen', 'loRead', and

17+-- are simply C functions that call 'loCreat', 'loOpen', 'loRead', and

1818-- 'loWrite', and do not perform any transaction handling themselves,

1919-- they also need to be wrapped in an explicit transaction.

2020--

src/Database/PostgreSQL/Simple/Newtypes.hsnew file+49

@@ -0,0 +1,49 @@

1+{-# LANGUAGE DeriveFunctor #-}

2+{-# LANGUAGE DeriveDataTypeable #-}

3+-- | Module with newtypes suitable to usage with @DerivingVia@ or standalone.

4+--

5+-- The newtypes are named after packages they wrap.

6+module Database.PostgreSQL.Simple.Newtypes (

7+ Aeson (..), getAeson,

8+) where

10+import Data.Typeable (Typeable)

11+import Database.PostgreSQL.Simple.ToField (ToField (..))

12+import Database.PostgreSQL.Simple.FromField (FromField (..), fromJSONField)

13+

14+import qualified Data.Aeson as Aeson

15+

16+-------------------------------------------------------------------------------

17+-- aeson

18+-------------------------------------------------------------------------------

19+

20+-- | A newtype wrapper with 'ToField' and 'FromField' instances

21+-- based on 'Aeson.ToJSON' and 'Aeson.FromJSON' type classes from @aeson@.

22+--

23+-- Example using @DerivingVia@:

24+--

25+-- @

26+-- data Foo = Foo Int String

27+-- deriving stock (Eq, Show, Generic) -- GHC built int

28+-- deriving anyclass ('Aeson.FromJSON', 'Aeson.ToJSON') -- Derived using GHC Generics

29+-- deriving ('ToField', 'FromField') via 'Aeson' Foo -- DerivingVia

30+-- @

31+--

32+-- Example using 'Aeson' newtype directly, for more ad-hoc queries

33+--

34+-- @

35+-- execute conn "INSERT INTO tbl (fld) VALUES (?)" (Only ('Aeson' x))

36+-- @

37+--

38+-- @since 0.6.3

39+newtype Aeson a = Aeson a

40+ deriving (Eq, Show, Read, Typeable, Functor)

41+

42+getAeson :: Aeson a -> a

43+getAeson (Aeson a) = a

44+

45+instance Aeson.ToJSON a => ToField (Aeson a) where

46+ toField = toField . Aeson.encode . getAeson

47+

48+instance (Aeson.FromJSON a, Typeable a) => FromField (Aeson a) where

49+ fromField f bs = fmap Aeson (fromJSONField f bs)

src/Database/PostgreSQL/Simple/Notification.hs+62−32

@@ -5,7 +5,8 @@

55-----------------------------------------------------------------------------

66-- |

77-- Module : Database.PostgreSQL.Simple.Notification

910-- License : BSD3

1011--

1112-- Maintainer : leon@melding-monads.com

@@ -13,7 +14,7 @@

1314--

1415-- Support for receiving asynchronous notifications via PostgreSQL's

1516-- Listen/Notify mechanism. See

16−-- <http://www.postgresql.org/docs/9.1/static/sql-notify.html> for more

17+-- <https://www.postgresql.org/docs/9.5/static/sql-notify.html> for more

1718-- information.

1819--

1920-- Note that on Windows, @getNotification@ currently uses a polling loop

@@ -24,7 +25,7 @@

2425-- Notifications do not create any extra work for the backend, and are

2526-- likely cheaper on the client side as well.

2627--

27−-- <http://hackage.haskell.org/trac/ghc/ticket/7353>

28+-- <https://hackage.haskell.org/trac/ghc/ticket/7353>

2829--

2930-----------------------------------------------------------------------------

3031

@@ -35,19 +36,27 @@ module Database.PostgreSQL.Simple.Notification

3536 , getBackendPID

3637 ) where

3738

38−import Control.Concurrent

39−import Control.Monad ( when )

40−import Control.Exception ( throwIO )

39+import Control.Monad ( join, void )

40+import Control.Exception ( throwIO, catch )

4141import qualified Data.ByteString as B

42+import qualified Data.ByteString.Char8 as B8

4243import Database.PostgreSQL.Simple.Internal

4344import qualified Database.PostgreSQL.LibPQ as PQ

4445import System.Posix.Types ( CPid )

46+import GHC.IO.Exception ( ioe_location )

47+

48+#if defined(mingw32_HOST_OS)

49+import Control.Concurrent ( threadDelay )

50+#else

51+import GHC.Conc ( atomically )

52+import Control.Concurrent ( threadWaitReadSTM )

53+#endif

4554

4655data Notification = Notification

47− { notificationPid :: !CPid

48− , notificationChannel :: !B.ByteString

49− , notificationData :: !B.ByteString

50− }

56+ { notificationPid :: {-# UNPACK #-} !CPid

57+ , notificationChannel :: {-# UNPACK #-} !B.ByteString

58+ , notificationData :: {-# UNPACK #-} !B.ByteString

59+ } deriving (Show, Eq)

5160

5261convertNotice :: PQ.Notify -> Notification

5362convertNotice PQ.Notify{..}

@@ -57,35 +66,56 @@ convertNotice PQ.Notify{..}

5766

5867-- | Returns a single notification. If no notifications are available,

5968-- 'getNotification' blocks until one arrives.

69+--

70+-- It is safe to call 'getNotification' on a connection that is concurrently

71+-- being used for other purposes, note however that PostgreSQL does not

72+-- deliver notifications while a connection is inside a transaction.

6073

6174getNotification :: Connection -> IO Notification

62−getNotification conn = loop False

75+getNotification conn = join $ withConnection conn fetch

6376 where

6477 funcName = "Database.PostgreSQL.Simple.Notification.getNotification"

65− loop doConsume = do

66− res <- withConnection conn $ \c -> do

67− when doConsume (PQ.consumeInput c >> return ())

68− mmsg <- PQ.notifies c

69− case mmsg of

70− Nothing -> do

71− mfd <- PQ.socket c

72− case mfd of

73− Nothing -> throwIO $ fdError funcName

74− Just fd -> return (Left fd)

75− Just msg -> return (Right msg)

76− -- FIXME? what happens if the connection is closed/reset right here?

77− case res of

78+

79+ fetch c = do

80+ mmsg <- PQ.notifies c

81+ case mmsg of

82+ Just msg -> return (return $! convertNotice msg)

83+ Nothing -> do

84+ mfd <- PQ.socket c

85+ case mfd of

86+ Nothing -> return (throwIO $! fdError funcName)

7887#if defined(mingw32_HOST_OS)

79− -- threadWaitRead doesn't work for sockets on Windows, so just poll

80− -- for input every second (PQconsumeInput is non-blocking).

81− --

82− -- We could call select(), but FFI calls can't be interrupted with

83− -- async exceptions, whereas threadDelay can.

84− Left _fd -> threadDelay 1000000 >> loop True

88+ -- threadWaitRead doesn't work for sockets on Windows, so just

89+ -- poll for input every second (PQconsumeInput is non-blocking).

90+ --

91+ -- We could call select(), but FFI calls can't be interrupted

92+ -- with async exceptions, whereas threadDelay can.

93+ Just _fd -> do

94+ return (threadDelay 1000000 >> loop)

8595#else

86− Left fd -> threadWaitRead fd >> loop True

96+ -- This case fixes the race condition above. By registering

97+ -- our interest in the descriptor before we drop the lock,

98+ -- there is no opportunity for the descriptor index to be

99+ -- reallocated on us.

100+ --

101+ -- (That is, assuming there isn't concurrently executing

102+ -- code that manipulates the descriptor without holding

103+ -- the lock... but such a major bug is likely to exhibit

104+ -- itself in an at least somewhat more dramatic fashion.)

105+ Just fd -> do

106+ (waitRead, _) <- threadWaitReadSTM fd

107+ return $ do

108+ atomically waitRead `catch` (throwIO . setIOErrorLocation)

109+ loop

87110#endif

88− Right msg -> return $! convertNotice msg

111+

112+ loop = join $ withConnection conn $ \c -> do

113+ void $ PQ.consumeInput c

114+ fetch c

115+

116+ setIOErrorLocation :: IOError -> IOError

117+ setIOErrorLocation err = err { ioe_location = B8.unpack funcName }

118+

89119

90120-- | Non-blocking variant of 'getNotification'. Returns a single notification,

91121-- if available. If no notifications are available, returns 'Nothing'.

src/Database/PostgreSQL/Simple/Ok.hs+10−4

@@ -1,10 +1,11 @@

11{-# LANGUAGE DeriveDataTypeable #-}

22{-# LANGUAGE DeriveFunctor #-}

3+{-# LANGUAGE CPP #-}

45------------------------------------------------------------------------------

56-- |

67-- Module : Database.PostgreSQL.Simple.Ok

89-- License : BSD3

910--

1011-- Maintainer : leon@melding-monads.com

@@ -20,7 +21,7 @@

2021-- commonly-used type and typeclass included in @base@.

2122--

2223-- Extending the failure case to a list of 'SomeException's enables a

23−-- more sensible 'Alternative' instance definitions: '<|>' concatinates

24+-- more sensible 'Alternative' instance definitions: '<|>' concatenates

2425-- the list of exceptions when both cases fail, and 'empty' is defined as

2526-- 'Errors []'. Though '<|>' one could pick one of two exceptions, and

2627-- throw away the other, and have 'empty' provide a generic exception,

@@ -36,6 +37,8 @@ import Control.Exception

3637import Control.Monad(MonadPlus(..))

3738import Data.Typeable

3839

40+import qualified Control.Monad.Fail as Fail

41+

3942-- FIXME: [SomeException] should probably be something else, maybe

4043-- a difference list (or a tree?)

4144

@@ -69,11 +72,14 @@ instance MonadPlus Ok where

6972 mplus = (<|>)

7073

7174instance Monad Ok where

72− return = Ok

73−

7475 Errors es >>= _ = Errors es

7576 Ok a >>= f = f a

7677

78+#if !(MIN_VERSION_base(4,13,0))

79+ fail = Fail.fail

80+#endif

81+

82+instance Fail.MonadFail Ok where

7783 fail str = Errors [SomeException (ErrorCall str)]

7884

7985-- | a way to reify a list of exceptions into a single exception

src/Database/PostgreSQL/Simple/Range.hsnew file+317

@@ -0,0 +1,317 @@

1+{-# LANGUAGE DeriveDataTypeable #-}

2+{-# LANGUAGE DeriveFunctor #-}

3+{-# LANGUAGE OverloadedStrings #-}

4+{-# LANGUAGE FlexibleInstances #-}

6+------------------------------------------------------------------------------

7+-- |

8+-- Module: Database.PostgreSQL.Simple.Range

11+-- License: BSD3

12+-- Maintainer: Leon P Smith <leon@melding-monads.com>

13+--

14+------------------------------------------------------------------------------

15+

16+module Database.PostgreSQL.Simple.Range

17+ ( RangeBound(..)

18+ , PGRange(..)

19+ , empty

20+ , isEmpty, isEmptyBy

21+ , contains, containsBy

22+ , fromFieldRange

23+ ) where

24+

25+import Control.Applicative hiding (empty)

26+import Data.Attoparsec.ByteString.Char8 (Parser, parseOnly)

27+import qualified Data.Attoparsec.ByteString.Char8 as A

28+import qualified Data.ByteString as B

29+import Data.ByteString.Builder

30+ ( Builder, byteString, lazyByteString, char8

31+ , intDec, int8Dec, int16Dec, int32Dec, int64Dec, integerDec

32+ , wordDec, word8Dec, word16Dec, word32Dec, word64Dec

33+ , doubleDec, floatDec )

34+import Data.Int (Int16, Int32, Int64,

35+ Int8)

36+import Data.Function (on)

37+import Data.Monoid (mempty)

38+import Data.Scientific (Scientific)

39+import qualified Data.Text.Lazy.Builder as LT

40+import qualified Data.Text.Lazy.Encoding as LT

41+import Data.Time.Compat (Day, LocalTime,

42+ NominalDiffTime,

43+ TimeOfDay, UTCTime,

44+ ZonedTime,

45+ zonedTimeToUTC)

46+import Data.Typeable (Typeable)

47+import Data.Word (Word, Word16, Word32,

48+ Word64, Word8)

49+

50+import Database.PostgreSQL.Simple.Compat (scientificBuilder, (<>), toByteString)

51+import Database.PostgreSQL.Simple.FromField

52+import Database.PostgreSQL.Simple.Time

53+ hiding (PosInfinity, NegInfinity)

54+-- import qualified Database.PostgreSQL.Simple.Time as Time

55+import Database.PostgreSQL.Simple.ToField

56+

57+-- | Represents boundary of a range

58+data RangeBound a = NegInfinity

59+ | Inclusive !a

60+ | Exclusive !a

61+ | PosInfinity

62+ deriving (Show, Typeable, Eq, Functor)

63+

64+-- | Generic range type

65+data PGRange a = PGRange !(RangeBound a) !(RangeBound a)

66+ deriving (Show, Typeable, Functor)

67+

68+empty :: PGRange a

69+empty = PGRange PosInfinity NegInfinity

70+

71+instance Ord a => Eq (PGRange a) where

72+ x == y = eq x y || (isEmpty x && isEmpty y)

73+ where eq (PGRange a m) (PGRange b n) = a == b && m == n

74+

75+isEmptyBy :: (a -> a -> Ordering) -> PGRange a -> Bool

76+isEmptyBy cmp v =

77+ case v of

78+ (PGRange PosInfinity _) -> True

79+ (PGRange _ NegInfinity) -> True

80+ (PGRange NegInfinity _) -> False

81+ (PGRange _ PosInfinity) -> False

82+ (PGRange (Inclusive x) (Inclusive y)) -> cmp x y == GT

83+ (PGRange (Inclusive x) (Exclusive y)) -> cmp x y /= LT

84+ (PGRange (Exclusive x) (Inclusive y)) -> cmp x y /= LT

85+ (PGRange (Exclusive x) (Exclusive y)) -> cmp x y /= LT

86+

87+-- | Is a range empty? If this returns 'True', then the 'contains'

88+-- predicate will always return 'False'. However, if this returns

89+-- 'False', it is not necessarily true that there exists a point for

90+-- which 'contains' returns 'True'.

91+-- Consider @'PGRange' ('Excludes' 2) ('Excludes' 3) :: PGRange Int@,

92+-- for example.

93+isEmpty :: Ord a => PGRange a -> Bool

94+isEmpty = isEmptyBy compare

95+

96+

97+-- | Does a range contain a given point? Note that in some cases, this may

98+-- not correspond exactly with a server-side computation. Consider @UTCTime@

99+-- for example, which has a resolution of a picosecond, whereas postgresql's

100+-- @timestamptz@ types have a resolution of a microsecond. Putting such

101+-- Haskell values into the database will result in them being rounded, which

102+-- can change the value of the containment predicate.

103+

104+contains :: Ord a => PGRange a -> (a -> Bool)

105+contains = containsBy compare

106+

107+containsBy :: (a -> a -> Ordering) -> PGRange a -> (a -> Bool)

108+containsBy cmp rng x =

109+ case rng of

110+ PGRange _lb NegInfinity -> False

111+ PGRange lb ub -> checkLB lb x && checkUB ub x

112+ where

113+ checkLB lb y =

114+ case lb of

115+ NegInfinity -> True

116+ PosInfinity -> False

117+ Inclusive a -> cmp a y /= GT

118+ Exclusive a -> cmp a y == LT

119+

120+ checkUB ub y =

121+ case ub of

122+ NegInfinity -> False

123+ PosInfinity -> True

124+ Inclusive z -> cmp y z /= GT

125+ Exclusive z -> cmp y z == LT

126+

127+lowerBound :: Parser (a -> RangeBound a)

128+lowerBound = (A.char '(' *> pure Exclusive) <|> (A.char '[' *> pure Inclusive)

129+{-# INLINE lowerBound #-}

130+

131+upperBound :: Parser (a -> RangeBound a)

132+upperBound = (A.char ')' *> pure Exclusive) <|> (A.char ']' *> pure Inclusive)

133+{-# INLINE upperBound #-}

134+

135+-- | Generic range parser

136+pgrange :: Parser (RangeBound B.ByteString, RangeBound B.ByteString)

137+pgrange = do

138+ lb <- lowerBound

139+ v1 <- (A.char ',' *> "") <|> (rangeElem (==',') <* A.char ',')

140+ v2 <- rangeElem $ \c -> c == ')' || c == ']'

141+ ub <- upperBound

142+ A.endOfInput

143+ let low = if B.null v1 then NegInfinity else lb v1

144+ up = if B.null v2 then PosInfinity else ub v2

145+ return (low, up)

146+

147+rangeElem :: (Char -> Bool) -> Parser B.ByteString

148+rangeElem end = (A.char '"' *> doubleQuoted)

149+ <|> A.takeTill end

150+{-# INLINE rangeElem #-}

151+

152+-- | Simple double quoted value parser

153+doubleQuoted :: Parser B.ByteString

154+doubleQuoted = toByteString <$> go mempty

155+ where

156+ go acc = do

157+ h <- byteString <$> A.takeTill (\c -> c == '\\' || c == '"')

158+ let rest = do

159+ start <- A.anyChar

160+ case start of

161+ '\\' -> do

162+ c <- A.anyChar

163+ go (acc <> h <> char8 c)

164+ '"' -> (A.char '"' *> go (acc <> h <> char8 '"'))

165+ <|> pure (acc <> h)

166+ _ -> error "impossible in doubleQuoted"

167+ rest

168+

169+rangeToBuilder :: Ord a => (a -> Builder) -> PGRange a -> Builder

170+rangeToBuilder = rangeToBuilderBy compare

171+

172+-- | Generic range to builder for plain values

173+rangeToBuilderBy :: (a -> a -> Ordering) -> (a -> Builder) -> PGRange a -> Builder

174+rangeToBuilderBy cmp f x =

175+ if isEmptyBy cmp x

176+ then byteString "'empty'"

177+ else let (PGRange a b) = x

178+ in buildLB a <> buildUB b

179+ where

180+ buildLB NegInfinity = byteString "'[,"

181+ buildLB (Inclusive v) = byteString "'[\"" <> f v <> byteString "\","

182+ buildLB (Exclusive v) = byteString "'(\"" <> f v <> byteString "\","

183+ buildLB PosInfinity = error "impossible in rangeToBuilder"

184+

185+ buildUB NegInfinity = error "impossible in rangeToBuilder"

186+ buildUB (Inclusive v) = char8 '"' <> f v <> byteString "\"]'"

187+ buildUB (Exclusive v) = char8 '"' <> f v <> byteString "\")'"

188+ buildUB PosInfinity = byteString "]'"

189+{-# INLINE rangeToBuilder #-}

190+

191+

192+instance (FromField a, Typeable a) => FromField (PGRange a) where

193+ fromField = fromFieldRange fromField

194+

195+fromFieldRange :: Typeable a => FieldParser a -> FieldParser (PGRange a)

196+fromFieldRange fromField' f mdat = do

197+ info <- typeInfo f

198+ case info of

199+ Range{} ->

200+ let f' = f { typeOid = typoid (rngsubtype info) }

201+ in case mdat of

202+ Nothing -> returnError UnexpectedNull f ""

203+ Just "empty" -> pure $ empty

204+ Just bs ->

205+ let parseIt NegInfinity = pure NegInfinity

206+ parseIt (Inclusive v) = Inclusive <$> fromField' f' (Just v)

207+ parseIt (Exclusive v) = Exclusive <$> fromField' f' (Just v)

208+ parseIt PosInfinity = pure PosInfinity

209+ in case parseOnly pgrange bs of

210+ Left e -> returnError ConversionFailed f e

211+ Right (lb,ub) -> PGRange <$> parseIt lb <*> parseIt ub

212+ _ -> returnError Incompatible f ""

213+

214+

215+instance ToField (PGRange Int8) where

216+ toField = Plain . rangeToBuilder int8Dec

217+ {-# INLINE toField #-}

218+

219+instance ToField (PGRange Int16) where

220+ toField = Plain . rangeToBuilder int16Dec

221+ {-# INLINE toField #-}

222+

223+instance ToField (PGRange Int32) where

224+ toField = Plain . rangeToBuilder int32Dec

225+ {-# INLINE toField #-}

226+

227+instance ToField (PGRange Int) where

228+ toField = Plain . rangeToBuilder intDec

229+ {-# INLINE toField #-}

230+

231+instance ToField (PGRange Int64) where

232+ toField = Plain . rangeToBuilder int64Dec

233+ {-# INLINE toField #-}

234+

235+instance ToField (PGRange Integer) where

236+ toField = Plain . rangeToBuilder integerDec

237+ {-# INLINE toField #-}

238+

239+instance ToField (PGRange Word8) where

240+ toField = Plain . rangeToBuilder word8Dec

241+ {-# INLINE toField #-}

242+

243+instance ToField (PGRange Word16) where

244+ toField = Plain . rangeToBuilder word16Dec

245+ {-# INLINE toField #-}

246+

247+instance ToField (PGRange Word32) where

248+ toField = Plain . rangeToBuilder word32Dec

249+ {-# INLINE toField #-}

250+

251+instance ToField (PGRange Word) where

252+ toField = Plain . rangeToBuilder wordDec

253+ {-# INLINE toField #-}

254+

255+instance ToField (PGRange Word64) where

256+ toField = Plain . rangeToBuilder word64Dec

257+ {-# INLINE toField #-}

258+

259+instance ToField (PGRange Float) where

260+ toField = Plain . rangeToBuilder floatDec

261+ {-# INLINE toField #-}

262+

263+instance ToField (PGRange Double) where

264+ toField = Plain . rangeToBuilder doubleDec

265+ {-# INLINE toField #-}

266+

267+instance ToField (PGRange Scientific) where

268+ toField = Plain . rangeToBuilder f

269+ where

270+ f = lazyByteString . LT.encodeUtf8 . LT.toLazyText . scientificBuilder

271+ {-# INLINE toField #-}

272+

273+instance ToField (PGRange UTCTime) where

274+ toField = Plain . rangeToBuilder utcTimeToBuilder

275+ {-# INLINE toField #-}

276+

277+instance ToField (PGRange ZonedTime) where

278+ toField = Plain . rangeToBuilderBy cmpZonedTime zonedTimeToBuilder

279+ {-# INLINE toField #-}

280+

281+cmpZonedTime :: ZonedTime -> ZonedTime -> Ordering

282+cmpZonedTime = compare `on` zonedTimeToUTC -- FIXME: optimize

283+

284+instance ToField (PGRange LocalTime) where

285+ toField = Plain . rangeToBuilder localTimeToBuilder

286+ {-# INLINE toField #-}

287+

288+instance ToField (PGRange Day) where

289+ toField = Plain . rangeToBuilder dayToBuilder

290+ {-# INLINE toField #-}

291+

292+instance ToField (PGRange TimeOfDay) where

293+ toField = Plain . rangeToBuilder timeOfDayToBuilder

294+ {-# INLINE toField #-}

295+

296+instance ToField (PGRange UTCTimestamp) where

297+ toField = Plain . rangeToBuilder utcTimestampToBuilder

298+ {-# INLINE toField #-}

299+

300+instance ToField (PGRange ZonedTimestamp) where

301+ toField = Plain . rangeToBuilderBy cmpZonedTimestamp zonedTimestampToBuilder

302+ {-# INLINE toField #-}

303+

304+cmpZonedTimestamp :: ZonedTimestamp -> ZonedTimestamp -> Ordering

305+cmpZonedTimestamp = compare `on` (zonedTimeToUTC <$>)

306+

307+instance ToField (PGRange LocalTimestamp) where

308+ toField = Plain . rangeToBuilder localTimestampToBuilder

309+ {-# INLINE toField #-}

310+

311+instance ToField (PGRange Date) where

312+ toField = Plain . rangeToBuilder dateToBuilder

313+ {-# INLINE toField #-}

314+

315+instance ToField (PGRange NominalDiffTime) where

316+ toField = Plain . rangeToBuilder nominalDiffTimeToBuilder

317+ {-# INLINE toField #-}

src/Database/PostgreSQL/Simple/SqlQQ.hs+17−14

@@ -1,3 +1,9 @@

1+{-# LANGUAGE CPP #-}

2+#if __GLASGOW_HASKELL__ >= 800

3+{-# LANGUAGE TemplateHaskellQuotes #-}

4+#else

5+{-# LANGUAGE TemplateHaskell #-}

6+#endif

17------------------------------------------------------------------------------

28-- |

39-- Module: Database.PostgreSQL.Simple.SqlQQ

@@ -9,10 +15,11 @@

915------------------------------------------------------------------------------

1016

1117module Database.PostgreSQL.Simple.SqlQQ (sql) where

12−

18+import Database.PostgreSQL.Simple.Types (Query)

1319import Language.Haskell.TH

1420import Language.Haskell.TH.Quote

1521import Data.Char

22+import Data.String

1623

1724-- | 'sql' is a quasiquoter that eases the syntactic burden

1825-- of writing big sql statements in Haskell source code. For example:

@@ -27,10 +34,10 @@ import Data.Char

2734-- > LIMIT 100 |]

2835-- > (beginTime,endTime,string)

2936--

30−-- This quasiquoter attempts to mimimize whitespace; otherwise the

31−-- above query would consist of approximately half whitespace when sent

32−-- to the database backend. It also recognizes and strips out standard

33−-- sql comments "--".

37+-- This quasiquoter returns a literal string expression of type 'Query',

38+-- and attempts to minimize whitespace; otherwise the above query would

39+-- consist of approximately half whitespace when sent to the database

40+-- backend. It also recognizes and strips out standard sql comments "--".

3441--

3542-- The implementation of the whitespace reducer is currently incomplete.

3643-- Thus it can mess up your syntax in cases where whitespace should be

@@ -50,17 +57,14 @@ import Data.Char

5057

5158sql :: QuasiQuoter

5259sql = QuasiQuoter

53− { quotePat = error "Database.PostgreSQL.Simple.SqlQQ.sql:\

54− \ quasiquoter used in pattern context"

55− , quoteType = error "Database.PostgreSQL.Simple.SqlQQ.sql:\

56− \ quasiquoter used in type context"

60+ { quotePat = error "Database.PostgreSQL.Simple.SqlQQ.sql: quasiquoter used in pattern context"

61+ , quoteType = error "Database.PostgreSQL.Simple.SqlQQ.sql: quasiquoter used in type context"

5762 , quoteExp = sqlExp

58− , quoteDec = error "Database.PostgreSQL.Simple.SqlQQ.sql:\

59− \ quasiquoter used in declaration context"

63+ , quoteDec = error "Database.PostgreSQL.Simple.SqlQQ.sql: quasiquoter used in declaration context"

6064 }

6165

6266sqlExp :: String -> Q Exp

63−sqlExp = stringE . minimizeSpace

67+sqlExp = appE [| fromString :: String -> Query |] . stringE . minimizeSpace

6468

6569minimizeSpace :: String -> String

6670minimizeSpace = drop 1 . reduceSpace

@@ -83,5 +87,4 @@ minimizeSpace = drop 1 . reduceSpace

8387 instring ('\'':'\'':xs) = '\'':'\'': instring xs

8488 instring ('\'':xs) = '\'': insql xs

8589 instring (x:xs) = x : instring xs

86− instring [] = error "Database.PostgreSQL.Simple.SqlQQ.sql:\

87− \ string literal not terminated"

90+ instring [] = error "Database.PostgreSQL.Simple.SqlQQ.sql: string literal not terminated"

src/Database/PostgreSQL/Simple/Time.hs+215−50

@@ -1,53 +1,216 @@

1−------------------------------------------------------------------------------

2−-- |

3−-- Module: Database.PostgreSQL.Simple.Time

5−-- License: BSD3

6−-- Maintainer: Leon P Smith <leon@melding-monads.com>

7−-- Stability: experimental

8−--

9−-- Time types that supports positive and negative infinity. Also includes

10−-- new time parsers and printers with better performance than GHC's time

11−-- package.

12−--

13−-- The parsers only understand the specific variant of ISO 8601 that

14−-- PostgreSQL emits, and the printers attempt to duplicate this syntax.

15−-- Thus the @datestyle@ parameter for the connection must be set to @ISO@.

16−--

17−-- These parsers and printers likely have problems and shortcomings. Some

18−-- that I know of:

19−--

20−-- 1 @TimestampTZ@s before a timezone-dependent point in time cannot be

21−-- parsed, because the parsers can only handle timezone offsets of a

22−-- integer number of minutes. However, PostgreSQL will include seconds

23−-- in the offset, depending on the historical time standards for the city

24−-- identifying the time zone.

25−--

26−-- This boundary point often marks an event of some interest. In the US

27−-- for example, @timestamptz@s before @1883-Nov-18 12:00:00@ local time

28−-- cannot be parsed. This is the moment Standard Railway Time went live.

29−-- Concretely, PostgreSQL will emit @1883-11-18 12:03:57-04:56:02@

30−-- instead of @1883-11-18 11:59:59-05@ when the @timezone@ parameter

31−-- for the connection is set to @America/New_York@.

32−--

33−-- 2. Dates and times surrounding @1582-Feb-24@, the date the Gregorian

34−-- Calendar was introduced, should be investigated for conversion errors.

35−--

36−-- 3. Points in time Before Christ are not also not supported. For example,

37−-- PostgreSQL will emit @0045-01-01 BC@ for a value of a @date@ type.

38−-- This is the year that the Julian Calendar was adopted.

39−--

40−-- However, it should be noted that the old parsers also had issues 1 and 3.

41−-- Also, the new parsers now correctly handle time zones that include minutes

42−-- in their offset. Most notably, this includes all of India and parts of

43−-- Canada and Australia.

44−--

45−-- PostgreSQL uses the zoneinfo database for its time zone information.

46−-- You can read more about PostgreSQL's date and time types at

47−-- <http://www.postgresql.org/docs/9.1/static/datatype-datetime.html>,

48−-- and zoneinfo at <http://en.wikipedia.org/wiki/Tz_database>.

49−--

50−------------------------------------------------------------------------------

1+{- |

2+Module: Database.PostgreSQL.Simple.Time

4+License: BSD3

5+Maintainer: Leon P Smith <leon@melding-monads.com>

6+Stability: experimental

8+This module provides time types that supports positive and negative

9+infinity, as well as some functions for converting to and from strings.

10+

11+Also, this module also contains commentary regarding postgresql's timestamp

12+types, civil timekeeping in general, and how it relates to

13+postgresql-simple. You can read more about PostgreSQL's date and time types

14+at <https://www.postgresql.org/docs/9.5/static/datatype-datetime.html>,

15+and the IANA time zone database at <https://en.wikipedia.org/wiki/Tz_database>.

16+

17+Stack Overflow also has some excellent commentary on time, if it is a

18+wiki page or a highly upvoted question and answer. If the answer regarding

19+time has not received about a hundred upvotes at least, then the answer is

20+almost invariably completely and painfully wrong, even if it's the chosen

21+answer or the most highly upvoted answer to a question.

22+

23+PostgreSQL's @timestamp with time zone@ (hereafter, @timestamptz@) can be

24+converted to Haskell's 'Data.Time.UTCTime' and 'Data.Time.ZonedTime' types,

25+because values of these types represent a self-contained, unambiguous point

26+in time. PostgreSQL's @timestamp without time zone@ (hereafter, @timestamp@)

27+can be converted to Haskell's 'Data.Time.LocalTime', because values of these

28+types are ambiguous by themselves, and require context to disambiguate.

29+

30+While this behavior may be superficially counterintuitive because the

31+names might suggest otherwise, this behavior is correct. In fact,

32+the \"timezone\" language in both the postgresql and haskell types would

33+be better read as \"offset (from UTC)\", thus we have postgresql's

34+\"timestamp with offset\" corresponding to Haskell's \"time with the

35+offset \'zero\'\" and Haskell's \"time with an offset (that might be

36+nonzero)\". Similarly, postgresql's \"timestamp without an offset\"

37+corresponds to Haskell's \"local time (without an offset)\".

38+

39+It's important to distinguish between an offset, a standard time, and

40+a time zone. An offset is simply a difference of a local time from UTC,

41+such as @+00@, @-05@, or @+05:30@. A standard time specifies an offset

42+(which may vary throughout the year, due to daylight savings) that a

43+region follows, such as Universal Coordinated Time (UTC), Eastern Standard

44+Time\/Eastern Daylight Time (EST\/EDT), or India Standard Time (IST).

45+And a time zone, much like a standard time, is a function from

46+timestamps to offsets.

47+

48+A time zone is different from a standard time because different regions

49+inside a standard time can be governed by different civil authorities with

50+different laws and thus have different histories of civil time. An IANA

51+time zone is any region of the world that has had the same history of

52+civil time since @1970-01-01 00:00+00@.

53+

54+For example, as of today, both @America\/New_York@ and

55+@America\/Indiana\/Indianapolis@ are on the EST\/EDT time standard, but

56+Indiana used to be on Central Standard Time until 1942, and did not observe

57+daylight savings time (EST only) until 2006. Thus, the choice between

58+these two time zones still matters if you are dealing with timestamps

59+prior to 2006, and could become relevant again if (most of) Indiana

60+moves back to Central Time. (Of course, if the Central to Eastern switch

61+was the only difference, then these two time zones would be the same in

62+IANA's eyes, due to their cutoff date of 1970-01-01.)

63+

64+Getting back to practicalities, PostgreSQL's @timestamptz@ type does not

65+actually store an offset; rather, it uses the offset provided to calculate

66+UTC, and stores the timestamp as UTC. If an offset is not provided, the

67+given timestamp is assumed to be a local time for whatever the @timezone@

68+variable is set to, and the IANA TZ database is consulted to calculate an

69+offset from UTC for the time in question.

70+

71+Note that while most (local timestamp, time zone) pairs correspond to exactly

72+one UTC timestamp, some correspond to two UTC timestamps, while others

73+correspond to none at all. The ambiguous case occurs when the civil time

74+is rolled back, making a calendar day longer than 24 hours. In this case,

75+PostgreSQL silently chooses the second, later possibility. The inconsistent

76+case occurs when the civil time is moved forward, making a calendar day less

77+than 24 hours. In this case, PostgreSQL silently assumes the local time

78+was read off a clock that had not been moved forward at the prescribed time,

79+and moves the clock forward for you. Thus, converting from local time

80+to UTC need not be monotonic, if these inconsistent cases are allowed.

81+

82+When retrieving a @timestamptz@, the backend looks at the @time zone@

83+connection variable and then consults the IANA TZ database to calculate

84+an offset for the timestamp in the given time zone.

85+

86+Note that while some of the information contained in the IANA TZ database

87+is a bit of a standardized fiction, the conversion from UTC time to a

88+(local time, offset) pair in a particular time zone is always unambiguous,

89+and the result can always be unambiguously converted back to UTC. Thus,

90+postgresql-simple can interpret such a result as a 'Data.Time.ZonedTime',

91+or use the offset to convert back to 'Data.Time.UTCTime'.

92+

93+By contrast, the @timestamp@ type ignores any offsets provided to it,

94+and never sends back an offset. Thus, postgresql-simple equates this

95+with 'Data.Time.LocalTime', which has no concept of an offset. One can

96+convert between @timestamptz@ and @timestamp@ using the @AT TIME ZONE@

97+operator, whose semantics also demonstrates that @timestamptz@ is

98+'Data.Time.UTCTime' whereas @timestamp@ is 'Data.Time.LocalTime'.

99+

100+PostgreSQL's @timezone@ is a per-connection variable that by default is

101+initialized to @\'localtime\'@, which normally corresponds to the server's

102+time zone. However, this default can be modified on the server side for an

103+entire cluster, or on a per-user or per-database basis. Moreover, a client

104+can modify their instance of the variable at any time, and can apply that

105+change to the remaining duration of the connection, the current transaction,

106+or the execution context of a server-side function. In addition, upon

107+connection initialization, the libpq client checks for the existence of

108+the @PGTZ@ environment variable, and if it exists, modifies @timezone@

109+accordingly.

110+

111+With a few caveats, postgresql-simple is designed so that you can both send

112+and receive timestamps with the server and get a correct result, no matter

113+what the @timezone@ setting is. But it is important to understand the caveats:

114+

115+1. The correctness of server-side computations can depend on the @timezone@

116+ setting. Examples include adding an @interval@ to a @timestamptz@, or

117+ type casting between @timestamp@ and @timestamptz@, or applying

118+ the @DATE@ function to a @timestamptz@.

119+

120+2. The (localtime, offset) pair contained in a 'Data.Time.ZonedTime' result

121+ will depend on the @timezone@ setting, although the result will always

122+ represent the same instant in time regardless of the time zone.

123+

124+3. Sending a 'Data.Time.LocalTime' and interpreting it as a @timestamptz@

125+ can be useful, as it will be converted to UTC via the tz database,

126+ but correctness will depend on the @timezone@ setting. You may prefer

127+ to use an explicit @AT TIME ZONE@ conversion instead, which would avoid

128+ this contextual dependence.

129+

130+Furthermore, although these following points don't involve the @timezone@

131+setting, they are related to the last point above:

132+

133+1. Sending a 'Data.Time.UTCTime' and interpreting it as a @timestamp@ can

134+ be useful. In practice, the most common context used to disambiguate

135+ @timestamp@ is that it represents UTC, and this coding technique will

136+ work as expected in this situation.

137+

138+2. Sending a 'Data.Time.ZonedTime' and interpreting it as a @timestamp@ is

139+ almost always the wrong thing to do, as the offset will be ignored and

140+ discarded. This is likely to lead to inconsistencies in the database,

141+ and may lead to partial data loss.

142+

143+When dealing with local timestamps that refer to the future, it is often

144+useful to store it as a local time in a @timestamp@ column and store the

145+time zone in a second column. One reason to do this is so that you can

146+convert to UTC on the fly as needed, and be protected against future changes

147+to the TZ database due to changes in local time standards. In any case,

148+'Data.Time.ZonedTime' is not suitable for this application, because despite

149+its name, it represents an offset and not a time zone. Time zones can change;

150+offsets do not. In reality, we can't convert a local timestamp that occurs

151+sufficiently far in the future to UTC, because we don't know how to do it yet.

152+

153+There are a few limitations and caveats that one might need to be aware

154+of with the current implementation when dealing with older timestamps:

155+

156+For sufficiently old timestamps in almost all time zones, the IANA TZ

157+database specifies offsets from UTC that is not an integral number of

158+minutes. This corresponds to local mean time; that is, astronomical

159+time in the city that defines the time zone. Different time zones moved

160+away from local mean time to a standard time at different points in

161+history, so \"sufficiently old\" depends on the time zone in question.

162+

163+Thus, when retrieving a @timestamptz@ postgresql will in some cases

164+provide seconds in the offset. For example:

165+

166+@

167+$ psql

168+psql (9.4.5)

169+Type \"help\" for help.

170+

171+lpsmith=> SET timezone TO \'America/New_York\';

172+SET

173+lpsmith=> VALUES (\'1883-11-18 16:59:59+00\'::timestamptz),

174+ (\'1883-11-18 17:00:00+00\'::timestamptz);

175+ column1

176+------------------------------

177+ 1883-11-18 12:03:57-04:56:02

178+ 1883-11-18 12:00:00-05

179+(2 rows)

180+@

181+

182+Both of these timestamps can be parsed as a 'Data.Time.UTCTime' type,

183+however 'Data.Time.ZonedTime' will fail on the former timestamp.

184+Because 'Data.Time.ZonedTime' assumes that offsets are an integer number

185+of minutes, there isn't an particularly good solution here.

186+

187+PostgreSQL, like most software, uses the proleptic Gregorian calendar

188+for its date calculations, extending the Gregorian calendar backwards

189+in time before its introduction and pretending that the Julian calendar

190+does not exist. For most purposes, the adoption of the Gregorian calendar

191+ranges from @1582-10-15@ to @1923-03-01@, depending on location and

192+sometimes even political allegiances within a single location.

193+

194+Timestamps BCE are not supported. For example, PostgreSQL

195+will emit \"@0045-01-01 BC@\" for the first proleptic Gregorian day of

196+the year the Roman Empire adopted the Julian Calendar, but

197+postgresql-simple does not (yet?) have the ability to either parse or

198+generate this syntax. Unfortunately this syntax isn't convenient to

199+print or especially parse.

200+

201+Also, postgresql itself cannot parse or print dates before @4714-11-24 BC@,

202+which is the Julian date on the proleptic Gregorian Calendar. Although

203+postgresql's timestamp types are perfectly capable of representing timestamps

204+nearly 300,000 years in the past, using this would require postgresql-simple

205+and other client programs to support binary parameters and results.

206+

207+Dealing with years BCE is also complicated slightly by the fact that

208+Haskell's time library has a year \"0000\", which is a convention often

209+used by astronomers, while postgresql adopts the more historically

210+accurate convention that there is no year zero, but rather \"1 BCE\"

211+was immediately followed by \"1 CE\".

212+

213+-}

51214

52215module Database.PostgreSQL.Simple.Time

53216 ( Unbounded(..)

@@ -64,6 +227,7 @@ module Database.PostgreSQL.Simple.Time

64227 , parseUTCTimestamp

65228 , parseZonedTimestamp

66229 , parseLocalTimestamp

230+ , parseCalendarDiffTime

67231 , dayToBuilder

68232 , utcTimeToBuilder

69233 , zonedTimeToBuilder

@@ -76,6 +240,7 @@ module Database.PostgreSQL.Simple.Time

76240 , localTimestampToBuilder

77241 , unboundedToBuilder

78242 , nominalDiffTimeToBuilder

243+ , calendarDiffTimeToBuilder

79244 ) where

80245

81246import Database.PostgreSQL.Simple.Time.Implementation

src/Database/PostgreSQL/Simple/Time/Implementation.hs+44−191

@@ -1,51 +1,44 @@

11------------------------------------------------------------------------------

22-- |

33-- Module: Database.PostgreSQL.Simple.Time.Implementation

55-- License: BSD3

66-- Maintainer: Leon P Smith <leon@melding-monads.com>

77-- Stability: experimental

88--

99------------------------------------------------------------------------------

1010

11−{-# LANGUAGE DeriveDataTypeable #-}

11+{-# LANGUAGE DeriveDataTypeable, DeriveFunctor #-}

1212

1313module Database.PostgreSQL.Simple.Time.Implementation where

1414

15−import Prelude hiding (take, (++))

16−import Blaze.ByteString.Builder(Builder, fromByteString)

17−import Blaze.ByteString.Builder.Char8(fromChar)

18−import Blaze.Text.Int(integral)

15+import Prelude hiding (take)

16+import Data.ByteString.Builder(Builder, byteString)

17+import Data.ByteString.Builder.Prim(primBounded)

1918import Control.Arrow((***))

2019import Control.Applicative

21−import Control.Monad(when)

22−import Data.Bits((.&.))

2320import qualified Data.ByteString as B

24−import Data.ByteString.Internal (c2w, w2c)

25−import Data.Time hiding (getTimeZone, getZonedTime)

21+import Data.Time.Compat (LocalTime, UTCTime, ZonedTime, Day, TimeOfDay, TimeZone, NominalDiffTime, utc)

22+import Data.Time.LocalTime.Compat (CalendarDiffTime)

2623import Data.Typeable

27−import Data.Word(Word8)

28−import qualified Data.Attoparsec.Char8 as A

29−import Data.Monoid(Monoid(..))

30−import Data.Fixed (Pico)

31−import Unsafe.Coerce

32−

33−(++) :: Monoid a => a -> a -> a

34−(++) = mappend

35−infixr 5 ++

24+import Data.Maybe (fromMaybe)

25+import qualified Data.Attoparsec.ByteString.Char8 as A

26+import Database.PostgreSQL.Simple.Compat ((<>))

27+import qualified Database.PostgreSQL.Simple.Time.Internal.Parser as TP

28+import qualified Database.PostgreSQL.Simple.Time.Internal.Printer as TPP

3629

3730data Unbounded a

3831 = NegInfinity

3932 | Finite !a

4033 | PosInfinity

41− deriving (Eq, Ord, Typeable)

34+ deriving (Eq, Ord, Typeable, Functor)

4235

4336instance Show a => Show (Unbounded a) where

4437 showsPrec prec x rest

4538 = case x of

46− NegInfinity -> "-infinity" ++ rest

39+ NegInfinity -> "-infinity" <> rest

4740 Finite time -> showsPrec prec time rest

48− PosInfinity -> "infinity" ++ rest

41+ PosInfinity -> "infinity" <> rest

4942

5043instance Read a => Read (Unbounded a) where

5144 readsPrec prec = readParen False $ \str -> case str of

@@ -85,6 +78,9 @@ parseLocalTimestamp = A.parseOnly (getLocalTimestamp <* A.endOfInput)

8578parseDate :: B.ByteString -> Either String Date

8679parseDate = A.parseOnly (getDate <* A.endOfInput)

8780

81+parseCalendarDiffTime :: B.ByteString -> Either String CalendarDiffTime

82+parseCalendarDiffTime = A.parseOnly (getCalendarDiffTime <* A.endOfInput)

83+

8884getUnbounded :: A.Parser a -> A.Parser (Unbounded a)

8985getUnbounded getFinite

9086 = (pure NegInfinity <* A.string "-infinity")

@@ -92,160 +88,74 @@ getUnbounded getFinite

9288 <|> (Finite <$> getFinite)

9389

9490getDay :: A.Parser Day

95−getDay = do

96− yearStr <- A.takeWhile A.isDigit

97− when (B.length yearStr < 4) (fail "year must consist of at least 4 digits")

98−

99− let !year = toNum yearStr

100− _ <- A.char '-'

101− !month <- digits "month"

102− _ <- A.char '-'

103− day <- digits "day"

104−

105− case fromGregorianValid year month day of

106− Nothing -> fail "invalid date"

107− Just x -> return $! x

91+getDay = TP.day

10892

10993getDate :: A.Parser Date

11094getDate = getUnbounded getDay

11195

112−decimal :: Fractional a => B.ByteString -> a

113−decimal str = toNum str / 10^(B.length str)

114−{-# INLINE decimal #-}

115−

11696getTimeOfDay :: A.Parser TimeOfDay

117−getTimeOfDay = do

118− !hour <- digits "hours"

119− _ <- A.char ':'

120− minute <- digits "minutes"

121− _ <- A.char ':'

122− second <- digits "seconds"

123− subsec <- (A.char '.' *> (decimal <$> A.takeWhile1 A.isDigit)) <|> return 0

124−

125− let !picos' = second + subsec

126−

127− case makeTimeOfDayValid hour minute picos' of

128− Nothing -> fail "invalid time of day"

129− Just x -> return $! x

97+getTimeOfDay = TP.timeOfDay

13098

13199getLocalTime :: A.Parser LocalTime

132−getLocalTime = LocalTime <$> getDay <*> (A.char ' ' *> getTimeOfDay)

100+getLocalTime = TP.localTime

133101

134102getLocalTimestamp :: A.Parser LocalTimestamp

135103getLocalTimestamp = getUnbounded getLocalTime

136104

137105getTimeZone :: A.Parser TimeZone

138−getTimeZone = do

139− !sign <- A.satisfy (\c -> c == '+' || c == '-')

140− !hours <- digits "timezone"

141− !mins <- (A.char ':' *> digits "timezone minutes") <|> pure 0

142− let !absset = 60 * hours + mins

143− !offset = if sign == '+' then absset else -absset

144− return $! minutesToTimeZone offset

106+getTimeZone = fromMaybe utc <$> TP.timeZone

145107

146108type TimeZoneHMS = (Int,Int,Int)

147109

148110getTimeZoneHMS :: A.Parser TimeZoneHMS

149−getTimeZoneHMS = do

150− !sign <- A.satisfy (\c -> c == '+' || c == '-')

151− !hours <- digits "timezone"

152− !mins <- (A.char ':' *> digits "timezone minutes") <|> pure 0

153− !secs <- (A.char ':' *> digits "timezone seconds") <|> pure 0

154− if sign == '+'

155− then return $! (hours, mins, secs)

156− else return $! (\ !h !m !s -> (h,m,s)) (-hours) (-mins) (-secs)

111+getTimeZoneHMS = munge <$> TP.timeZoneHMS

112+ where

113+ munge Nothing = (0,0,0)

114+ munge (Just (TP.UTCOffsetHMS h m s)) = (h,m,s)

157115

158116localToUTCTimeOfDayHMS :: TimeZoneHMS -> TimeOfDay -> (Integer, TimeOfDay)

159−localToUTCTimeOfDayHMS (dh, dm, ds) (TimeOfDay h m s) =

160− (\ !a !b -> (a,b)) dday (TimeOfDay h'' m'' s'')

161− where

162− s' = s - fromIntegral ds

163− (!s'', m')

164− | s' < 0 = (s' + 60, m - dm - 1)

165− | s' >= 60 = (s' - 60, m - dm + 1)

166− | otherwise = (s' , m - dm )

167− (!m'', h')

168− | m' < 0 = (m' + 60, h - dh - 1)

169− | m' >= 60 = (m' - 60, h - dh + 1)

170− | otherwise = (m' , h - dh )

171− (!h'', dday)

172− | h' < 0 = (h' + 24, -1)

173− | h' >= 24 = (h' - 24, 1)

174− | otherwise = (h' , 0)

117+localToUTCTimeOfDayHMS (dh, dm, ds) tod =

118+ TP.localToUTCTimeOfDayHMS (TP.UTCOffsetHMS dh dm ds) tod

175119

176120getZonedTime :: A.Parser ZonedTime

177−getZonedTime = ZonedTime <$> getLocalTime <*> getTimeZone

121+getZonedTime = TP.zonedTime

178122

179123getZonedTimestamp :: A.Parser ZonedTimestamp

180124getZonedTimestamp = getUnbounded getZonedTime

181125

182126getUTCTime :: A.Parser UTCTime

183−getUTCTime = do

184− day <- getDay

185− _ <- A.char ' '

186− time <- getTimeOfDay

187− zone <- getTimeZoneHMS

188− let !(dayDelta,time') = localToUTCTimeOfDayHMS zone time

189− let !day' = addDays dayDelta day

190− let !time'' = timeOfDayToTime time'

191− return $! UTCTime day' time''

127+getUTCTime = TP.utcTime

192128

193129getUTCTimestamp :: A.Parser UTCTimestamp

194130getUTCTimestamp = getUnbounded getUTCTime

195131

196−toNum :: Num n => B.ByteString -> n

197−toNum = B.foldl' (\a c -> 10*a + digit c) 0

198−{-# INLINE toNum #-}

199−

200−digit :: Num n => Word8 -> n

201−digit c = fromIntegral (c .&. 0x0f)

202−{-# INLINE digit #-}

203−

204−digits :: Num n => String -> A.Parser n

205−digits msg = do

206− x <- A.anyChar

207− y <- A.anyChar

208− if A.isDigit x && A.isDigit y

209− then return $! (10 * digit (c2w x) + digit (c2w y))

210− else fail (msg ++ " is not 2 digits")

211−{-# INLINE digits #-}

132+getCalendarDiffTime :: A.Parser CalendarDiffTime

133+getCalendarDiffTime = TP.calendarDiffTime

212134

213135dayToBuilder :: Day -> Builder

214−dayToBuilder (toGregorian -> (y,m,d)) = do

215− pad4 y ++ fromChar '-' ++ pad2 m ++ fromChar '-' ++ pad2 d

136+dayToBuilder = primBounded TPP.day

216137

217138timeOfDayToBuilder :: TimeOfDay -> Builder

218−timeOfDayToBuilder (TimeOfDay h m s) = do

219− pad2 h ++ fromChar ':' ++ pad2 m ++ fromChar ':' ++ showSeconds s

139+timeOfDayToBuilder = primBounded TPP.timeOfDay

220140

221141timeZoneToBuilder :: TimeZone -> Builder

222−timeZoneToBuilder tz

223− | m == 0 = sign h ++ pad2 (abs h)

224− | otherwise = sign h ++ pad2 (abs h) ++ fromChar ':' ++ pad2 (abs m)

225− where

226− (h,m) = timeZoneMinutes tz `quotRem` 60

227− sign h | h >= 0 = fromChar '+'

228− | otherwise = fromChar '-'

142+timeZoneToBuilder = primBounded TPP.timeZone

229143

230144utcTimeToBuilder :: UTCTime -> Builder

231−utcTimeToBuilder (UTCTime day time) =

232− dayToBuilder day ++ fromChar ' '

233− ++ timeOfDayToBuilder (timeToTimeOfDay time) ++ fromByteString "+00"

145+utcTimeToBuilder = primBounded TPP.utcTime

234146

235147zonedTimeToBuilder :: ZonedTime -> Builder

236−zonedTimeToBuilder (ZonedTime localTime tz) =

237− localTimeToBuilder localTime ++ timeZoneToBuilder tz

148+zonedTimeToBuilder = primBounded TPP.zonedTime

238149

239150localTimeToBuilder :: LocalTime -> Builder

240−localTimeToBuilder (LocalTime day tod) =

241− dayToBuilder day ++ fromChar ' ' ++ timeOfDayToBuilder tod

151+localTimeToBuilder = primBounded TPP.localTime

242152

243153unboundedToBuilder :: (a -> Builder) -> (Unbounded a -> Builder)

244154unboundedToBuilder finiteToBuilder unbounded

245155 = case unbounded of

246− NegInfinity -> fromByteString "-infinity"

156+ NegInfinity -> byteString "-infinity"

247157 Finite a -> finiteToBuilder a

248− PosInfinity -> fromByteString "infinity"

158+ PosInfinity -> byteString "infinity"

249159

250160utcTimestampToBuilder :: UTCTimestamp -> Builder

251161utcTimestampToBuilder = unboundedToBuilder utcTimeToBuilder

@@ -260,64 +170,7 @@ dateToBuilder :: Date -> Builder

260170dateToBuilder = unboundedToBuilder dayToBuilder

261171

262172nominalDiffTimeToBuilder :: NominalDiffTime -> Builder

263−nominalDiffTimeToBuilder xyz

264− | yz < 500000 = sign ++ integral x

265− | otherwise = sign ++ integral x ++ fromChar '.' ++ showD6 y

266− where

267− -- A kludge to work around the fact that Data.Fixed isn't very fast and

268− -- doesn't give me access to the MkFixed constructor.

269− sign = if xyz >= 0 then mempty else fromChar '-'

270− (x,yz) = ((unsafeCoerce (abs xyz) :: Integer) + 500000) `quotRem` 1000000000000

271− (fromIntegral -> y, _z) = yz `quotRem` 1000000

272−

273−showSeconds :: Pico -> Builder

274−showSeconds xyz

275− | yz == 0 = pad2 x

276− | z == 0 = pad2 x ++ fromChar '.' ++ showD6 y

277− | otherwise = pad2 x ++ fromChar '.' ++ pad6 y ++ showD6 z

278− where

279− -- A kludge to work around the fact that Data.Fixed isn't very fast and

280− -- doesn't give me access to the MkFixed constructor.

281− (x_,yz) = (unsafeCoerce xyz :: Integer) `quotRem` 1000000000000

282− x = fromIntegral x_ :: Int

283− (fromIntegral -> y, fromIntegral -> z) = yz `quotRem` 1000000

284−

285−pad6 :: Int -> Builder

286−pad6 xy = let (x,y) = xy `quotRem` 1000

287− in pad3 x ++ pad3 y

288−

289−showD6 :: Int -> Builder

290−showD6 xy = case xy `quotRem` 1000 of

291− (x,0) -> showD3 x

292− (x,y) -> pad3 x ++ showD3 y

293−

294−pad3 :: Int -> Builder

295−pad3 abc = let (ab,c) = abc `quotRem` 10

296− (a,b) = ab `quotRem` 10

297− in p a ++ p b ++ p c

298−

299−showD3 :: Int -> Builder

300−showD3 abc = case abc `quotRem` 100 of

301− (a, 0) -> p a

302− (a,bc) -> case bc `quotRem` 10 of

303− (b,0) -> p a ++ p b

304− (b,c) -> p a ++ p b ++ p c

305−

306−-- | p assumes its input is in the range [0..9]

307−p :: Integral n => n -> Builder

308−p n = fromChar (w2c (fromIntegral (n + 48)))

309−{-# INLINE p #-}

310−

311−-- | pad2 assumes its input is in the range [0..99]

312−pad2 :: Integral n => n -> Builder

313−pad2 n = let (a,b) = n `quotRem` 10 in p a ++ p b

314−{-# INLINE pad2 #-}

315−

316−-- | pad4 assumes its input is positive

317−pad4 :: (Integral n, Show n) => n -> Builder

318−pad4 abcd | abcd >= 10000 = integral abcd

319− | otherwise = p a ++ p b ++ p c ++ p d

320− where (ab,cd) = abcd `quotRem` 100

321− (a,b) = ab `quotRem` 10

322− (c,d) = cd `quotRem` 10

323−{-# INLINE pad4 #-}

173+nominalDiffTimeToBuilder = TPP.nominalDiffTime

174+

175+calendarDiffTimeToBuilder :: CalendarDiffTime -> Builder

176+calendarDiffTimeToBuilder = TPP.calendarDiffTime

src/Database/PostgreSQL/Simple/Time/Internal/Parser.hsnew file+204

@@ -0,0 +1,204 @@

1+{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}

3+-- |

4+-- Module: Database.PostgreSQL.Simple.Time.Internal.Parser

7+-- License: BSD3

8+-- Maintainer: Leon P Smith <leon@melding-monads.com>

9+-- Stability: experimental

10+--

11+-- Parsers for parsing dates and times.

12+

13+module Database.PostgreSQL.Simple.Time.Internal.Parser

14+ (

15+ day

16+ , localTime

17+ , timeOfDay

18+ , timeZone

19+ , UTCOffsetHMS(..)

20+ , timeZoneHMS

21+ , localToUTCTimeOfDayHMS

22+ , utcTime

23+ , zonedTime

24+ , calendarDiffTime

25+ ) where

26+

27+import Control.Applicative ((<$>), (<*>), (<*), (*>))

28+import Database.PostgreSQL.Simple.Compat (toPico)

29+import Data.Attoparsec.ByteString.Char8 as A

30+import Data.Bits ((.&.))

31+import Data.ByteString (ByteString)

32+import Data.Char (ord)

33+import Data.Fixed (Pico)

34+import Data.Int (Int64)

35+import Data.Maybe (fromMaybe)

36+import Data.Time.Calendar.Compat (Day, fromGregorianValid, addDays)

37+import Data.Time.Clock.Compat (UTCTime(..))

38+import Data.Time.Format.ISO8601.Compat (iso8601ParseM)

39+import Data.Time.LocalTime.Compat (CalendarDiffTime)

40+import qualified Data.ByteString.Char8 as B8

41+import qualified Data.Time.LocalTime.Compat as Local

42+

43+-- | Parse a date of the form @YYYY-MM-DD@.

44+day :: Parser Day

45+day = do

46+ y <- decimal <* char '-'

47+ m <- twoDigits <* char '-'

48+ d <- twoDigits

49+ maybe (fail "invalid date") return (fromGregorianValid y m d)

50+

51+-- | Parse a two-digit integer (e.g. day of month, hour).

52+twoDigits :: Parser Int

53+twoDigits = do

54+ a <- digit

55+ b <- digit

56+ let c2d c = ord c .&. 15

57+ return $! c2d a * 10 + c2d b

58+

59+-- | Parse a time of the form @HH:MM[:SS[.SSS]]@.

60+timeOfDay :: Parser Local.TimeOfDay

61+timeOfDay = do

62+ h <- twoDigits <* char ':'

63+ m <- twoDigits

64+ mc <- peekChar

65+ s <- case mc of

66+ Just ':' -> anyChar *> seconds

67+ _ -> return 0

68+ if h < 24 && m < 60 && s <= 60

69+ then return (Local.TimeOfDay h m s)

70+ else fail "invalid time"

71+

72+-- | Parse a count of seconds, with the integer part being two digits

73+-- long.

74+seconds :: Parser Pico

75+seconds = do

76+ real <- twoDigits

77+ mc <- peekChar

78+ case mc of

79+ Just '.' -> do

80+ t <- anyChar *> takeWhile1 isDigit

81+ return $! parsePicos (fromIntegral real) t

82+ _ -> return $! fromIntegral real

83+ where

84+ parsePicos :: Int64 -> B8.ByteString -> Pico

85+ parsePicos a0 t = toPico (fromIntegral (t' * 10^n))

86+ where n = max 0 (12 - B8.length t)

87+ t' = B8.foldl' (\a c -> 10 * a + fromIntegral (ord c .&. 15)) a0

88+ (B8.take 12 t)

89+

90+-- | Parse a time zone, and return 'Nothing' if the offset from UTC is

91+-- zero. (This makes some speedups possible.)

92+timeZone :: Parser (Maybe Local.TimeZone)

93+timeZone = do

94+ ch <- satisfy $ \c -> c == '+' || c == '-' || c == 'Z'

95+ if ch == 'Z'

96+ then return Nothing

97+ else do

98+ h <- twoDigits

99+ mm <- peekChar

100+ m <- case mm of

101+ Just ':' -> anyChar *> twoDigits

102+ _ -> return 0

103+ let off | ch == '-' = negate off0

104+ | otherwise = off0

105+ off0 = h * 60 + m

106+ case undefined of

107+ _ | off == 0 ->

108+ return Nothing

109+ | h > 23 || m > 59 ->

110+ fail "invalid time zone offset"

111+ | otherwise ->

112+ let !tz = Local.minutesToTimeZone off

113+ in return (Just tz)

114+

115+data UTCOffsetHMS = UTCOffsetHMS {-# UNPACK #-} !Int {-# UNPACK #-} !Int {-# UNPACK #-} !Int

116+

117+-- | Parse a time zone, and return 'Nothing' if the offset from UTC is

118+-- zero. (This makes some speedups possible.)

119+timeZoneHMS :: Parser (Maybe UTCOffsetHMS)

120+timeZoneHMS = do

121+ ch <- satisfy $ \c -> c == '+' || c == '-' || c == 'Z'

122+ if ch == 'Z'

123+ then return Nothing

124+ else do

125+ h <- twoDigits

126+ m <- maybeTwoDigits

127+ s <- maybeTwoDigits

128+ case undefined of

129+ _ | h == 0 && m == 0 && s == 0 ->

130+ return Nothing

131+ | h > 23 || m >= 60 || s >= 60 ->

132+ fail "invalid time zone offset"

133+ | otherwise ->

134+ if ch == '+'

135+ then let !tz = UTCOffsetHMS h m s

136+ in return (Just tz)

137+ else let !tz = UTCOffsetHMS (-h) (-m) (-s)

138+ in return (Just tz)

139+ where

140+ maybeTwoDigits = do

141+ ch <- peekChar

142+ case ch of

143+ Just ':' -> anyChar *> twoDigits

144+ _ -> return 0

145+

146+localToUTCTimeOfDayHMS :: UTCOffsetHMS -> Local.TimeOfDay -> (Integer, Local.TimeOfDay)

147+localToUTCTimeOfDayHMS (UTCOffsetHMS dh dm ds) (Local.TimeOfDay h m s) =

148+ (\ !a !b -> (a,b)) dday (Local.TimeOfDay h'' m'' s'')

149+ where

150+ s' = s - fromIntegral ds

151+ (!s'', m')

152+ | s' < 0 = (s' + 60, m - dm - 1)

153+ | s' >= 60 = (s' - 60, m - dm + 1)

154+ | otherwise = (s' , m - dm )

155+ (!m'', h')

156+ | m' < 0 = (m' + 60, h - dh - 1)

157+ | m' >= 60 = (m' - 60, h - dh + 1)

158+ | otherwise = (m' , h - dh )

159+ (!h'', dday)

160+ | h' < 0 = (h' + 24, -1)

161+ | h' >= 24 = (h' - 24, 1)

162+ | otherwise = (h' , 0)

163+

164+

165+-- | Parse a date and time, of the form @YYYY-MM-DD HH:MM:SS@.

166+-- The space may be replaced with a @T@. The number of seconds may be

167+-- followed by a fractional component.

168+localTime :: Parser Local.LocalTime

169+localTime = Local.LocalTime <$> day <* daySep <*> timeOfDay

170+ where daySep = satisfy (\c -> c == ' ' || c == 'T')

171+

172+-- | Behaves as 'zonedTime', but converts any time zone offset into a

173+-- UTC time.

174+utcTime :: Parser UTCTime

175+utcTime = do

176+ (Local.LocalTime d t) <- localTime

177+ mtz <- timeZoneHMS

178+ case mtz of

179+ Nothing -> let !tt = Local.timeOfDayToTime t

180+ in return (UTCTime d tt)

181+ Just tz -> let !(dd,t') = localToUTCTimeOfDayHMS tz t

182+ !d' = addDays dd d

183+ !tt = Local.timeOfDayToTime t'

184+ in return (UTCTime d' tt)

185+

186+-- | Parse a date with time zone info. Acceptable formats:

187+--

188+-- @YYYY-MM-DD HH:MM:SS Z@

189+--

190+-- The first space may instead be a @T@, and the second space is

191+-- optional. The @Z@ represents UTC. The @Z@ may be replaced with a

192+-- time zone offset of the form @+0000@ or @-08:00@, where the first

193+-- two digits are hours, the @:@ is optional and the second two digits

194+-- (also optional) are minutes.

195+zonedTime :: Parser Local.ZonedTime

196+zonedTime = Local.ZonedTime <$> localTime <*> (fromMaybe utc <$> timeZone)

197+

198+utc :: Local.TimeZone

199+utc = Local.TimeZone 0 False ""

200+

201+calendarDiffTime :: Parser CalendarDiffTime

202+calendarDiffTime = do

203+ contents <- takeByteString

204+ iso8601ParseM $ B8.unpack contents

src/Database/PostgreSQL/Simple/Time/Internal/Printer.hsnew file+135

@@ -0,0 +1,135 @@

1+{-# LANGUAGE BangPatterns, ViewPatterns #-}

3+------------------------------------------------------------------------------

4+-- Module: Database.PostgreSQL.Simple.Time.Internal.Printer

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+84−54

@@ -1,5 +1,6 @@

11{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-}

22{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}

3+{-# LANGUAGE PolyKinds #-}

45------------------------------------------------------------------------------

56-- |

@@ -22,38 +23,44 @@ module Database.PostgreSQL.Simple.ToField

2223 , inQuotes

2324 ) where

2425

25−import Blaze.ByteString.Builder (Builder, fromByteString, toByteString)

26−import Blaze.ByteString.Builder.Char8 (fromChar)

27−import Blaze.Text (integral, double, float)

26+import Control.Applicative (Const(Const))

2827import qualified Data.Aeson as JSON

29−import Data.ByteString (ByteString)

28+import Data.ByteString (ByteString)

29+import Data.ByteString.Builder

30+ ( Builder, byteString, char8, stringUtf8

31+ , intDec, int8Dec, int16Dec, int32Dec, int64Dec, integerDec

32+ , wordDec, word8Dec, word16Dec, word32Dec, word64Dec

33+ , floatDec, doubleDec

34+ )

35+import Data.Functor.Identity (Identity(Identity))

3036import Data.Int (Int8, Int16, Int32, Int64)

3137import Data.List (intersperse)

3238import Data.Monoid (mappend)

33−import Data.Time (Day, TimeOfDay, LocalTime, UTCTime, ZonedTime, NominalDiffTime)

39+import Data.Time.Compat (Day, TimeOfDay, LocalTime, UTCTime, ZonedTime, NominalDiffTime)

40+import Data.Time.LocalTime.Compat (CalendarDiffTime)

3441import Data.Typeable (Typeable)

3542import Data.Word (Word, Word8, Word16, Word32, Word64)

3643import {-# SOURCE #-} Database.PostgreSQL.Simple.ToRow

3744import Database.PostgreSQL.Simple.Types

38−import qualified Blaze.ByteString.Builder.Char.Utf8 as Utf8

45+import Database.PostgreSQL.Simple.Compat (toByteString)

46+

3947import qualified Data.ByteString as SB

4048import qualified Data.ByteString.Lazy as LB

49+import Data.CaseInsensitive (CI)

50+import qualified Data.CaseInsensitive as CI

4151import qualified Data.Text as ST

4252import qualified Data.Text.Encoding as ST

4353import qualified Data.Text.Lazy as LT

4454import qualified Data.Text.Lazy.Builder as LT

45−import Data.UUID (UUID)

46−import qualified Data.UUID as UUID

55+import Data.UUID.Types (UUID)

56+import qualified Data.UUID.Types as UUID

4757import Data.Vector (Vector)

4858import qualified Data.Vector as V

4959import qualified Database.PostgreSQL.LibPQ as PQ

5060import Database.PostgreSQL.Simple.Time

5161import Data.Scientific (Scientific)

52−#if MIN_VERSION_scientific(0,3,0)

5362import Data.Text.Lazy.Builder.Scientific (scientificBuilder)

54−#else

55−import Data.Scientific (scientificBuilder)

56−#endif

63+import Foreign.C.Types (CUInt(..))

5764

5865-- | How to render an element when substituting it into a query.

5966data Action =

@@ -93,90 +100,98 @@ instance ToField Action where

93100 toField a = a

94101 {-# INLINE toField #-}

95102

103+instance (ToField a) => ToField (Const a b) where

104+ toField (Const a) = toField a

105+ {-# INLINE toField #-}

106+

107+instance (ToField a) => ToField (Identity a) where

108+ toField (Identity a) = toField a

109+ {-# INLINE toField #-}

110+

96111instance (ToField a) => ToField (Maybe a) where

97112 toField Nothing = renderNull

98113 toField (Just a) = toField a

99114 {-# INLINE toField #-}

100115

101116instance (ToField a) => ToField (In [a]) where

102− toField (In []) = Plain $ fromByteString "(null)"

117+ toField (In []) = Plain $ byteString "(null)"

103118 toField (In xs) = Many $

104− Plain (fromChar '(') :

105− (intersperse (Plain (fromChar ',')) . map toField $ xs) ++

106− [Plain (fromChar ')')]

119+ Plain (char8 '(') :

120+ (intersperse (Plain (char8 ',')) . map toField $ xs) ++

121+ [Plain (char8 ')')]

107122

108123renderNull :: Action

109−renderNull = Plain (fromByteString "null")

124+renderNull = Plain (byteString "null")

110125

111126instance ToField Null where

112127 toField _ = renderNull

113128 {-# INLINE toField #-}

114129

115130instance ToField Default where

116− toField _ = Plain (fromByteString "default")

131+ toField _ = Plain (byteString "default")

117132 {-# INLINE toField #-}

118133

119134instance ToField Bool where

120− toField True = Plain (fromByteString "true")

121− toField False = Plain (fromByteString "false")

135+ toField True = Plain (byteString "true")

136+ toField False = Plain (byteString "false")

122137 {-# INLINE toField #-}

123138

124139instance ToField Int8 where

125− toField = Plain . integral

140+ toField = Plain . int8Dec

126141 {-# INLINE toField #-}

127142

128143instance ToField Int16 where

129− toField = Plain . integral

144+ toField = Plain . int16Dec

130145 {-# INLINE toField #-}

131146

132147instance ToField Int32 where

133− toField = Plain . integral

148+ toField = Plain . int32Dec

134149 {-# INLINE toField #-}

135150

136151instance ToField Int where

137− toField = Plain . integral

152+ toField = Plain . intDec

138153 {-# INLINE toField #-}

139154

140155instance ToField Int64 where

141− toField = Plain . integral

156+ toField = Plain . int64Dec

142157 {-# INLINE toField #-}

143158

144159instance ToField Integer where

145− toField = Plain . integral

160+ toField = Plain . integerDec

146161 {-# INLINE toField #-}

147162

148163instance ToField Word8 where

149− toField = Plain . integral

164+ toField = Plain . word8Dec

150165 {-# INLINE toField #-}

151166

152167instance ToField Word16 where

153− toField = Plain . integral

168+ toField = Plain . word16Dec

154169 {-# INLINE toField #-}

155170

156171instance ToField Word32 where

157− toField = Plain . integral

172+ toField = Plain . word32Dec

158173 {-# INLINE toField #-}

159174

160175instance ToField Word where

161− toField = Plain . integral

176+ toField = Plain . wordDec

162177 {-# INLINE toField #-}

163178

164179instance ToField Word64 where

165− toField = Plain . integral

180+ toField = Plain . word64Dec

166181 {-# INLINE toField #-}

167182

168183instance ToField PQ.Oid where

169− toField = Plain . integral . \(PQ.Oid x) -> x

184+ toField = Plain . \(PQ.Oid (CUInt x)) -> word32Dec x

170185 {-# INLINE toField #-}

171186

172187instance ToField Float where

173− toField v | isNaN v || isInfinite v = Plain (inQuotes (float v))

174− | otherwise = Plain (float v)

188+ toField v | isNaN v || isInfinite v = Plain (inQuotes (floatDec v))

189+ | otherwise = Plain (floatDec v)

175190 {-# INLINE toField #-}

176191

177192instance ToField Double where

178− toField v | isNaN v || isInfinite v = Plain (inQuotes (double v))

179− | otherwise = Plain (double v)

193+ toField v | isNaN v || isInfinite v = Plain (inQuotes (doubleDec v))

194+ | otherwise = Plain (doubleDec v)

180195 {-# INLINE toField #-}

181196

182197instance ToField Scientific where

@@ -198,7 +213,7 @@ instance ToField Identifier where

198213instance ToField QualifiedIdentifier where

199214 toField (QualifiedIdentifier (Just s) t) =

200215 Many [ EscapeIdentifier (ST.encodeUtf8 s)

201− , Plain (fromChar '.')

216+ , Plain (char8 '.')

202217 , EscapeIdentifier (ST.encodeUtf8 t)

203218 ]

204219 toField (QualifiedIdentifier Nothing t) =

@@ -218,13 +233,22 @@ instance ToField ST.Text where

218233 {-# INLINE toField #-}

219234

220235instance ToField [Char] where

221− toField = Escape . toByteString . Utf8.fromString

236+ toField = Escape . toByteString . stringUtf8

222237 {-# INLINE toField #-}

223238

224239instance ToField LT.Text where

225240 toField = toField . LT.toStrict

226241 {-# INLINE toField #-}

227242

243+-- | citext

244+instance ToField (CI ST.Text) where

245+ toField = toField . CI.original

246+ {-# INLINE toField #-}

247+

248+-- | citext

249+instance ToField (CI LT.Text) where

250+ toField = toField . LT.toStrict . CI.original

251+ {-# INLINE toField #-}

228252

229253instance ToField UTCTime where

230254 toField = Plain . inQuotes . utcTimeToBuilder

@@ -266,41 +290,47 @@ instance ToField NominalDiffTime where

266290 toField = Plain . inQuotes . nominalDiffTimeToBuilder

267291 {-# INLINE toField #-}

268292

293+instance ToField CalendarDiffTime where

294+ toField = Plain . inQuotes . calendarDiffTimeToBuilder

295+ {-# INLINE toField #-}

296+

269297instance (ToField a) => ToField (PGArray a) where

270− toField xs = Many $

271− Plain (fromByteString "ARRAY[") :

272− (intersperse (Plain (fromChar ',')) . map toField $ fromPGArray xs) ++

273− [Plain (fromChar ']')]

274− -- Because the ARRAY[...] input syntax is being used, it is possible

275− -- that the use of type-specific separator characters is unnecessary.

298+ toField pgArray =

299+ case fromPGArray pgArray of

300+ [] -> Plain (byteString "'{}'")

301+ xs -> Many $

302+ Plain (byteString "ARRAY[") :

303+ (intersperse (Plain (char8 ',')) . map toField $ xs) ++

304+ [Plain (char8 ']')]

305+ -- Because the ARRAY[...] input syntax is being used, it is possible

306+ -- that the use of type-specific separator characters is unnecessary.

276307

277308instance (ToField a) => ToField (Vector a) where

278309 toField = toField . PGArray . V.toList

279310

280311instance ToField UUID where

281− toField = Plain . inQuotes . fromByteString . UUID.toASCIIBytes

312+ toField = Plain . inQuotes . byteString . UUID.toASCIIBytes

282313

283314instance ToField JSON.Value where

284315 toField = toField . JSON.encode

285316

286−-- | Convert a Haskell value to a JSON 'JSON.Value' using

287−-- 'JSON.toJSON' and convert that to a field using 'toField'.

317+-- | Convert a Haskell value to JSON using 'JSON.toEncoding'.

288318--

289319-- This can be used as the default implementation for the 'toField'

290320-- method for Haskell types that have a JSON representation in

291321-- PostgreSQL.

292322toJSONField :: JSON.ToJSON a => a -> Action

293−toJSONField = toField . JSON.toJSON

323+toJSONField = toField . JSON.encode

294324

295325-- | Surround a string with single-quote characters: \"@'@\"

296326--

297327-- This function /does not/ perform any other escaping.

298328inQuotes :: Builder -> Builder

299329inQuotes b = quote `mappend` b `mappend` quote

300− where quote = Utf8.fromChar '\''

330+ where quote = char8 '\''

301331

302332interleaveFoldr :: (a -> [b] -> [b]) -> b -> [b] -> [a] -> [b]

303−interleaveFoldr f b bs as = foldr (\a bs -> b : f a bs) bs as

333+interleaveFoldr f b bs' as = foldr (\a bs -> b : f a bs) bs' as

304334{-# INLINE interleaveFoldr #-}

305335

306336instance ToRow a => ToField (Values a) where

@@ -318,8 +348,8 @@ instance ToRow a => ToField (Values a) where

318348 funcname = "Database.PostgreSQL.Simple.toField :: Values a -> Action"

319349 norows = funcname ++ " either values or types must be non-empty"

320350 emptyrow = funcname ++ " each row must contain at least one column"

321− lit = Plain . fromByteString

322− litC = Plain . fromChar

351+ lit = Plain . byteString

352+ litC = Plain . char8

323353 values x = Many (lit "(VALUES ": x)

324354

325355 typedField :: (Action, QualifiedIdentifier) -> [Action] -> [Action]

@@ -347,8 +377,8 @@ instance ToRow a => ToField (Values a) where

347377

348378 typedRows :: ToRow a => [a] -> [QualifiedIdentifier] -> [Action] -> [Action]

349379 typedRows [] _ _ = error funcname

350− typedRows (val:vals) types rest =

351− typedRow (toRow val) types (multiRows vals rest)

380+ typedRows (val:vals) typs rest =

381+ typedRow (toRow val) typs (multiRows vals rest)

352382

353383 untypedRows :: ToRow a => [a] -> [Action] -> [Action]

354384 untypedRows [] _ = error funcname

src/Database/PostgreSQL/Simple/ToField.hs-boot+1−1

@@ -1,7 +1,7 @@

11module Database.PostgreSQL.Simple.ToField where

33import Database.PostgreSQL.Simple.Types

4−import Blaze.ByteString.Builder(Builder)

4+import Data.ByteString.Builder(Builder)

55import Data.ByteString(ByteString)

77-- | How to render an element when substituting it into a query.

src/Database/PostgreSQL/Simple/ToRow.hs+127

@@ -1,3 +1,4 @@

1+{-# LANGUAGE DefaultSignatures, FlexibleInstances, FlexibleContexts #-}

12------------------------------------------------------------------------------

23-- |

34-- Module: Database.PostgreSQL.Simple.ToRow

@@ -22,14 +23,33 @@ module Database.PostgreSQL.Simple.ToRow

2223

2324import Database.PostgreSQL.Simple.ToField (Action(..), ToField(..))

2425import Database.PostgreSQL.Simple.Types (Only(..), (:.)(..))

26+import GHC.Generics

2527

2628-- | A collection type that can be turned into a list of rendering

2729-- 'Action's.

2830--

2931-- Instances should use the 'toField' method of the 'ToField' class

3032-- to perform conversion of each element of the collection.

33+--

34+-- You can derive 'ToRow' for your data type using GHC generics, like this:

35+--

36+-- @

37+-- \{-# LANGUAGE DeriveAnyClass \#-}

38+-- \{-# LANGUAGE DeriveGeneric \#-}

39+--

40+-- import "GHC.Generics" ('GHC.Generics.Generic')

41+-- import "Database.PostgreSQL.Simple" ('ToRow')

42+--

43+-- data User = User { name :: String, fileQuota :: Int }

44+-- deriving ('GHC.Generics.Generic', 'ToRow')

45+-- @

46+--

47+-- Note that this only works for product types (e.g. records) and does not

48+-- support sum types or recursive types.

3149class ToRow a where

3250 toRow :: a -> [Action]

51+ default toRow :: (Generic a, GToRow (Rep a)) => a -> [Action]

52+ toRow = gtoRow . from

3353 -- ^ ToField a collection of values.

3454

3555instance ToRow () where

@@ -85,8 +105,115 @@ instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,

85105 [toField a, toField b, toField c, toField d, toField e, toField f,

86106 toField g, toField h, toField i, toField j]

87107

108+instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,

109+ ToField g, ToField h, ToField i, ToField j, ToField k)

110+ => ToRow (a,b,c,d,e,f,g,h,i,j,k) where

111+ toRow (a,b,c,d,e,f,g,h,i,j,k) =

112+ [toField a, toField b, toField c, toField d, toField e, toField f,

113+ toField g, toField h, toField i, toField j, toField k]

114+

115+instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,

116+ ToField g, ToField h, ToField i, ToField j, ToField k, ToField l)

117+ => ToRow (a,b,c,d,e,f,g,h,i,j,k,l) where

118+ toRow (a,b,c,d,e,f,g,h,i,j,k,l) =

119+ [toField a, toField b, toField c, toField d, toField e, toField f,

120+ toField g, toField h, toField i, toField j, toField k, toField l]

121+

122+instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,

123+ ToField g, ToField h, ToField i, ToField j, ToField k, ToField l,

124+ ToField m)

125+ => ToRow (a,b,c,d,e,f,g,h,i,j,k,l,m) where

126+ toRow (a,b,c,d,e,f,g,h,i,j,k,l,m) =

127+ [toField a, toField b, toField c, toField d, toField e, toField f,

128+ toField g, toField h, toField i, toField j, toField k, toField l,

129+ toField m]

130+

131+instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,

132+ ToField g, ToField h, ToField i, ToField j, ToField k, ToField l,

133+ ToField m, ToField n)

134+ => ToRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n) where

135+ toRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n) =

136+ [toField a, toField b, toField c, toField d, toField e, toField f,

137+ toField g, toField h, toField i, toField j, toField k, toField l,

138+ toField m, toField n]

139+

140+instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,

141+ ToField g, ToField h, ToField i, ToField j, ToField k, ToField l,

142+ ToField m, ToField n, ToField o)

143+ => ToRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) where

144+ toRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) =

145+ [toField a, toField b, toField c, toField d, toField e, toField f,

146+ toField g, toField h, toField i, toField j, toField k, toField l,

147+ toField m, toField n, toField o]

148+

149+instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,

150+ ToField g, ToField h, ToField i, ToField j, ToField k, ToField l,

151+ ToField m, ToField n, ToField o, ToField p)

152+ => ToRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) where

153+ toRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) =

154+ [toField a, toField b, toField c, toField d, toField e, toField f,

155+ toField g, toField h, toField i, toField j, toField k, toField l,

156+ toField m, toField n, toField o, toField p]

157+

158+instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,

159+ ToField g, ToField h, ToField i, ToField j, ToField k, ToField l,

160+ ToField m, ToField n, ToField o, ToField p, ToField q)

161+ => ToRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q) where

162+ toRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q) =

163+ [toField a, toField b, toField c, toField d, toField e, toField f,

164+ toField g, toField h, toField i, toField j, toField k, toField l,

165+ toField m, toField n, toField o, toField p, toField q]

166+

167+instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,

168+ ToField g, ToField h, ToField i, ToField j, ToField k, ToField l,

169+ ToField m, ToField n, ToField o, ToField p, ToField q, ToField r)

170+ => ToRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r) where

171+ toRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r) =

172+ [toField a, toField b, toField c, toField d, toField e, toField f,

173+ toField g, toField h, toField i, toField j, toField k, toField l,

174+ toField m, toField n, toField o, toField p, toField q, toField r]

175+

176+instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,

177+ ToField g, ToField h, ToField i, ToField j, ToField k, ToField l,

178+ ToField m, ToField n, ToField o, ToField p, ToField q, ToField r,

179+ ToField s)

180+ => ToRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s) where

181+ toRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s) =

182+ [toField a, toField b, toField c, toField d, toField e, toField f,

183+ toField g, toField h, toField i, toField j, toField k, toField l,

184+ toField m, toField n, toField o, toField p, toField q, toField r,

185+ toField s]

186+

187+instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,

188+ ToField g, ToField h, ToField i, ToField j, ToField k, ToField l,

189+ ToField m, ToField n, ToField o, ToField p, ToField q, ToField r,

190+ ToField s, ToField t)

191+ => ToRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t) where

192+ toRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t) =

193+ [toField a, toField b, toField c, toField d, toField e, toField f,

194+ toField g, toField h, toField i, toField j, toField k, toField l,

195+ toField m, toField n, toField o, toField p, toField q, toField r,

196+ toField s, toField t]

197+

88198instance (ToField a) => ToRow [a] where

89199 toRow = map toField

90200

91201instance (ToRow a, ToRow b) => ToRow (a :. b) where

92202 toRow (a :. b) = toRow a ++ toRow b

203+

204+

205+-- Type class for default implementation of ToRow using generics

206+class GToRow f where

207+ gtoRow :: f p -> [Action]

208+

209+instance GToRow f => GToRow (M1 c i f) where

210+ gtoRow (M1 x) = gtoRow x

211+

212+instance (GToRow f, GToRow g) => GToRow (f :*: g) where

213+ gtoRow (f :*: g) = gtoRow f ++ gtoRow g

214+

215+instance (ToField a) => GToRow (K1 R a) where

216+ gtoRow (K1 a) = [toField a]

217+

218+instance GToRow U1 where

219+ gtoRow _ = []

src/Database/PostgreSQL/Simple/ToRow.hs-boot+10−1

@@ -1,9 +1,18 @@

1−module Database.PostgreSQL.Simple.ToRow where

1+{-# LANGUAGE DefaultSignatures, FlexibleInstances, FlexibleContexts #-}

2+module Database.PostgreSQL.Simple.ToRow (

3+ ToRow(..)

4+ ) where

36import Database.PostgreSQL.Simple.Types

47import {-# SOURCE #-} Database.PostgreSQL.Simple.ToField

8+import GHC.Generics

610class ToRow a where

711 toRow :: a -> [Action]

12+ default toRow :: (Generic a, GToRow (Rep a)) => a -> [Action]

13+ toRow = gtoRow . from

14+

15+class GToRow f where

16+ gtoRow :: f p -> [Action]

817

918instance ToField a => ToRow (Only a)

src/Database/PostgreSQL/Simple/Transaction.hs+35−17

@@ -1,4 +1,14 @@

1−{-# LANGUAGE RecordWildCards #-}

1+{-# LANGUAGE RecordWildCards, ScopedTypeVariables #-}

3+------------------------------------------------------------------------------

4+-- |

5+-- Module: Database.PostgreSQL.Simple.Transaction

8+-- License: BSD3

9+-- Maintainer: Leon P Smith <leon@melding-monads.com>

10+--

11+------------------------------------------------------------------------------

212

313module Database.PostgreSQL.Simple.Transaction

414 (

@@ -7,6 +17,7 @@ module Database.PostgreSQL.Simple.Transaction

717 , withTransactionLevel

818 , withTransactionMode

919 , withTransactionModeRetry

20+ , withTransactionModeRetry'

1021 , withTransactionSerializable

1122 , TransactionMode(..)

1223 , IsolationLevel(..)

@@ -45,7 +56,7 @@ import Database.PostgreSQL.Simple.Compat (mask, (<>))

4556

4657-- | Of the four isolation levels defined by the SQL standard,

4758-- these are the three levels distinguished by PostgreSQL as of version 9.0.

48−-- See <http://www.postgresql.org/docs/9.1/static/transaction-iso.html>

59+-- See <https://www.postgresql.org/docs/9.5/static/transaction-iso.html>

4960-- for more information. Note that prior to PostgreSQL 9.0, 'RepeatableRead'

5061-- was equivalent to 'Serializable'.

5162

@@ -132,41 +143,48 @@ withTransactionMode :: TransactionMode -> Connection -> IO a -> IO a

132143withTransactionMode mode conn act =

133144 mask $ \restore -> do

134145 beginMode mode conn

135− r <- restore act `E.onException` rollback conn

146+ r <- restore act `E.onException` rollback_ conn

136147 commit conn

137148 return r

138149

150+-- | 'withTransactionModeRetry'' but with the exception type pinned to 'SqlError'.

151+withTransactionModeRetry :: TransactionMode -> (SqlError -> Bool) -> Connection -> IO a -> IO a

152+withTransactionModeRetry = withTransactionModeRetry'

153+

139154-- | Like 'withTransactionMode', but also takes a custom callback to

140−-- determine if a transaction should be retried if an 'SqlError' occurs.

141−-- If the callback returns True, then the transaction will be retried.

142−-- If the callback returns False, or an exception other than an 'SqlError'

155+-- determine if a transaction should be retried if an exception occurs.

156+-- If the callback returns 'True', then the transaction will be retried.

157+-- If the callback returns 'False', or an exception other than an @e@

143158-- occurs then the transaction will be rolled back and the exception rethrown.

144159--

145160-- This is used to implement 'withTransactionSerializable'.

146−withTransactionModeRetry :: TransactionMode -> (SqlError -> Bool) -> Connection -> IO a -> IO a

147−withTransactionModeRetry mode shouldRetry conn act =

161+withTransactionModeRetry' :: forall a e. E.Exception e => TransactionMode -> (e -> Bool) -> Connection -> IO a -> IO a

162+withTransactionModeRetry' mode shouldRetry conn act =

148163 mask $ \restore ->

149164 retryLoop $ E.try $ do

150− a <- restore act

165+ a <- restore act `E.onException` rollback_ conn

151166 commit conn

152167 return a

153168 where

154− retryLoop :: IO (Either E.SomeException a) -> IO a

169+ retryLoop :: IO (Either e a) -> IO a

155170 retryLoop act' = do

156171 beginMode mode conn

157172 r <- act'

158173 case r of

159− Left e -> do

160− rollback conn

161− case fmap shouldRetry (E.fromException e) of

162− Just True -> retryLoop act'

163− _ -> E.throwIO e

174+ Left e ->

175+ case shouldRetry e of

176+ True -> retryLoop act'

177+ False -> E.throwIO e

164178 Right a ->

165179 return a

166180

167181-- | Rollback a transaction.

168182rollback :: Connection -> IO ()

169−rollback conn = execute_ conn "ABORT" >> return ()

183+rollback conn = execute_ conn "ROLLBACK" >> return ()

184+

185+-- | Rollback a transaction, ignoring any @IOErrors@

186+rollback_ :: Connection -> IO ()

187+rollback_ conn = rollback conn `E.catch` \(_ :: IOError) -> return ()

170188

171189-- | Commit a transaction.

172190commit :: Connection -> IO ()

@@ -203,7 +221,7 @@ beginMode mode conn = do

203221-- be used inside of a transaction, and provides a sort of

204222-- \"nested transaction\".

205223--

206−-- See <http://www.postgresql.org/docs/current/static/sql-savepoint.html>

224+-- See <https://www.postgresql.org/docs/9.5/static/sql-savepoint.html>

207225withSavepoint :: Connection -> IO a -> IO a

208226withSavepoint conn body =

209227 mask $ \restore -> do

src/Database/PostgreSQL/Simple/TypeInfo.hs+9−9

@@ -50,21 +50,21 @@ import Database.PostgreSQL.Simple.TypeInfo.Static

5050-- in the connections's cache.

5151

5252getTypeInfo :: Connection -> PQ.Oid -> IO TypeInfo

53−getTypeInfo conn@Connection{..} oid =

54− case staticTypeInfo oid of

55− Just name -> return name

56− Nothing -> modifyMVar connectionObjects $ getTypeInfo' conn oid

53+getTypeInfo conn@Connection{..} oid' =

54+ case staticTypeInfo oid' of

55+ Just name' -> return name'

56+ Nothing -> modifyMVar connectionObjects $ getTypeInfo' conn oid'

5757

5858getTypeInfo' :: Connection -> PQ.Oid -> TypeInfoCache

5959 -> IO (TypeInfoCache, TypeInfo)

60−getTypeInfo' conn oid oidmap =

61− case IntMap.lookup (oid2int oid) oidmap of

60+getTypeInfo' conn oid' oidmap =

61+ case IntMap.lookup (oid2int oid') oidmap of

6262 Just typeinfo -> return (oidmap, typeinfo)

6363 Nothing -> do

6464 names <- query conn "SELECT oid, typcategory, typdelim, typname,\

6565 \ typelem, typrelid\

6666 \ FROM pg_type WHERE oid = ?"

67− (Only oid)

67+ (Only oid')

6868 (oidmap', typeInfo) <-

6969 case names of

7070 [] -> return $ throw (fatalError "invalid type oid")

@@ -78,7 +78,7 @@ getTypeInfo' conn oid oidmap =

7878 rngsubtypeOids <- query conn "SELECT rngsubtype\

7979 \ FROM pg_range\

8080 \ WHERE rngtypid = ?"

81− (Only oid)

81+ (Only oid')

8282 case rngsubtypeOids of

8383 [Only rngsubtype_] -> do

8484 (oidmap', rngsubtype) <-

@@ -104,7 +104,7 @@ getTypeInfo' conn oid oidmap =

104104 _ -> fail "typename query returned more than one result"

105105 -- oid is a primary key, so the query should

106106 -- never return more than one result

107− let !oidmap'' = IntMap.insert (oid2int oid) typeInfo oidmap'

107+ let !oidmap'' = IntMap.insert (oid2int oid') typeInfo oidmap'

108108 return $! (oidmap'', typeInfo)

109109

110110getAttInfos :: Connection -> [(B.ByteString, PQ.Oid)] -> TypeInfoCache

src/Database/PostgreSQL/Simple/TypeInfo/Macro.hs+9−3

@@ -1,4 +1,9 @@

1+{-# LANGUAGE CPP #-}

2+#if __GLASGOW_HASKELL__ >= 800

3+{-# LANGUAGE TemplateHaskellQuotes #-}

4+#else

15{-# LANGUAGE TemplateHaskell #-}

6+#endif

38------------------------------------------------------------------------------

49-- |

@@ -22,11 +27,12 @@ import Database.PostgreSQL.Simple.TypeInfo.Static

2227import Database.PostgreSQL.Simple.Types (Oid(..))

2328import Language.Haskell.TH

2429

25−

2630-- | Returns an expression that has type @'Oid' -> 'Bool'@, true if the

2731-- oid is equal to any one of the 'typoid's of the given 'TypeInfo's.

2832mkCompats :: [TypeInfo] -> ExpQ

29−mkCompats tys = [| \(Oid x) -> $(caseE [| x |] (map alt tys ++ [catchAll])) |]

33+mkCompats tys = do

34+ x <- newName "x"

35+ lamE [conP 'Oid [varP x]] $ caseE (varE x) (map alt tys ++ [catchAll])

3036 where

3137 alt :: TypeInfo -> MatchQ

3238 alt ty = match (inlineTypoidP ty) (normalB [| True |]) []

@@ -38,7 +44,7 @@ mkCompats tys = [| \(Oid x) -> $(caseE [| x |] (map alt tys ++ [catchAll])) |]

3844-- Returns an expression of type 'Oid'. Useful because GHC tends

3945-- not to fold constants.

4046inlineTypoid :: TypeInfo -> ExpQ

41−inlineTypoid ty = [| Oid $(litE (getTypoid ty)) |]

47+inlineTypoid ty = conE 'Oid `appE` litE (getTypoid ty)

4248

4349inlineTypoidP :: TypeInfo -> PatQ

4450inlineTypoidP ty = litP (getTypoid ty)

src/Database/PostgreSQL/Simple/TypeInfo/Static.hs+1368−74

@@ -19,53 +19,233 @@ module Database.PostgreSQL.Simple.TypeInfo.Static

1919 ( TypeInfo(..)

2020 , staticTypeInfo

2121 , bool

22+ , boolOid

2223 , bytea

24+ , byteaOid

2325 , char

26+ , charOid

2427 , name

28+ , nameOid

2529 , int8

30+ , int8Oid

2631 , int2

32+ , int2Oid

2733 , int4

34+ , int4Oid

2835 , regproc

36+ , regprocOid

2937 , text

38+ , textOid

3039 , oid

40+ , oidOid

3141 , tid

42+ , tidOid

3243 , xid

44+ , xidOid

3345 , cid

46+ , cidOid

3447 , xml

48+ , xmlOid

3549 , point

50+ , pointOid

3651 , lseg

52+ , lsegOid

3753 , path

54+ , pathOid

3855 , box

56+ , boxOid

3957 , polygon

58+ , polygonOid

4059 , line

60+ , lineOid

4161 , cidr

62+ , cidrOid

4263 , float4

64+ , float4Oid

4365 , float8

44− , abstime

45− , reltime

46− , tinterval

66+ , float8Oid

4767 , unknown

68+ , unknownOid

4869 , circle

70+ , circleOid

4971 , money

72+ , moneyOid

5073 , macaddr

74+ , macaddrOid

5175 , inet

76+ , inetOid

5277 , bpchar

78+ , bpcharOid

5379 , varchar

80+ , varcharOid

5481 , date

82+ , dateOid

5583 , time

84+ , timeOid

5685 , timestamp

86+ , timestampOid

5787 , timestamptz

88+ , timestamptzOid

5889 , interval

90+ , intervalOid

5991 , timetz

92+ , timetzOid

6093 , bit

94+ , bitOid

6195 , varbit

96+ , varbitOid

6297 , numeric

98+ , numericOid

6399 , refcursor

100+ , refcursorOid

64101 , record

102+ , recordOid

65103 , void

104+ , voidOid

105+ , array_record

106+ , array_recordOid

107+ , regprocedure

108+ , regprocedureOid

109+ , regoper

110+ , regoperOid

111+ , regoperator

112+ , regoperatorOid

113+ , regclass

114+ , regclassOid

115+ , regtype

116+ , regtypeOid

66117 , uuid

118+ , uuidOid

67119 , json

120+ , jsonOid

68121 , 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

69249 ) where

70250

71251import Database.PostgreSQL.LibPQ (Oid(..))

@@ -96,9 +276,6 @@ staticTypeInfo (Oid x) = case x of

96276 650 -> Just cidr

97277 700 -> Just float4

98278 701 -> Just float8

99− 702 -> Just abstime

100− 703 -> Just reltime

101− 704 -> Just tinterval

102279 705 -> Just unknown

103280 718 -> Just circle

104281 790 -> Just money

@@ -118,391 +295,1508 @@ staticTypeInfo (Oid x) = case x of

118295 1790 -> Just refcursor

119296 2249 -> Just record

120297 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

121304 2950 -> Just uuid

122305 114 -> Just json

123306 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

124370 _ -> Nothing

125371

126372bool :: TypeInfo

127373bool = Basic {

128− typoid = Oid 16,

374+ typoid = boolOid,

129375 typcategory = 'B',

130376 typdelim = ',',

131377 typname = "bool"

132378 }

133379

380+boolOid :: Oid

381+boolOid = Oid 16

382+{-# INLINE boolOid #-}

383+

134384bytea :: TypeInfo

135385bytea = Basic {

136− typoid = Oid 17,

386+ typoid = byteaOid,

137387 typcategory = 'U',

138388 typdelim = ',',

139389 typname = "bytea"

140390 }

141391

392+byteaOid :: Oid

393+byteaOid = Oid 17

394+{-# INLINE byteaOid #-}

395+

142396char :: TypeInfo

143397char = Basic {

144− typoid = Oid 18,

398+ typoid = charOid,

145399 typcategory = 'S',

146400 typdelim = ',',

147401 typname = "char"

148402 }

149403

404+charOid :: Oid

405+charOid = Oid 18

406+{-# INLINE charOid #-}

407+

150408name :: TypeInfo

151409name = Basic {

152− typoid = Oid 19,

410+ typoid = nameOid,

153411 typcategory = 'S',

154412 typdelim = ',',

155413 typname = "name"

156414 }

157415

416+nameOid :: Oid

417+nameOid = Oid 19

418+{-# INLINE nameOid #-}

419+

158420int8 :: TypeInfo

159421int8 = Basic {

160− typoid = Oid 20,

422+ typoid = int8Oid,

161423 typcategory = 'N',

162424 typdelim = ',',

163425 typname = "int8"

164426 }

165427

428+int8Oid :: Oid

429+int8Oid = Oid 20

430+{-# INLINE int8Oid #-}

431+

166432int2 :: TypeInfo

167433int2 = Basic {

168− typoid = Oid 21,

434+ typoid = int2Oid,

169435 typcategory = 'N',

170436 typdelim = ',',

171437 typname = "int2"

172438 }

173439

440+int2Oid :: Oid

441+int2Oid = Oid 21

442+{-# INLINE int2Oid #-}

443+

174444int4 :: TypeInfo

175445int4 = Basic {

176− typoid = Oid 23,

446+ typoid = int4Oid,

177447 typcategory = 'N',

178448 typdelim = ',',

179449 typname = "int4"

180450 }

181451

452+int4Oid :: Oid

453+int4Oid = Oid 23

454+{-# INLINE int4Oid #-}

455+

182456regproc :: TypeInfo

183457regproc = Basic {

184− typoid = Oid 24,

458+ typoid = regprocOid,

185459 typcategory = 'N',

186460 typdelim = ',',

187461 typname = "regproc"

188462 }

189463

464+regprocOid :: Oid

465+regprocOid = Oid 24

466+{-# INLINE regprocOid #-}

467+

190468text :: TypeInfo

191469text = Basic {

192− typoid = Oid 25,

470+ typoid = textOid,

193471 typcategory = 'S',

194472 typdelim = ',',

195473 typname = "text"

196474 }

197475

476+textOid :: Oid

477+textOid = Oid 25

478+{-# INLINE textOid #-}

479+

198480oid :: TypeInfo

199481oid = Basic {

200− typoid = Oid 26,

482+ typoid = oidOid,

201483 typcategory = 'N',

202484 typdelim = ',',

203485 typname = "oid"

204486 }

205487

488+oidOid :: Oid

489+oidOid = Oid 26

490+{-# INLINE oidOid #-}

491+

206492tid :: TypeInfo

207493tid = Basic {

208− typoid = Oid 27,

494+ typoid = tidOid,

209495 typcategory = 'U',

210496 typdelim = ',',

211497 typname = "tid"

212498 }

213499

500+tidOid :: Oid

501+tidOid = Oid 27

502+{-# INLINE tidOid #-}

503+

214504xid :: TypeInfo

215505xid = Basic {

216− typoid = Oid 28,

506+ typoid = xidOid,

217507 typcategory = 'U',

218508 typdelim = ',',

219509 typname = "xid"

220510 }

221511

512+xidOid :: Oid

513+xidOid = Oid 28

514+{-# INLINE xidOid #-}

515+

222516cid :: TypeInfo

223517cid = Basic {

224− typoid = Oid 29,

518+ typoid = cidOid,

225519 typcategory = 'U',

226520 typdelim = ',',

227521 typname = "cid"

228522 }

229523

524+cidOid :: Oid

525+cidOid = Oid 29

526+{-# INLINE cidOid #-}

527+

230528xml :: TypeInfo

231529xml = Basic {

232− typoid = Oid 142,

530+ typoid = xmlOid,

233531 typcategory = 'U',

234532 typdelim = ',',

235533 typname = "xml"

236534 }

237535

536+xmlOid :: Oid

537+xmlOid = Oid 142

538+{-# INLINE xmlOid #-}

539+

238540point :: TypeInfo

239541point = Basic {

240− typoid = Oid 600,

542+ typoid = pointOid,

241543 typcategory = 'G',

242544 typdelim = ',',

243545 typname = "point"

244546 }

245547

548+pointOid :: Oid

549+pointOid = Oid 600

550+{-# INLINE pointOid #-}

551+

246552lseg :: TypeInfo

247553lseg = Basic {

248− typoid = Oid 601,

554+ typoid = lsegOid,

249555 typcategory = 'G',

250556 typdelim = ',',

251557 typname = "lseg"

252558 }

253559

560+lsegOid :: Oid

561+lsegOid = Oid 601

562+{-# INLINE lsegOid #-}

563+

254564path :: TypeInfo

255565path = Basic {

256− typoid = Oid 602,

566+ typoid = pathOid,

257567 typcategory = 'G',

258568 typdelim = ',',

259569 typname = "path"

260570 }

261571

572+pathOid :: Oid

573+pathOid = Oid 602

574+{-# INLINE pathOid #-}

575+

262576box :: TypeInfo

263577box = Basic {

264− typoid = Oid 603,

578+ typoid = boxOid,

265579 typcategory = 'G',

266580 typdelim = ';',

267581 typname = "box"

268582 }

269583

584+boxOid :: Oid

585+boxOid = Oid 603

586+{-# INLINE boxOid #-}

587+

270588polygon :: TypeInfo

271589polygon = Basic {

272− typoid = Oid 604,

590+ typoid = polygonOid,

273591 typcategory = 'G',

274592 typdelim = ',',

275593 typname = "polygon"

276594 }

277595

596+polygonOid :: Oid

597+polygonOid = Oid 604

598+{-# INLINE polygonOid #-}

599+

278600line :: TypeInfo

279601line = Basic {

280− typoid = Oid 628,

602+ typoid = lineOid,

281603 typcategory = 'G',

282604 typdelim = ',',

283605 typname = "line"

284606 }

285607

608+lineOid :: Oid

609+lineOid = Oid 628

610+{-# INLINE lineOid #-}

611+

286612cidr :: TypeInfo

287613cidr = Basic {

288− typoid = Oid 650,

614+ typoid = cidrOid,

289615 typcategory = 'I',

290616 typdelim = ',',

291617 typname = "cidr"

292618 }

293619

620+cidrOid :: Oid

621+cidrOid = Oid 650

622+{-# INLINE cidrOid #-}

623+

294624float4 :: TypeInfo

295625float4 = Basic {

296− typoid = Oid 700,

626+ typoid = float4Oid,

297627 typcategory = 'N',

298628 typdelim = ',',

299629 typname = "float4"

300630 }

301631

632+float4Oid :: Oid

633+float4Oid = Oid 700

634+{-# INLINE float4Oid #-}

635+

302636float8 :: TypeInfo

303637float8 = Basic {

304− typoid = Oid 701,

638+ typoid = float8Oid,

305639 typcategory = 'N',

306640 typdelim = ',',

307641 typname = "float8"

308642 }

309643

310−abstime :: TypeInfo

311−abstime = Basic {

312− typoid = Oid 702,

313− typcategory = 'D',

314− typdelim = ',',

315− typname = "abstime"

316− }

317−

318−reltime :: TypeInfo

319−reltime = Basic {

320− typoid = Oid 703,

321− typcategory = 'T',

322− typdelim = ',',

323− typname = "reltime"

324− }

325−

326−tinterval :: TypeInfo

327−tinterval = Basic {

328− typoid = Oid 704,

329− typcategory = 'T',

330− typdelim = ',',

331− typname = "tinterval"

332− }

644+float8Oid :: Oid

645+float8Oid = Oid 701

646+{-# INLINE float8Oid #-}

333647

334648unknown :: TypeInfo

335649unknown = Basic {

336− typoid = Oid 705,

650+ typoid = unknownOid,

337651 typcategory = 'X',

338652 typdelim = ',',

339653 typname = "unknown"

340654 }

341655

656+unknownOid :: Oid

657+unknownOid = Oid 705

658+{-# INLINE unknownOid #-}

659+

342660circle :: TypeInfo

343661circle = Basic {

344− typoid = Oid 718,

662+ typoid = circleOid,

345663 typcategory = 'G',

346664 typdelim = ',',

347665 typname = "circle"

348666 }

349667

668+circleOid :: Oid

669+circleOid = Oid 718

670+{-# INLINE circleOid #-}

671+

350672money :: TypeInfo

351673money = Basic {

352− typoid = Oid 790,

674+ typoid = moneyOid,

353675 typcategory = 'N',

354676 typdelim = ',',

355677 typname = "money"

356678 }

357679

680+moneyOid :: Oid

681+moneyOid = Oid 790

682+{-# INLINE moneyOid #-}

683+

358684macaddr :: TypeInfo

359685macaddr = Basic {

360− typoid = Oid 829,

686+ typoid = macaddrOid,

361687 typcategory = 'U',

362688 typdelim = ',',

363689 typname = "macaddr"

364690 }

365691

692+macaddrOid :: Oid

693+macaddrOid = Oid 829

694+{-# INLINE macaddrOid #-}

695+

366696inet :: TypeInfo

367697inet = Basic {

368− typoid = Oid 869,

698+ typoid = inetOid,

369699 typcategory = 'I',

370700 typdelim = ',',

371701 typname = "inet"

372702 }

373703

704+inetOid :: Oid

705+inetOid = Oid 869

706+{-# INLINE inetOid #-}

707+

374708bpchar :: TypeInfo

375709bpchar = Basic {

376− typoid = Oid 1042,

710+ typoid = bpcharOid,

377711 typcategory = 'S',

378712 typdelim = ',',

379713 typname = "bpchar"

380714 }

381715

716+bpcharOid :: Oid

717+bpcharOid = Oid 1042

718+{-# INLINE bpcharOid #-}

719+

382720varchar :: TypeInfo

383721varchar = Basic {

384− typoid = Oid 1043,

722+ typoid = varcharOid,

385723 typcategory = 'S',

386724 typdelim = ',',

387725 typname = "varchar"

388726 }

389727

728+varcharOid :: Oid

729+varcharOid = Oid 1043

730+{-# INLINE varcharOid #-}

731+

390732date :: TypeInfo

391733date = Basic {

392− typoid = Oid 1082,

734+ typoid = dateOid,

393735 typcategory = 'D',

394736 typdelim = ',',

395737 typname = "date"

396738 }

397739

740+dateOid :: Oid

741+dateOid = Oid 1082

742+{-# INLINE dateOid #-}

743+

398744time :: TypeInfo

399745time = Basic {

400− typoid = Oid 1083,

746+ typoid = timeOid,

401747 typcategory = 'D',

402748 typdelim = ',',

403749 typname = "time"

404750 }

405751

752+timeOid :: Oid

753+timeOid = Oid 1083

754+{-# INLINE timeOid #-}

755+

406756timestamp :: TypeInfo

407757timestamp = Basic {

408− typoid = Oid 1114,

758+ typoid = timestampOid,

409759 typcategory = 'D',

410760 typdelim = ',',

411761 typname = "timestamp"

412762 }

413763

764+timestampOid :: Oid

765+timestampOid = Oid 1114

766+{-# INLINE timestampOid #-}

767+

414768timestamptz :: TypeInfo

415769timestamptz = Basic {

416− typoid = Oid 1184,

770+ typoid = timestamptzOid,

417771 typcategory = 'D',

418772 typdelim = ',',

419773 typname = "timestamptz"

420774 }

421775

776+timestamptzOid :: Oid

777+timestamptzOid = Oid 1184

778+{-# INLINE timestamptzOid #-}

779+

422780interval :: TypeInfo

423781interval = Basic {

424− typoid = Oid 1186,

782+ typoid = intervalOid,

425783 typcategory = 'T',

426784 typdelim = ',',

427785 typname = "interval"

428786 }

429787

788+intervalOid :: Oid

789+intervalOid = Oid 1186

790+{-# INLINE intervalOid #-}

791+

430792timetz :: TypeInfo

431793timetz = Basic {

432− typoid = Oid 1266,

794+ typoid = timetzOid,

433795 typcategory = 'D',

434796 typdelim = ',',

435797 typname = "timetz"

436798 }

437799

800+timetzOid :: Oid

801+timetzOid = Oid 1266

802+{-# INLINE timetzOid #-}

803+

438804bit :: TypeInfo

439805bit = Basic {

440− typoid = Oid 1560,

806+ typoid = bitOid,

441807 typcategory = 'V',

442808 typdelim = ',',

443809 typname = "bit"

444810 }

445811

812+bitOid :: Oid

813+bitOid = Oid 1560

814+{-# INLINE bitOid #-}

815+

446816varbit :: TypeInfo

447817varbit = Basic {

448− typoid = Oid 1562,

818+ typoid = varbitOid,

449819 typcategory = 'V',

450820 typdelim = ',',

451821 typname = "varbit"

452822 }

453823

824+varbitOid :: Oid

825+varbitOid = Oid 1562

826+{-# INLINE varbitOid #-}

827+

454828numeric :: TypeInfo

455829numeric = Basic {

456− typoid = Oid 1700,

830+ typoid = numericOid,

457831 typcategory = 'N',

458832 typdelim = ',',

459833 typname = "numeric"

460834 }

461835

836+numericOid :: Oid

837+numericOid = Oid 1700

838+{-# INLINE numericOid #-}

839+

462840refcursor :: TypeInfo

463841refcursor = Basic {

464− typoid = Oid 1790,

842+ typoid = refcursorOid,

465843 typcategory = 'U',

466844 typdelim = ',',

467845 typname = "refcursor"

468846 }

469847

848+refcursorOid :: Oid

849+refcursorOid = Oid 1790

850+{-# INLINE refcursorOid #-}

851+

470852record :: TypeInfo

471853record = Basic {

472− typoid = Oid 2249,

854+ typoid = recordOid,

473855 typcategory = 'P',

474856 typdelim = ',',

475857 typname = "record"

476858 }

477859

860+recordOid :: Oid

861+recordOid = Oid 2249

862+{-# INLINE recordOid #-}

863+

478864void :: TypeInfo

479865void = Basic {

480− typoid = Oid 2278,

866+ typoid = voidOid,

481867 typcategory = 'P',

482868 typdelim = ',',

483869 typname = "void"

484870 }

485871

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+

486949uuid :: TypeInfo

487950uuid = Basic {

488− typoid = Oid 2950,

951+ typoid = uuidOid,

489952 typcategory = 'U',

490953 typdelim = ',',

491954 typname = "uuid"

492955 }

493956

957+uuidOid :: Oid

958+uuidOid = Oid 2950

959+{-# INLINE uuidOid #-}

960+

494961json :: TypeInfo

495962json = Basic {

496− typoid = Oid 114,

963+ typoid = jsonOid,

497964 typcategory = 'U',

498965 typdelim = ',',

499966 typname = "json"

500967 }

501968

969+jsonOid :: Oid

970+jsonOid = Oid 114

971+{-# INLINE jsonOid #-}

972+

502973jsonb :: TypeInfo

503974jsonb = Basic {

504− typoid = Oid 3802,

975+ typoid = jsonbOid,

505976 typcategory = 'U',

506977 typdelim = ',',

507978 typname = "jsonb"

508979 }

980+

981+jsonbOid :: Oid

982+jsonbOid = Oid 3802

983+{-# INLINE jsonbOid #-}

984+

985+int2vector :: TypeInfo

986+int2vector = Array {

987+ typoid = int2vectorOid,

988+ typcategory = 'A',

989+ typdelim = ',',

990+ typname = "int2vector",

991+ typelem = int2

992+ }

993+

994+int2vectorOid :: Oid

995+int2vectorOid = Oid 22

996+{-# INLINE int2vectorOid #-}

997+

998+oidvector :: TypeInfo

999+oidvector = Array {

1000+ typoid = oidvectorOid,

1001+ typcategory = 'A',

1002+ typdelim = ',',

1003+ typname = "oidvector",

1004+ typelem = oid

1005+ }

1006+

1007+oidvectorOid :: Oid

1008+oidvectorOid = Oid 30

1009+{-# INLINE oidvectorOid #-}

1010+

1011+array_xml :: TypeInfo

1012+array_xml = Array {

1013+ typoid = array_xmlOid,

1014+ typcategory = 'A',

1015+ typdelim = ',',

1016+ typname = "_xml",

1017+ typelem = xml

1018+ }

1019+

1020+array_xmlOid :: Oid

1021+array_xmlOid = Oid 143

1022+{-# INLINE array_xmlOid #-}

1023+

1024+array_json :: TypeInfo

1025+array_json = Array {

1026+ typoid = array_jsonOid,

1027+ typcategory = 'A',

1028+ typdelim = ',',

1029+ typname = "_json",

1030+ typelem = json

1031+ }

1032+

1033+array_jsonOid :: Oid

1034+array_jsonOid = Oid 199

1035+{-# INLINE array_jsonOid #-}

1036+

1037+array_line :: TypeInfo

1038+array_line = Array {

1039+ typoid = array_lineOid,

1040+ typcategory = 'A',

1041+ typdelim = ',',

1042+ typname = "_line",

1043+ typelem = line

1044+ }

1045+

1046+array_lineOid :: Oid

1047+array_lineOid = Oid 629

1048+{-# INLINE array_lineOid #-}

1049+

1050+array_cidr :: TypeInfo

1051+array_cidr = Array {

1052+ typoid = array_cidrOid,

1053+ typcategory = 'A',

1054+ typdelim = ',',

1055+ typname = "_cidr",

1056+ typelem = cidr

1057+ }

1058+

1059+array_cidrOid :: Oid

1060+array_cidrOid = Oid 651

1061+{-# INLINE array_cidrOid #-}

1062+

1063+array_circle :: TypeInfo

1064+array_circle = Array {

1065+ typoid = array_circleOid,

1066+ typcategory = 'A',

1067+ typdelim = ',',

1068+ typname = "_circle",

1069+ typelem = circle

1070+ }

1071+

1072+array_circleOid :: Oid

1073+array_circleOid = Oid 719

1074+{-# INLINE array_circleOid #-}

1075+

1076+array_money :: TypeInfo

1077+array_money = Array {

1078+ typoid = array_moneyOid,

1079+ typcategory = 'A',

1080+ typdelim = ',',

1081+ typname = "_money",

1082+ typelem = money

1083+ }

1084+

1085+array_moneyOid :: Oid

1086+array_moneyOid = Oid 791

1087+{-# INLINE array_moneyOid #-}

1088+

1089+array_bool :: TypeInfo

1090+array_bool = Array {

1091+ typoid = array_boolOid,

1092+ typcategory = 'A',

1093+ typdelim = ',',

1094+ typname = "_bool",

1095+ typelem = bool

1096+ }

1097+

1098+array_boolOid :: Oid

1099+array_boolOid = Oid 1000

1100+{-# INLINE array_boolOid #-}

1101+

1102+array_bytea :: TypeInfo

1103+array_bytea = Array {

1104+ typoid = array_byteaOid,

1105+ typcategory = 'A',

1106+ typdelim = ',',

1107+ typname = "_bytea",

1108+ typelem = bytea

1109+ }

1110+

1111+array_byteaOid :: Oid

1112+array_byteaOid = Oid 1001

1113+{-# INLINE array_byteaOid #-}

1114+

1115+array_char :: TypeInfo

1116+array_char = Array {

1117+ typoid = array_charOid,

1118+ typcategory = 'A',

1119+ typdelim = ',',

1120+ typname = "_char",

1121+ typelem = char

1122+ }

1123+

1124+array_charOid :: Oid

1125+array_charOid = Oid 1002

1126+{-# INLINE array_charOid #-}

1127+

1128+array_name :: TypeInfo

1129+array_name = Array {

1130+ typoid = array_nameOid,

1131+ typcategory = 'A',

1132+ typdelim = ',',

1133+ typname = "_name",

1134+ typelem = name

1135+ }

1136+

1137+array_nameOid :: Oid

1138+array_nameOid = Oid 1003

1139+{-# INLINE array_nameOid #-}

1140+

1141+array_int2 :: TypeInfo

1142+array_int2 = Array {

1143+ typoid = array_int2Oid,

1144+ typcategory = 'A',

1145+ typdelim = ',',

1146+ typname = "_int2",

1147+ typelem = int2

1148+ }

1149+

1150+array_int2Oid :: Oid

1151+array_int2Oid = Oid 1005

1152+{-# INLINE array_int2Oid #-}

1153+

1154+array_int2vector :: TypeInfo

1155+array_int2vector = Array {

1156+ typoid = array_int2vectorOid,

1157+ typcategory = 'A',

1158+ typdelim = ',',

1159+ typname = "_int2vector",

1160+ typelem = int2vector

1161+ }

1162+

1163+array_int2vectorOid :: Oid

1164+array_int2vectorOid = Oid 1006

1165+{-# INLINE array_int2vectorOid #-}

1166+

1167+array_int4 :: TypeInfo

1168+array_int4 = Array {

1169+ typoid = array_int4Oid,

1170+ typcategory = 'A',

1171+ typdelim = ',',

1172+ typname = "_int4",

1173+ typelem = int4

1174+ }

1175+

1176+array_int4Oid :: Oid

1177+array_int4Oid = Oid 1007

1178+{-# INLINE array_int4Oid #-}

1179+

1180+array_regproc :: TypeInfo

1181+array_regproc = Array {

1182+ typoid = array_regprocOid,

1183+ typcategory = 'A',

1184+ typdelim = ',',

1185+ typname = "_regproc",

1186+ typelem = regproc

1187+ }

1188+

1189+array_regprocOid :: Oid

1190+array_regprocOid = Oid 1008

1191+{-# INLINE array_regprocOid #-}

1192+

1193+array_text :: TypeInfo

1194+array_text = Array {

1195+ typoid = array_textOid,

1196+ typcategory = 'A',

1197+ typdelim = ',',

1198+ typname = "_text",

1199+ typelem = text

1200+ }

1201+

1202+array_textOid :: Oid

1203+array_textOid = Oid 1009

1204+{-# INLINE array_textOid #-}

1205+

1206+array_tid :: TypeInfo

1207+array_tid = Array {

1208+ typoid = array_tidOid,

1209+ typcategory = 'A',

1210+ typdelim = ',',

1211+ typname = "_tid",

1212+ typelem = tid

1213+ }

1214+

1215+array_tidOid :: Oid

1216+array_tidOid = Oid 1010

1217+{-# INLINE array_tidOid #-}

1218+

1219+array_xid :: TypeInfo

1220+array_xid = Array {

1221+ typoid = array_xidOid,

1222+ typcategory = 'A',

1223+ typdelim = ',',

1224+ typname = "_xid",

1225+ typelem = xid

1226+ }

1227+

1228+array_xidOid :: Oid

1229+array_xidOid = Oid 1011

1230+{-# INLINE array_xidOid #-}

1231+

1232+array_cid :: TypeInfo

1233+array_cid = Array {

1234+ typoid = array_cidOid,

1235+ typcategory = 'A',

1236+ typdelim = ',',

1237+ typname = "_cid",

1238+ typelem = cid

1239+ }

1240+

1241+array_cidOid :: Oid

1242+array_cidOid = Oid 1012

1243+{-# INLINE array_cidOid #-}

1244+

1245+array_oidvector :: TypeInfo

1246+array_oidvector = Array {

1247+ typoid = array_oidvectorOid,

1248+ typcategory = 'A',

1249+ typdelim = ',',

1250+ typname = "_oidvector",

1251+ typelem = oidvector

1252+ }

1253+

1254+array_oidvectorOid :: Oid

1255+array_oidvectorOid = Oid 1013

1256+{-# INLINE array_oidvectorOid #-}

1257+

1258+array_bpchar :: TypeInfo

1259+array_bpchar = Array {

1260+ typoid = array_bpcharOid,

1261+ typcategory = 'A',

1262+ typdelim = ',',

1263+ typname = "_bpchar",

1264+ typelem = bpchar

1265+ }

1266+

1267+array_bpcharOid :: Oid

1268+array_bpcharOid = Oid 1014

1269+{-# INLINE array_bpcharOid #-}

1270+

1271+array_varchar :: TypeInfo

1272+array_varchar = Array {

1273+ typoid = array_varcharOid,

1274+ typcategory = 'A',

1275+ typdelim = ',',

1276+ typname = "_varchar",

1277+ typelem = varchar

1278+ }

1279+

1280+array_varcharOid :: Oid

1281+array_varcharOid = Oid 1015

1282+{-# INLINE array_varcharOid #-}

1283+

1284+array_int8 :: TypeInfo

1285+array_int8 = Array {

1286+ typoid = array_int8Oid,

1287+ typcategory = 'A',

1288+ typdelim = ',',

1289+ typname = "_int8",

1290+ typelem = int8

1291+ }

1292+

1293+array_int8Oid :: Oid

1294+array_int8Oid = Oid 1016

1295+{-# INLINE array_int8Oid #-}

1296+

1297+array_point :: TypeInfo

1298+array_point = Array {

1299+ typoid = array_pointOid,

1300+ typcategory = 'A',

1301+ typdelim = ',',

1302+ typname = "_point",

1303+ typelem = point

1304+ }

1305+

1306+array_pointOid :: Oid

1307+array_pointOid = Oid 1017

1308+{-# INLINE array_pointOid #-}

1309+

1310+array_lseg :: TypeInfo

1311+array_lseg = Array {

1312+ typoid = array_lsegOid,

1313+ typcategory = 'A',

1314+ typdelim = ',',

1315+ typname = "_lseg",

1316+ typelem = lseg

1317+ }

1318+

1319+array_lsegOid :: Oid

1320+array_lsegOid = Oid 1018

1321+{-# INLINE array_lsegOid #-}

1322+

1323+array_path :: TypeInfo

1324+array_path = Array {

1325+ typoid = array_pathOid,

1326+ typcategory = 'A',

1327+ typdelim = ',',

1328+ typname = "_path",

1329+ typelem = path

1330+ }

1331+

1332+array_pathOid :: Oid

1333+array_pathOid = Oid 1019

1334+{-# INLINE array_pathOid #-}

1335+

1336+array_box :: TypeInfo

1337+array_box = Array {

1338+ typoid = array_boxOid,

1339+ typcategory = 'A',

1340+ typdelim = ';',

1341+ typname = "_box",

1342+ typelem = box

1343+ }

1344+

1345+array_boxOid :: Oid

1346+array_boxOid = Oid 1020

1347+{-# INLINE array_boxOid #-}

1348+

1349+array_float4 :: TypeInfo

1350+array_float4 = Array {

1351+ typoid = array_float4Oid,

1352+ typcategory = 'A',

1353+ typdelim = ',',

1354+ typname = "_float4",

1355+ typelem = float4

1356+ }

1357+

1358+array_float4Oid :: Oid

1359+array_float4Oid = Oid 1021

1360+{-# INLINE array_float4Oid #-}

1361+

1362+array_float8 :: TypeInfo

1363+array_float8 = Array {

1364+ typoid = array_float8Oid,

1365+ typcategory = 'A',

1366+ typdelim = ',',

1367+ typname = "_float8",

1368+ typelem = float8

1369+ }

1370+

1371+array_float8Oid :: Oid

1372+array_float8Oid = Oid 1022

1373+{-# INLINE array_float8Oid #-}

1374+

1375+array_polygon :: TypeInfo

1376+array_polygon = Array {

1377+ typoid = array_polygonOid,

1378+ typcategory = 'A',

1379+ typdelim = ',',

1380+ typname = "_polygon",

1381+ typelem = polygon

1382+ }

1383+

1384+array_polygonOid :: Oid

1385+array_polygonOid = Oid 1027

1386+{-# INLINE array_polygonOid #-}

1387+

1388+array_oid :: TypeInfo

1389+array_oid = Array {

1390+ typoid = array_oidOid,

1391+ typcategory = 'A',

1392+ typdelim = ',',

1393+ typname = "_oid",

1394+ typelem = oid

1395+ }

1396+

1397+array_oidOid :: Oid

1398+array_oidOid = Oid 1028

1399+{-# INLINE array_oidOid #-}

1400+

1401+array_macaddr :: TypeInfo

1402+array_macaddr = Array {

1403+ typoid = array_macaddrOid,

1404+ typcategory = 'A',

1405+ typdelim = ',',

1406+ typname = "_macaddr",

1407+ typelem = macaddr

1408+ }

1409+

1410+array_macaddrOid :: Oid

1411+array_macaddrOid = Oid 1040

1412+{-# INLINE array_macaddrOid #-}

1413+

1414+array_inet :: TypeInfo

1415+array_inet = Array {

1416+ typoid = array_inetOid,

1417+ typcategory = 'A',

1418+ typdelim = ',',

1419+ typname = "_inet",

1420+ typelem = inet

1421+ }

1422+

1423+array_inetOid :: Oid

1424+array_inetOid = Oid 1041

1425+{-# INLINE array_inetOid #-}

1426+

1427+array_timestamp :: TypeInfo

1428+array_timestamp = Array {

1429+ typoid = array_timestampOid,

1430+ typcategory = 'A',

1431+ typdelim = ',',

1432+ typname = "_timestamp",

1433+ typelem = timestamp

1434+ }

1435+

1436+array_timestampOid :: Oid

1437+array_timestampOid = Oid 1115

1438+{-# INLINE array_timestampOid #-}

1439+

1440+array_date :: TypeInfo

1441+array_date = Array {

1442+ typoid = array_dateOid,

1443+ typcategory = 'A',

1444+ typdelim = ',',

1445+ typname = "_date",

1446+ typelem = date

1447+ }

1448+

1449+array_dateOid :: Oid

1450+array_dateOid = Oid 1182

1451+{-# INLINE array_dateOid #-}

1452+

1453+array_time :: TypeInfo

1454+array_time = Array {

1455+ typoid = array_timeOid,

1456+ typcategory = 'A',

1457+ typdelim = ',',

1458+ typname = "_time",

1459+ typelem = time

1460+ }

1461+

1462+array_timeOid :: Oid

1463+array_timeOid = Oid 1183

1464+{-# INLINE array_timeOid #-}

1465+

1466+array_timestamptz :: TypeInfo

1467+array_timestamptz = Array {

1468+ typoid = array_timestamptzOid,

1469+ typcategory = 'A',

1470+ typdelim = ',',

1471+ typname = "_timestamptz",

1472+ typelem = timestamptz

1473+ }

1474+

1475+array_timestamptzOid :: Oid

1476+array_timestamptzOid = Oid 1185

1477+{-# INLINE array_timestamptzOid #-}

1478+

1479+array_interval :: TypeInfo

1480+array_interval = Array {

1481+ typoid = array_intervalOid,

1482+ typcategory = 'A',

1483+ typdelim = ',',

1484+ typname = "_interval",

1485+ typelem = interval

1486+ }

1487+

1488+array_intervalOid :: Oid

1489+array_intervalOid = Oid 1187

1490+{-# INLINE array_intervalOid #-}

1491+

1492+array_numeric :: TypeInfo

1493+array_numeric = Array {

1494+ typoid = array_numericOid,

1495+ typcategory = 'A',

1496+ typdelim = ',',

1497+ typname = "_numeric",

1498+ typelem = numeric

1499+ }

1500+

1501+array_numericOid :: Oid

1502+array_numericOid = Oid 1231

1503+{-# INLINE array_numericOid #-}

1504+

1505+array_timetz :: TypeInfo

1506+array_timetz = Array {

1507+ typoid = array_timetzOid,

1508+ typcategory = 'A',

1509+ typdelim = ',',

1510+ typname = "_timetz",

1511+ typelem = timetz

1512+ }

1513+

1514+array_timetzOid :: Oid

1515+array_timetzOid = Oid 1270

1516+{-# INLINE array_timetzOid #-}

1517+

1518+array_bit :: TypeInfo

1519+array_bit = Array {

1520+ typoid = array_bitOid,

1521+ typcategory = 'A',

1522+ typdelim = ',',

1523+ typname = "_bit",

1524+ typelem = bit

1525+ }

1526+

1527+array_bitOid :: Oid

1528+array_bitOid = Oid 1561

1529+{-# INLINE array_bitOid #-}

1530+

1531+array_varbit :: TypeInfo

1532+array_varbit = Array {

1533+ typoid = array_varbitOid,

1534+ typcategory = 'A',

1535+ typdelim = ',',

1536+ typname = "_varbit",

1537+ typelem = varbit

1538+ }

1539+

1540+array_varbitOid :: Oid

1541+array_varbitOid = Oid 1563

1542+{-# INLINE array_varbitOid #-}

1543+

1544+array_refcursor :: TypeInfo

1545+array_refcursor = Array {

1546+ typoid = array_refcursorOid,

1547+ typcategory = 'A',

1548+ typdelim = ',',

1549+ typname = "_refcursor",

1550+ typelem = refcursor

1551+ }

1552+

1553+array_refcursorOid :: Oid

1554+array_refcursorOid = Oid 2201

1555+{-# INLINE array_refcursorOid #-}

1556+

1557+array_regprocedure :: TypeInfo

1558+array_regprocedure = Array {

1559+ typoid = array_regprocedureOid,

1560+ typcategory = 'A',

1561+ typdelim = ',',

1562+ typname = "_regprocedure",

1563+ typelem = regprocedure

1564+ }

1565+

1566+array_regprocedureOid :: Oid

1567+array_regprocedureOid = Oid 2207

1568+{-# INLINE array_regprocedureOid #-}

1569+

1570+array_regoper :: TypeInfo

1571+array_regoper = Array {

1572+ typoid = array_regoperOid,

1573+ typcategory = 'A',

1574+ typdelim = ',',

1575+ typname = "_regoper",

1576+ typelem = regoper

1577+ }

1578+

1579+array_regoperOid :: Oid

1580+array_regoperOid = Oid 2208

1581+{-# INLINE array_regoperOid #-}

1582+

1583+array_regoperator :: TypeInfo

1584+array_regoperator = Array {

1585+ typoid = array_regoperatorOid,

1586+ typcategory = 'A',

1587+ typdelim = ',',

1588+ typname = "_regoperator",

1589+ typelem = regoperator

1590+ }

1591+

1592+array_regoperatorOid :: Oid

1593+array_regoperatorOid = Oid 2209

1594+{-# INLINE array_regoperatorOid #-}

1595+

1596+array_regclass :: TypeInfo

1597+array_regclass = Array {

1598+ typoid = array_regclassOid,

1599+ typcategory = 'A',

1600+ typdelim = ',',

1601+ typname = "_regclass",

1602+ typelem = regclass

1603+ }

1604+

1605+array_regclassOid :: Oid

1606+array_regclassOid = Oid 2210

1607+{-# INLINE array_regclassOid #-}

1608+

1609+array_regtype :: TypeInfo

1610+array_regtype = Array {

1611+ typoid = array_regtypeOid,

1612+ typcategory = 'A',

1613+ typdelim = ',',

1614+ typname = "_regtype",

1615+ typelem = regtype

1616+ }

1617+

1618+array_regtypeOid :: Oid

1619+array_regtypeOid = Oid 2211

1620+{-# INLINE array_regtypeOid #-}

1621+

1622+array_uuid :: TypeInfo

1623+array_uuid = Array {

1624+ typoid = array_uuidOid,

1625+ typcategory = 'A',

1626+ typdelim = ',',

1627+ typname = "_uuid",

1628+ typelem = uuid

1629+ }

1630+

1631+array_uuidOid :: Oid

1632+array_uuidOid = Oid 2951

1633+{-# INLINE array_uuidOid #-}

1634+

1635+array_jsonb :: TypeInfo

1636+array_jsonb = Array {

1637+ typoid = array_jsonbOid,

1638+ typcategory = 'A',

1639+ typdelim = ',',

1640+ typname = "_jsonb",

1641+ typelem = jsonb

1642+ }

1643+

1644+array_jsonbOid :: Oid

1645+array_jsonbOid = Oid 3807

1646+{-# INLINE array_jsonbOid #-}

1647+

1648+int4range :: TypeInfo

1649+int4range = Range {

1650+ typoid = int4rangeOid,

1651+ typcategory = 'R',

1652+ typdelim = ',',

1653+ typname = "int4range",

1654+ rngsubtype = int4

1655+ }

1656+

1657+int4rangeOid :: Oid

1658+int4rangeOid = Oid 3904

1659+{-# INLINE int4rangeOid #-}

1660+

1661+_int4range :: TypeInfo

1662+_int4range = Array {

1663+ typoid = _int4rangeOid,

1664+ typcategory = 'A',

1665+ typdelim = ',',

1666+ typname = "_int4range",

1667+ typelem = int4range

1668+ }

1669+

1670+_int4rangeOid :: Oid

1671+_int4rangeOid = Oid 3905

1672+{-# INLINE _int4rangeOid #-}

1673+

1674+numrange :: TypeInfo

1675+numrange = Range {

1676+ typoid = numrangeOid,

1677+ typcategory = 'R',

1678+ typdelim = ',',

1679+ typname = "numrange",

1680+ rngsubtype = numeric

1681+ }

1682+

1683+numrangeOid :: Oid

1684+numrangeOid = Oid 3906

1685+{-# INLINE numrangeOid #-}

1686+

1687+_numrange :: TypeInfo

1688+_numrange = Array {

1689+ typoid = _numrangeOid,

1690+ typcategory = 'A',

1691+ typdelim = ',',

1692+ typname = "_numrange",

1693+ typelem = numrange

1694+ }

1695+

1696+_numrangeOid :: Oid

1697+_numrangeOid = Oid 3907

1698+{-# INLINE _numrangeOid #-}

1699+

1700+tsrange :: TypeInfo

1701+tsrange = Range {

1702+ typoid = tsrangeOid,

1703+ typcategory = 'R',

1704+ typdelim = ',',

1705+ typname = "tsrange",

1706+ rngsubtype = timestamp

1707+ }

1708+

1709+tsrangeOid :: Oid

1710+tsrangeOid = Oid 3908

1711+{-# INLINE tsrangeOid #-}

1712+

1713+_tsrange :: TypeInfo

1714+_tsrange = Array {

1715+ typoid = _tsrangeOid,

1716+ typcategory = 'A',

1717+ typdelim = ',',

1718+ typname = "_tsrange",

1719+ typelem = tsrange

1720+ }

1721+

1722+_tsrangeOid :: Oid

1723+_tsrangeOid = Oid 3909

1724+{-# INLINE _tsrangeOid #-}

1725+

1726+tstzrange :: TypeInfo

1727+tstzrange = Range {

1728+ typoid = tstzrangeOid,

1729+ typcategory = 'R',

1730+ typdelim = ',',

1731+ typname = "tstzrange",

1732+ rngsubtype = timestamptz

1733+ }

1734+

1735+tstzrangeOid :: Oid

1736+tstzrangeOid = Oid 3910

1737+{-# INLINE tstzrangeOid #-}

1738+

1739+_tstzrange :: TypeInfo

1740+_tstzrange = Array {

1741+ typoid = _tstzrangeOid,

1742+ typcategory = 'A',

1743+ typdelim = ',',

1744+ typname = "_tstzrange",

1745+ typelem = tstzrange

1746+ }

1747+

1748+_tstzrangeOid :: Oid

1749+_tstzrangeOid = Oid 3911

1750+{-# INLINE _tstzrangeOid #-}

1751+

1752+daterange :: TypeInfo

1753+daterange = Range {

1754+ typoid = daterangeOid,

1755+ typcategory = 'R',

1756+ typdelim = ',',

1757+ typname = "daterange",

1758+ rngsubtype = date

1759+ }

1760+

1761+daterangeOid :: Oid

1762+daterangeOid = Oid 3912

1763+{-# INLINE daterangeOid #-}

1764+

1765+_daterange :: TypeInfo

1766+_daterange = Array {

1767+ typoid = _daterangeOid,

1768+ typcategory = 'A',

1769+ typdelim = ',',

1770+ typname = "_daterange",

1771+ typelem = daterange

1772+ }

1773+

1774+_daterangeOid :: Oid

1775+_daterangeOid = Oid 3913

1776+{-# INLINE _daterangeOid #-}

1777+

1778+int8range :: TypeInfo

1779+int8range = Range {

1780+ typoid = int8rangeOid,

1781+ typcategory = 'R',

1782+ typdelim = ',',

1783+ typname = "int8range",

1784+ rngsubtype = int8

1785+ }

1786+

1787+int8rangeOid :: Oid

1788+int8rangeOid = Oid 3926

1789+{-# INLINE int8rangeOid #-}

1790+

1791+_int8range :: TypeInfo

1792+_int8range = Array {

1793+ typoid = _int8rangeOid,

1794+ typcategory = 'A',

1795+ typdelim = ',',

1796+ typname = "_int8range",

1797+ typelem = int8range

1798+ }

1799+

1800+_int8rangeOid :: Oid

1801+_int8rangeOid = Oid 3927

1802+{-# INLINE _int8rangeOid #-}

src/Database/PostgreSQL/Simple/Types.hs+57−33

@@ -1,4 +1,4 @@

1−{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, GeneralizedNewtypeDeriving #-}

1+{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, GeneralizedNewtypeDeriving #-}

33------------------------------------------------------------------------------

44-- |

@@ -30,27 +30,26 @@ module Database.PostgreSQL.Simple.Types

3030 , Values(..)

3131 ) where

3232

33−import Blaze.ByteString.Builder (toByteString)

3433import Control.Arrow (first)

3534import Data.ByteString (ByteString)

3635import Data.Hashable (Hashable(hashWithSalt))

36+import Data.Foldable (toList)

3737import Data.Monoid (Monoid(..))

38+import Data.Semigroup

3839import Data.String (IsString(..))

3940import Data.Typeable (Typeable)

40−import qualified Blaze.ByteString.Builder.Char.Utf8 as Utf8

41+import Data.ByteString.Builder ( stringUtf8 )

4142import qualified Data.ByteString as B

4243import Data.Text (Text)

4344import qualified Data.Text as T

45+import Data.Tuple.Only (Only(..))

4446import Database.PostgreSQL.LibPQ (Oid(..))

47+import Database.PostgreSQL.Simple.Compat (toByteString)

4548

4649-- | A placeholder for the SQL @NULL@ value.

4750data Null = Null

4851 deriving (Read, Show, Typeable)

4952

50−instance Eq Null where

51− _ == _ = False

52− _ /= _ = False

53−

5453-- | A placeholder for the PostgreSQL @DEFAULT@ value.

5554data Default = Default

5655 deriving (Read, Show, Typeable)

@@ -85,30 +84,15 @@ instance Read Query where

8584 readsPrec i = fmap (first Query) . readsPrec i

8685

8786instance IsString Query where

88− fromString = Query . toByteString . Utf8.fromString

87+ fromString = Query . toByteString . stringUtf8

88+

89+instance Semigroup Query where

90+ Query a <> Query b = Query (B.append a b)

91+ {-# INLINE (<>) #-}

92+ sconcat xs = Query (B.concat $ map fromQuery $ toList xs)

8993

9094instance Monoid Query where

9195 mempty = Query B.empty

92− mappend (Query a) (Query b) = Query (B.append a b)

93− {-# INLINE mappend #-}

94− mconcat xs = Query (B.concat (map fromQuery xs))

95−

96−-- | A single-value \"collection\".

97−--

98−-- This is useful if you need to supply a single parameter to a SQL

99−-- query, or extract a single column from a SQL result.

100−--

101−-- Parameter example:

102−--

103−-- @query c \"select x from scores where x > ?\" ('Only' (42::Int))@

104−--

105−-- Result example:

106−--

107−-- @xs <- query_ c \"select id from users\"

108−--forM_ xs $ \\('Only' id) -> {- ... -}@

109−newtype Only a = Only {

110− fromOnly :: a

111− } deriving (Eq, Ord, Read, Show, Typeable, Functor)

11296

11397-- | Wrap a list of values for use in an @IN@ clause. Replaces a

11498-- single \"@?@\" character with a parenthesized list of rendered

@@ -117,6 +101,44 @@ newtype Only a = Only {

117101-- Example:

118102--

119103-- > query c "select * from whatever where id in ?" (Only (In [3,4,5]))

104+--

105+-- Note that @In []@ expands to @(null)@, which works as expected in

106+-- the query above, but evaluates to the logical null value on every

107+-- row instead of @TRUE@. This means that changing the query above

108+-- to @... id NOT in ?@ and supplying the empty list as the parameter

109+-- returns zero rows, instead of all of them as one would expect.

110+--

111+-- Since postgresql doesn't seem to provide a syntax for actually specifying

112+-- an empty list, which could solve this completely, there are two

113+-- workarounds particularly worth mentioning, namely:

114+--

115+-- 1. Use postgresql-simple's 'Values' type instead, which can handle the

116+-- empty case correctly. Note however that while specifying the

117+-- postgresql type @"int4"@ is mandatory in the empty case, specifying

118+-- the haskell type @Values (Only Int)@ would not normally be needed in

119+-- realistic use cases.

120+--

121+-- > query c "select * from whatever where id not in ?"

122+-- > (Only (Values ["int4"] [] :: Values (Only Int)))

123+--

124+--

125+-- 2. Use sql's @COALESCE@ operator to turn a logical @null@ into the correct

126+-- boolean. Note however that the correct boolean depends on the use

127+-- case:

128+--

129+-- > query c "select * from whatever where coalesce(id NOT in ?, TRUE)"

130+-- > (Only (In [] :: In [Int]))

131+--

132+-- > query c "select * from whatever where coalesce(id IN ?, FALSE)"

133+-- > (Only (In [] :: In [Int]))

134+--

135+-- Note that at as of PostgreSQL 9.4, the query planner cannot see inside

136+-- the @COALESCE@ operator, so if you have an index on @id@ then you

137+-- probably don't want to write the last example with @COALESCE@, which

138+-- would result in a table scan. There are further caveats if @id@ can

139+-- be null or you want null treated sensibly as a component of @IN@ or

140+-- @NOT IN@.

141+

120142newtype In a = In a

121143 deriving (Eq, Ord, Read, Show, Typeable, Functor)

122144

@@ -179,8 +201,9 @@ infixr 3 :.

179201newtype Savepoint = Savepoint Query

180202 deriving (Eq, Ord, Show, Read, Typeable)

181203

182−-- | Represents a @VALUES@ table literal, usable as an alternative

183−-- to @executeMany@ and @returning@. The main advantage is that

204+-- | Represents a @VALUES@ table literal, usable as an alternative to

205+-- 'Database.PostgreSQL.Simple.executeMany' and

206+-- 'Database.PostgreSQL.Simple.returning'. The main advantage is that

184207-- you can parametrize more than just a single @VALUES@ expression.

185208-- For example, here's a query to insert a thing into one table

186209-- and some attributes of that thing into another, returning the

@@ -193,7 +216,7 @@ newtype Savepoint = Savepoint Query

193216-- > ), new_attributes AS (

194217-- > INSERT INTO thing_attributes

195218-- > SELECT new_thing.id, attrs.*

196−-- > FROM new_thing JOIN ? attrs

219+-- > FROM new_thing JOIN ? attrs ON TRUE

197220-- > ) SELECT * FROM new_thing

198221-- > |] ("foo", Values [ "int4", "text" ]

199222-- > [ ( 1 , "hello" )

@@ -219,7 +242,8 @@ newtype Savepoint = Savepoint Query

219242-- is turned into a properly quoted identifier, the type name is case

220243-- sensitive and must be as it appears in the @pg_type@ table. Thus,

221244-- you must write @timestamptz@ instead of @timestamp with time zone@,

222−-- @int4@ instead of @integer@, @_int8@ instead of @bigint[]@, etcetera.

245+-- @int4@ instead of @integer@ or @serial@, @_int8@ instead of @bigint[]@,

246+-- etcetera.

223247--

224248-- You may omit the type names, however, if you do so the list

225249-- of values must be non-empty, and postgresql must be able to infer

@@ -228,7 +252,7 @@ newtype Savepoint = Savepoint Query

228252-- without issuing the query. In the second case, the postgres server

229253-- will return an error which will be turned into a @SqlError@ exception.

230254--

231−-- See <http://www.postgresql.org/docs/9.3/static/sql-values.html> for

255+-- See <https://www.postgresql.org/docs/9.5/static/sql-values.html> for

232256-- more information.

233257data Values a = Values [QualifiedIdentifier] [a]

234258 deriving (Eq, Ord, Show, Read, Typeable)

src/Database/PostgreSQL/Simple/Vector.hsnew file+45

@@ -0,0 +1,45 @@

1+-- | 'query' variants returning 'V.Vector'.

2+module Database.PostgreSQL.Simple.Vector where

4+import Database.PostgreSQL.Simple (Connection, formatQuery, formatMany)

5+import Database.PostgreSQL.Simple.FromRow (FromRow(..))

6+import Database.PostgreSQL.Simple.ToRow (ToRow(..))

7+import Database.PostgreSQL.Simple.Internal (RowParser, exec)

8+import Database.PostgreSQL.Simple.Internal.PQResultUtils

9+import Database.PostgreSQL.Simple.Types ( Query (..) )

10+

11+import qualified Data.Vector as V

12+

13+-- | Perform a @SELECT@ or other SQL query that is expected to return

14+-- results. All results are retrieved and converted before this

15+-- function returns.

16+query :: (ToRow q, FromRow r) => Connection -> Query -> q -> IO (V.Vector r)

17+query = queryWith fromRow

18+

19+-- | A version of 'query' that does not perform query substitution.

20+query_ :: (FromRow r) => Connection -> Query -> IO (V.Vector r)

21+query_ = queryWith_ fromRow

22+

23+-- | A version of 'query' taking parser as argument

24+queryWith :: ToRow q => RowParser r -> Connection -> Query -> q -> IO (V.Vector r)

25+queryWith parser conn template qs = do

26+ result <- exec conn =<< formatQuery conn template qs

27+ finishQueryWithV parser conn template result

28+

29+-- | A version of 'query_' taking parser as argument

30+queryWith_ :: RowParser r -> Connection -> Query -> IO (V.Vector r)

31+queryWith_ parser conn q@(Query que) = do

32+ result <- exec conn que

33+ finishQueryWithV parser conn q result

34+

35+-- | Execute @INSERT ... RETURNING@, @UPDATE ... RETURNING@, or other SQL

36+-- query that accepts multi-row input and is expected to return results.

37+returning :: (ToRow q, FromRow r) => Connection -> Query -> [q] -> IO (V.Vector r)

38+returning = returningWith fromRow

39+

40+-- | A version of 'returning' taking parser as argument

41+returningWith :: (ToRow q) => RowParser r -> Connection -> Query -> [q] -> IO (V.Vector r)

42+returningWith _ _ _ [] = return V.empty

43+returningWith parser conn q qs = do

44+ result <- exec conn =<< formatMany conn q qs

45+ finishQueryWithV parser conn q result

src/Database/PostgreSQL/Simple/Vector/Unboxed.hsnew file+44

@@ -0,0 +1,44 @@

1+module Database.PostgreSQL.Simple.Vector.Unboxed where

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 (..) )

10+import qualified Data.Vector.Unboxed as VU

11+

12+-- | Perform a @SELECT@ or other SQL query that is expected to return

13+-- results. All results are retrieved and converted before this

14+-- function returns.

15+query :: (ToRow q, FromRow r, VU.Unbox r) => Connection -> Query -> q -> IO (VU.Vector r)

16+query = queryWith fromRow

17+

18+-- | A version of 'query' that does not perform query substitution.

19+query_ :: (FromRow r, VU.Unbox r) => Connection -> Query -> IO (VU.Vector r)

20+query_ = queryWith_ fromRow

21+

22+-- | A version of 'query' taking parser as argument

23+queryWith :: (ToRow q, VU.Unbox r) => RowParser r -> Connection -> Query -> q -> IO (VU.Vector r)

24+queryWith parser conn template qs = do

25+ result <- exec conn =<< formatQuery conn template qs

26+ finishQueryWithVU parser conn template result

27+

28+-- | A version of 'query_' taking parser as argument

29+queryWith_ :: VU.Unbox r => RowParser r -> Connection -> Query -> IO (VU.Vector r)

30+queryWith_ parser conn q@(Query que) = do

31+ result <- exec conn que

32+ finishQueryWithVU parser conn q result

33+

34+-- | Execute @INSERT ... RETURNING@, @UPDATE ... RETURNING@, or other SQL

35+-- query that accepts multi-row input and is expected to return results.

36+returning :: (ToRow q, FromRow r, VU.Unbox r) => Connection -> Query -> [q] -> IO (VU.Vector r)

37+returning = returningWith fromRow

38+

39+-- | A version of 'returning' taking parser as argument

40+returningWith :: (ToRow q, VU.Unbox r) => RowParser r -> Connection -> Query -> [q] -> IO (VU.Vector r)

41+returningWith _ _ _ [] = return VU.empty

42+returningWith parser conn q qs = do

43+ result <- exec conn =<< formatMany conn q qs

44+ finishQueryWithVU parser conn q result

test/Common.hs+2−2

@@ -1,6 +1,6 @@

11module Common (

22 module Database.PostgreSQL.Simple,

3− module Test.HUnit,

3+ module Test.Tasty.HUnit,

44 TestEnv(..),

55 md5,

66) where

@@ -8,7 +8,7 @@ module Common (

88import Data.ByteString (ByteString)

99import Data.Text (Text)

1010import Database.PostgreSQL.Simple

11−import Test.HUnit

11+import Test.Tasty.HUnit

1212

1313import qualified Crypto.Hash.MD5 as MD5

1414import qualified Data.ByteString.Base16 as Base16

test/Exception.hsnew file+70

@@ -0,0 +1,70 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE OverloadedStrings #-}

3+{-# LANGUAGE ScopedTypeVariables #-}

5+module Exception (testExceptions) where

7+import Database.PostgreSQL.Simple

8+import Test.Tasty.HUnit (Assertion, assertBool)

9+import Common (TestEnv)

10+import Control.Exception (Exception (..), SomeException)

11+import Data.Maybe (isJust)

12+import Data.Either (isLeft)

13+import Control.Exception (throwIO, try)

14+

15+testExceptions :: TestEnv -> Assertion

16+testExceptions _ = do

17+ let sqlError = SqlError

18+ { sqlState = ""

19+ , sqlExecStatus = FatalError

20+ , sqlErrorMsg = ""

21+ , sqlErrorDetail = ""

22+ , sqlErrorHint = ""

23+ }

24+ let sqlEx :: SomeException = toException sqlError

25+ assertBool "SqlError is SomePostgreSqlException" $ isJust (fromException sqlEx :: Maybe SomePostgreSqlException)

26+ assertBool "SqlError is SqlError" $ isJust (fromException sqlEx :: Maybe SqlError)

27+ eSqlError :: Either SqlError () <- try $ throwIO sqlEx

28+ assertBool "Can catch SqlError" $ isLeft eSqlError

29+ eSqlPostgreSqlEx :: Either SomePostgreSqlException () <- try $ throwIO sqlEx

30+ assertBool "Can catch SomePostgreSqlException from SqlError" $ isLeft eSqlPostgreSqlEx

31+

32+ let formatError = FormatError

33+ { fmtMessage = ""

34+ , fmtQuery = ""

35+ , fmtParams = []

36+ }

37+ let formatEx :: SomeException = toException formatError

38+ assertBool "FormatError is SomePostgreSqlException" $ isJust (fromException formatEx :: Maybe SomePostgreSqlException)

39+ assertBool "FormatError is FormatError" $ isJust (fromException formatEx :: Maybe FormatError)

40+ eFormatError :: Either FormatError () <- try $ throwIO formatEx

41+ assertBool "Can catch FormatError" $ isLeft eFormatError

42+ eFormatPostreSqlEx :: Either SomePostgreSqlException () <- try $ throwIO formatEx

43+ assertBool "Can catch SomePostgreSqlException from FormatError" $ isLeft eFormatPostreSqlEx

44+

45+ let queryError = QueryError

46+ { qeMessage = ""

47+ , qeQuery = ""

48+ }

49+ let queryEx :: SomeException = toException queryError

50+ assertBool "QueryError is SomePostgreSqlException" $ isJust (fromException queryEx :: Maybe SomePostgreSqlException)

51+ assertBool "QueryError is QueryError" $ isJust (fromException queryEx :: Maybe QueryError)

52+ eQueryError :: Either QueryError () <- try $ throwIO queryEx

53+ assertBool "Can catch QueryError" $ isLeft eQueryError

54+ eQueryPostgreSqlEx :: Either SomePostgreSqlException () <- try $ throwIO queryEx

55+ assertBool "Can catch SomePostgreSqlException from QueryError" $ isLeft eQueryPostgreSqlEx

56+

57+ let resultError = Incompatible

58+ { errSQLType = ""

59+ , errSQLTableOid = Nothing

60+ , errSQLField = ""

61+ , errHaskellType = ""

62+ , errMessage = ""

63+ }

64+ let resultEx :: SomeException = toException resultError

65+ assertBool "ResultError is SomePostgreSqlException" $ isJust (fromException resultEx :: Maybe SomePostgreSqlException)

66+ assertBool "ResultError is ResultError" $ isJust (fromException resultEx :: Maybe ResultError)

67+ eResultEx :: Either ResultError () <- try $ throwIO resultEx

68+ assertBool "Can catch ResultError" $ isLeft eResultEx

69+ eResultPostgreSqlEx :: Either SomePostgreSqlException () <- try $ throwIO resultEx

70+ assertBool "Can catch SomePostgreSqlException from ResultError" $ isLeft eResultPostgreSqlEx

test/Inspection.hsnew file+79

@@ -0,0 +1,79 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE TemplateHaskell #-}

3+{-# OPTIONS_GHC -dsuppress-idinfo -dsuppress-coercions -dsuppress-type-applications -dsuppress-module-prefixes -dsuppress-type-signatures #-}

4+-- {-# OPTIONS_GHC -dsuppress-uniques #-}

5+{-# OPTIONS_GHC -fplugin=Test.Inspection.Plugin #-}

6+module Main where

8+import Test.Inspection

9+import Test.Tasty

10+import Test.Tasty.HUnit

11+

12+import qualified Database.PostgreSQL.LibPQ as PQ

13+import Database.PostgreSQL.Simple.FromField

14+import Database.PostgreSQL.Simple.TypeInfo as TI

15+import Database.PostgreSQL.Simple.TypeInfo.Macro

16+import qualified Database.PostgreSQL.Simple.TypeInfo.Static as TI

17+

18+-------------------------------------------------------------------------------

19+-- Inspection tests

20+-------------------------------------------------------------------------------

21+

22+-- # doesn't work :(

23+#define TH_MKCOMPATS3(a,b,c) $(mkCompats [TI.a,TI.b,TI.c])

24+#define IN_MKCOMPATS3(a,b,c) (eq TI.a \/ eq TI.b \/ eq TI.c)

25+

26+#define TH_INLINETYPOID(n) eq $(inlineTypoid TI.n)

27+#define IN_INLINETYPOID(n) eq TI.n

28+

29+-- eta-expansion is required

30+lhs01, rhs01 :: PQ.Oid -> Bool

31+lhs01 = TH_MKCOMPATS3(name,text,char)

32+rhs01 = IN_MKCOMPATS3(nameOid,textOid,charOid)

33+

34+lhs02, rhs02 :: PQ.Oid -> Bool

35+lhs02 = TH_INLINETYPOID(name)

36+rhs02 = IN_INLINETYPOID(nameOid)

37+

38+eq :: PQ.Oid -> PQ.Oid -> Bool

39+eq = (==)

40+{-# INLINE eq #-}

41+

42+infixr 2 \/

43+(\/) :: (PQ.Oid -> Bool)

44+ -> (PQ.Oid -> Bool)

45+ -> (PQ.Oid -> Bool)

46+f \/ g = \x -> f x || g x

47+{-# INLINE (\/) #-}

48+

49+inspectionTests :: TestTree

50+inspectionTests = testGroup "inspection"

51+ [ testCase "mkCompats" $

52+ assertSuccess $(inspectTest $ 'lhs01 === 'rhs01)

53+

54+ -- byteaOid isn't inlined?

55+ , testCase "inlineTypoid" $

56+#if __GLASGOW_HASKELL__ >= 808

57+ assertSuccess

58+#else

59+ assertFailure'

60+#endif

61+ $(inspectTest $ 'lhs02 ==- 'rhs02)

62+ ]

63+

64+assertSuccess :: Result -> IO ()

65+assertSuccess (Success _) = return ()

66+assertSuccess (Failure err) = assertFailure err

67+

68+assertFailure' :: Result -> IO ()

69+assertFailure' (Success err) = assertFailure err

70+assertFailure' (Failure _) = return ()

71+

72+-------------------------------------------------------------------------------

73+-- Main

74+-------------------------------------------------------------------------------

75+

76+main :: IO ()

77+main = defaultMain $ testGroup "tests"

78+ [ inspectionTests

79+ ]

test/Interval.hsnew file+176

@@ -0,0 +1,176 @@

1+{-# LANGUAGE QuasiQuotes #-}

3+{-

5+Testing strategies:

7+fromString . toString == id ** Todo?

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+346−59

@@ -1,53 +1,95 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE DeriveGeneric #-}

13{-# LANGUAGE DeriveDataTypeable #-}

24{-# LANGUAGE DoAndIfThenElse #-}

35{-# LANGUAGE ScopedTypeVariables #-}

6+#if __GLASGOW_HASKELL__ >= 806

7+{-# LANGUAGE DerivingStrategies #-}

8+{-# LANGUAGE DerivingVia #-}

9+{-# LANGUAGE DeriveAnyClass #-}

10+#endif

11+module Main (main) where

12+

413import Common

14+import Database.PostgreSQL.Simple.Copy

15+import Database.PostgreSQL.Simple.ToField (ToField)

516import Database.PostgreSQL.Simple.FromField (FromField)

6−import Database.PostgreSQL.Simple.Types(Query(..),Values(..))

717import Database.PostgreSQL.Simple.HStore

8−import Database.PostgreSQL.Simple.Copy

18+import Database.PostgreSQL.Simple.Newtypes

19+import Database.PostgreSQL.Simple.Internal (breakOnSingleQuestionMark)

20+import Database.PostgreSQL.Simple.Types(Query(..),Values(..), PGArray(..))

921import qualified Database.PostgreSQL.Simple.Transaction as ST

22+

1023import Control.Applicative

1124import Control.Exception as E

1225import Control.Monad

13−import Data.ByteString (ByteString)

26+import Data.Char

27+import Data.Foldable (toList)

28+import Data.List (concat, sort)

1429import Data.IORef

30+import Data.Monoid ((<>))

31+import Data.String (fromString)

1532import Data.Typeable

33+import GHC.Generics (Generic)

34+

35+import Data.Aeson

36+import Data.ByteString (ByteString)

1637import qualified Data.ByteString as B

38+import qualified Data.ByteString.Char8 as BS8

39+import qualified Data.ByteString.Lazy.Char8 as BL

40+import Data.CaseInsensitive (CI)

41+import qualified Data.CaseInsensitive as CI

1742import Data.Map (Map)

18−import Data.List (sort)

1943import qualified Data.Map as Map

2044import Data.Text(Text)

2145import qualified Data.Text.Encoding as T

22−import System.Exit (exitFailure)

23−import System.IO

2446import qualified Data.Vector as V

25−import Data.Aeson

47+import System.FilePath

48+import System.Timeout(timeout)

49+import Data.Time.Compat (getCurrentTime, diffUTCTime)

50+import System.Environment (getEnvironment)

2651

52+import Test.Tasty

53+import Test.Tasty.Golden

2754import Notify

2855import Serializable

2956import Time

30−

31−tests :: [TestEnv -> Test]

32−tests =

33− [ TestLabel "Bytea" . testBytea

34− , TestLabel "ExecuteMany" . testExecuteMany

35− , TestLabel "Fold" . testFold

36− , TestLabel "Notify" . testNotify

37− , TestLabel "Serializable" . testSerializable

38− , TestLabel "Time" . testTime

39− , TestLabel "Array" . testArray

40− , TestLabel "HStore" . testHStore

41− , TestLabel "JSON" . testJSON

42− , TestLabel "Savepoint" . testSavepoint

43− , TestLabel "Unicode" . testUnicode

44− , TestLabel "Values" . testValues

45− , TestLabel "Copy" . testCopy

46− , TestLabel "Double" . testDouble

57+import Interval

58+import Exception (testExceptions)

59+

60+tests :: TestEnv -> TestTree

61+tests env = testGroup "tests"

62+ $ map ($ env)

63+ [ testBytea

64+ , testCase "ExecuteMany" . testExecuteMany

65+ , testCase "Fold" . testFold

66+ , testCase "Notify" . testNotify

67+ , testCase "Serializable" . testSerializable

68+ , testCase "Time" . testTime

69+ , testCase "Interval" . testInterval

70+ , testCase "Array" . testArray

71+ , testCase "Array of nullables" . testNullableArray

72+ , testCase "HStore" . testHStore

73+ , testCase "citext" . testCIText

74+ , testCase "JSON" . testJSON

75+ , testCase "Aeson newtype" . testAeson

76+ , testCase "DerivingVia" . testDerivingVia

77+ , testCase "Question mark escape" . testQM

78+ , testCase "Savepoint" . testSavepoint

79+ , testCase "Unicode" . testUnicode

80+ , testCase "Values" . testValues

81+ , testCase "Copy" . testCopy

82+ , testCopyFailures

83+ , testCase "Double" . testDouble

84+ , testCase "1-ary generic" . testGeneric1

85+ , testCase "2-ary generic" . testGeneric2

86+ , testCase "3-ary generic" . testGeneric3

87+ , testCase "Timeout" . testTimeout

88+ , testCase "Exceptions" . testExceptions

4789 ]

4890

49−testBytea :: TestEnv -> Test

50−testBytea TestEnv{..} = TestList

91+testBytea :: TestEnv -> TestTree

92+testBytea TestEnv{..} = testGroup "Bytea"

5193 [ testStr "empty" []

5294 , testStr "\"hello\"" $ map (fromIntegral . fromEnum) ("hello" :: String)

5395 , testStr "ascending" [0..255]

@@ -56,7 +98,7 @@ testBytea TestEnv{..} = TestList

5698 , testStr "descending, doubled up" $ doubleUp [255,254..0]

5799 ]

58100 where

59− testStr label bytes = TestLabel label $ TestCase $ do

101+ testStr label bytes = testCase label $ do

60102 let bs = B.pack bytes

61103

62104 [Only h] <- query conn "SELECT md5(?::bytea)" [Binary bs]

@@ -67,8 +109,8 @@ testBytea TestEnv{..} = TestList

67109

68110 doubleUp = concatMap (\x -> [x, x])

69111

70−testExecuteMany :: TestEnv -> Test

71−testExecuteMany TestEnv{..} = TestCase $ do

112+testExecuteMany :: TestEnv -> Assertion

113+testExecuteMany TestEnv{..} = do

72114 execute_ conn "CREATE TEMPORARY TABLE tmp_executeMany (i INT, t TEXT, b BYTEA)"

73115

74116 let rows :: [(Int, String, Binary ByteString)]

@@ -85,8 +127,8 @@ testExecuteMany TestEnv{..} = TestCase $ do

85127

86128 return ()

87129

88−testFold :: TestEnv -> Test

89−testFold TestEnv{..} = TestCase $ do

130+testFold :: TestEnv -> Assertion

131+testFold TestEnv{..} = do

90132 xs <- fold_ conn "SELECT generate_series(1,10000)"

91133 [] $ \xs (Only x) -> return (x:xs)

92134 reverse xs @?= ([1..10000] :: [Int])

@@ -97,7 +139,7 @@ testFold TestEnv{..} = TestCase $ do

97139 xs <- readIORef ref

98140 writeIORef ref $! (a,b):xs

99141 xs <- readIORef ref

100− reverse xs @?= [(a,b) | a <- [1..100], b <- [1..50]]

142+ reverse xs @?= [(a,b) | b <- [1..50], a <- [1..100]]

101143

102144 -- Make sure fold propagates our exception.

103145 ref <- newIORef []

@@ -155,8 +197,8 @@ queryFailure conn q resultType = do

155197 ++ show (typeOf resultType)

156198 ++ " -> " ++ show val)

157199

158−testArray :: TestEnv -> Test

159−testArray TestEnv{..} = TestCase $ do

200+testArray :: TestEnv -> Assertion

201+testArray TestEnv{..} = do

160202 xs <- query_ conn "SELECT '{1,2,3,4}'::_int4"

161203 xs @?= [Only (V.fromList [1,2,3,4 :: Int])]

162204 xs <- query_ conn "SELECT '{{1,2},{3,4}}'::_int4"

@@ -165,8 +207,17 @@ testArray TestEnv{..} = TestCase $ do

165207 queryFailure conn "SELECT '{1,2,3,4}'::_int4" (undefined :: V.Vector Bool)

166208 queryFailure conn "SELECT '{{1,2},{3,4}}'::_int4" (undefined :: V.Vector Int)

167209

168−testHStore :: TestEnv -> Test

169−testHStore TestEnv{..} = TestCase $ do

210+testNullableArray :: TestEnv -> Assertion

211+testNullableArray TestEnv{..} = do

212+ xs <- query_ conn "SELECT '{sometext, \"NULL\"}'::_text"

213+ xs @?= [Only (V.fromList ["sometext", "NULL" :: Text])]

214+ xs <- query_ conn "SELECT '{sometext, NULL}'::_text"

215+ xs @?= [Only (V.fromList [Just "sometext", Nothing :: Maybe Text])]

216+ queryFailure conn "SELECT '{sometext, NULL}'::_text" (undefined :: V.Vector Text)

217+

218+testHStore :: TestEnv -> Assertion

219+testHStore TestEnv{..} = do

220+ execute_ conn "CREATE EXTENSION IF NOT EXISTS hstore"

170221 roundTrip []

171222 roundTrip [("foo","bar"),("bar","baz"),("baz","hello")]

172223 roundTrip [("fo\"o","bar"),("b\\ar","baz"),("baz","\"value\\with\"escapes")]

@@ -177,12 +228,27 @@ testHStore TestEnv{..} = TestCase $ do

177228 m' <- query conn "SELECT ?::hstore" m

178229 [m] @?= m'

179230

180−testJSON :: TestEnv -> Test

181−testJSON TestEnv{..} = TestCase $ do

231+testCIText :: TestEnv -> Assertion

232+testCIText TestEnv{..} = do

233+ execute_ conn "CREATE EXTENSION IF NOT EXISTS citext"

234+ roundTrip (CI.mk "")

235+ roundTrip (CI.mk "UPPERCASE")

236+ roundTrip (CI.mk "lowercase")

237+ where

238+ roundTrip :: (CI Text) -> Assertion

239+ roundTrip cit = do

240+ let toPostgres = Only cit

241+ fromPostgres <- query conn "SELECT ?::citext" toPostgres

242+ [toPostgres] @?= fromPostgres

243+

244+testJSON :: TestEnv -> Assertion

245+testJSON TestEnv{..} = do

182246 roundTrip (Map.fromList [] :: Map Text Text)

183247 roundTrip (Map.fromList [("foo","bar"),("bar","baz"),("baz","hello")] :: Map Text Text)

184248 roundTrip (Map.fromList [("fo\"o","bar"),("b\\ar","baz"),("baz","\"value\\with\"escapes")] :: Map Text Text)

185249 roundTrip (V.fromList [1,2,3,4,5::Int])

250+ roundTrip ("foo" :: Text)

251+ roundTrip (42 :: Int)

186252 where

187253 roundTrip :: ToJSON a => a -> Assertion

188254 roundTrip a = do

@@ -190,8 +256,92 @@ testJSON TestEnv{..} = TestCase $ do

190256 js' <- query conn "SELECT ?::json" js

191257 [js] @?= js'

192258

193−testSavepoint :: TestEnv -> Test

194−testSavepoint TestEnv{..} = TestCase $ do

259+testAeson :: TestEnv -> Assertion

260+testAeson TestEnv{..} = do

261+ roundTrip (Map.fromList [] :: Map Text Text)

262+ roundTrip (Map.fromList [("foo","bar"),("bar","baz"),("baz","hello")] :: Map Text Text)

263+ roundTrip (Map.fromList [("fo\"o","bar"),("b\\ar","baz"),("baz","\"value\\with\"escapes")] :: Map Text Text)

264+ roundTrip (V.fromList [1,2,3,4,5::Int])

265+ roundTrip ("foo" :: Text)

266+ roundTrip (42 :: Int)

267+ where

268+ roundTrip :: (Eq a, Show a, Typeable a, ToJSON a, FromJSON a)=> a -> Assertion

269+ roundTrip x = do

270+ y <- query conn "SELECT ?::json" (Only (Aeson x))

271+ [Only (Aeson x)] @?= y

272+

273+testDerivingVia :: TestEnv -> Assertion

274+testDerivingVia TestEnv{..} = do

275+#if __GLASGOW_HASKELL__ <806

276+ return ()

277+#else

278+ roundTrip $ DerivingVia1 42 "Meaning of Life"

279+ where

280+ roundTrip :: (Eq a, Show a, Typeable a, ToField a, FromField a)=> a -> Assertion

281+ roundTrip x = do

282+ y <- query conn "SELECT ?::json" (Only x)

283+ [Only x] @?= y

284+

285+data DerivingVia1 = DerivingVia1 Int String

286+ deriving stock (Eq, Show, Generic)

287+ deriving anyclass (FromJSON, ToJSON)

288+ deriving (ToField, FromField) via Aeson DerivingVia1

289+

290+#endif

291+

292+

293+testQM :: TestEnv -> Assertion

294+testQM TestEnv{..} = do

295+ -- Just test on a single string

296+ let testQuery' b = "testing for ?" <> b <> " and making sure "

297+ testQueryDoubleQM = testQuery' "?"

298+ testQueryRest = "? is substituted"

299+ testQuery = fromString $ testQueryDoubleQM <> testQueryRest

300+ -- expect the entire first part with double QMs replaced with literal '?'

301+ expected = (fromString $ testQuery' "", fromString testQueryRest)

302+ tried = breakOnSingleQuestionMark testQuery

303+ errMsg = concat

304+ [ "Failed to break on single question mark exclusively:\n"

305+ , "expected: ", show expected

306+ , "result: ", show tried

307+ ]

308+ assertBool errMsg $ tried == expected

309+

310+ -- Let's also test the question mark operators in action

311+ -- ? -> Does the string exist as a top-level key within the JSON value?

312+ positiveQuery "SELECT ?::jsonb ?? ?" (testObj, "foo" :: Text)

313+ negativeQuery "SELECT ?::jsonb ?? ?" (testObj, "baz" :: Text)

314+ negativeQuery "SELECT ?::jsonb ?? ?" (toJSON numArray, "1" :: Text)

315+ -- ?| -> Do any of these array strings exist as top-level keys?

316+ positiveQuery "SELECT ?::jsonb ??| ?" (testObj, PGArray ["nope","bar","6" :: Text])

317+ negativeQuery "SELECT ?::jsonb ??| ?" (testObj, PGArray ["nope","6" :: Text])

318+ negativeQuery "SELECT ?::jsonb ??| ?" (toJSON numArray, PGArray ["1","2","6" :: Text])

319+ -- ?& -> Do all of these array strings exist as top-level keys?

320+ positiveQuery "SELECT ?::jsonb ??& ?" (testObj, PGArray ["foo","bar","quux" :: Text])

321+ positiveQuery "SELECT ?::jsonb ??& ?" (testObj, PGArray ["foo","bar" :: Text])

322+ negativeQuery "SELECT ?::jsonb ??& ?" (testObj, PGArray ["foo","bar","baz" :: Text])

323+ negativeQuery "SELECT ?::jsonb ??& ?" (toJSON numArray, PGArray ["1","2","3","4","5" :: Text])

324+ -- Format error for 2 question marks, not 4

325+ True <- expectError (isFormatError 2) $

326+ (query conn "SELECT ?::jsonb ?? ?" $ Only testObj :: IO [Only Bool])

327+ return ()

328+ where positiveQuery :: ToRow a => Query -> a -> Assertion

329+ positiveQuery = boolQuery True

330+ negativeQuery :: ToRow a => Query -> a -> Assertion

331+ negativeQuery = boolQuery False

332+ numArray :: [Int]

333+ numArray = [1,2,3,4,5]

334+ boolQuery :: ToRow a => Bool -> Query -> a -> Assertion

335+ boolQuery b t x = do

336+ a <- query conn t x

337+ [Only b] @?= a

338+ testObj = toJSON (Map.fromList [("foo",toJSON (1 :: Int))

339+ ,("bar",String "baz")

340+ ,("quux",toJSON [1 :: Int,2,3,4,5])] :: Map Text Value

341+ )

342+

343+testSavepoint :: TestEnv -> Assertion

344+testSavepoint TestEnv{..} = do

195345 True <- expectError ST.isNoActiveTransactionError $

196346 withSavepoint conn $ return ()

197347

@@ -251,8 +401,8 @@ testSavepoint TestEnv{..} = TestCase $ do

251401

252402 return ()

253403

254−testUnicode :: TestEnv -> Test

255−testUnicode TestEnv{..} = TestCase $ do

404+testUnicode :: TestEnv -> Assertion

405+testUnicode TestEnv{..} = do

256406 let q = Query . T.encodeUtf8 -- Handle encoding ourselves to ensure

257407 -- the table gets created correctly.

258408 let messages = map Only ["привет","мир"] :: [Only Text]

@@ -261,8 +411,8 @@ testUnicode TestEnv{..} = TestCase $ do

261411 messages' <- query_ conn "SELECT сообщение FROM ру́сский"

262412 sort messages @?= sort messages'

263413

264−testValues :: TestEnv -> Test

265−testValues TestEnv{..} = TestCase $ do

414+testValues :: TestEnv -> Assertion

415+testValues TestEnv{..} = do

266416 execute_ conn "CREATE TEMPORARY TABLE values_test (x int, y text)"

267417 test (Values ["int4","text"] [])

268418 test (Values ["int4","text"] [(1,"hello")])

@@ -279,8 +429,8 @@ testValues TestEnv{..} = TestCase $ do

279429 sort vals @?= sort vals'

280430

281431

282−testCopy :: TestEnv -> Test

283−testCopy TestEnv{..} = TestCase $ do

432+testCopy :: TestEnv -> Assertion

433+testCopy TestEnv{..} = do

284434 execute_ conn "CREATE TEMPORARY TABLE copy_test (x int, y text)"

285435 copy_ conn "COPY copy_test FROM STDIN (FORMAT CSV)"

286436 mapM_ (putCopyData conn) copyRows

@@ -297,6 +447,14 @@ testCopy TestEnv{..} = TestCase $ do

297447 -- so that we can issue more queries:

298448 [Only (x::Int)] <- query_ conn "SELECT 2 + 2"

299449 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

300458 where

301459 copyRows = ["1,foo\n"

302460 ,"2,bar\n"]

@@ -307,8 +465,70 @@ testCopy TestEnv{..} = TestCase $ do

307465 CopyOutDone _ -> return rows

308466 CopyOutRow row -> loop (row:rows)

309467

310−testDouble :: TestEnv -> Test

311−testDouble TestEnv{..} = TestCase $ do

468+testCopyFailures :: TestEnv -> TestTree

469+testCopyFailures env = testGroup "Copy failures"

470+ $ map ($ env)

471+ [ testCopyUniqueConstraintError

472+ , testCopyMalformedError

473+ ]

474+

475+goldenTest :: TestName -> IO BL.ByteString -> TestTree

476+goldenTest testName =

477+ goldenVsStringDiff testName diff (resultsDir </> fileName<.>"expected")

478+ where

479+ resultsDir = "test" </> "results"

480+ fileName = map normalize testName

481+ normalize c | not (isAlpha c) = '-'

482+ | otherwise = c

483+ diff ref new = ["diff", "-u", ref, new]

484+

485+-- | Test that we provide a sensible error message on failure

486+testCopyUniqueConstraintError :: TestEnv -> TestTree

487+testCopyUniqueConstraintError TestEnv{..} =

488+ goldenTest "unique constraint violation"

489+ $ handle (\(SomeException exc) -> return $ BL.pack $ show exc) $ do

490+ execute_ conn "CREATE TEMPORARY TABLE copy_unique_constraint_error_test (x int PRIMARY KEY, y text)"

491+ copy_ conn "COPY copy_unique_constraint_error_test FROM STDIN (FORMAT CSV)"

492+ mapM_ (putCopyData conn) copyRows

493+ _n <- putCopyEnd conn

494+ return BL.empty

495+ where

496+ copyRows = ["1,foo\n"

497+ ,"2,bar\n"

498+ ,"1,baz\n"]

499+

500+testCopyMalformedError :: TestEnv -> TestTree

501+testCopyMalformedError TestEnv{..} =

502+ goldenTest "malformed input"

503+ $ handle (\(SomeException exc) -> return $ BL.pack $ show exc) $ do

504+ execute_ conn "CREATE TEMPORARY TABLE copy_malformed_input_error_test (x int PRIMARY KEY, y text)"

505+ copy_ conn "COPY copy_unique_constraint_error_test FROM STDIN (FORMAT CSV)"

506+ mapM_ (putCopyData conn) copyRows

507+ _n <- putCopyEnd conn

508+ return BL.empty

509+ where

510+ copyRows = ["1,foo\n"

511+ ,"2,bar\n"

512+ ,"z,baz\n"]

513+

514+testTimeout :: TestEnv -> Assertion

515+testTimeout TestEnv{..} =

516+ withConn $ \c -> do

517+ start_t <- getCurrentTime

518+ res <- timeout 200000 $ do

519+ withTransaction c $ do

520+ query_ c "SELECT pg_sleep(1)" :: IO [Only ()]

521+ end_t <- getCurrentTime

522+ assertBool "Timeout did not occur" (res == Nothing)

523+#if !defined(mingw32_HOST_OS)

524+-- At the moment, you cannot timely abandon queries with async exceptions on

525+-- Windows.

526+ let d = end_t `diffUTCTime` start_t

527+ assertBool "Timeout didn't work in a timely fashion" (0.1 < d && d < 0.6)

528+#endif

529+

530+testDouble :: TestEnv -> Assertion

531+testDouble TestEnv{..} = do

312532 [Only (x :: Double)] <- query_ conn "SELECT 'NaN'::float8"

313533 assertBool "expected NaN" (isNaN x)

314534 [Only (x :: Double)] <- query_ conn "SELECT 'Infinity'::float8"

@@ -317,6 +537,45 @@ testDouble TestEnv{..} = TestCase $ do

317537 x @?= (-1 / 0)

318538

319539

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+

320579data TestException

321580 = TestException

322581 deriving (Eq, Show, Typeable)

@@ -334,28 +593,56 @@ isUniqueViolation SqlError{..} = sqlState == "23505"

334593isSyntaxError :: SqlError -> Bool

335594isSyntaxError SqlError{..} = sqlState == "42601"

336595

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+ ]

337604------------------------------------------------------------------------

338605

339606-- | Action for connecting to the database that will be used for testing.

340607--

341608-- Note that some tests, such as Notify, use multiple connections, and assume

342609-- that 'testConnect' connects to the same database every time it is called.

343−testConnect :: IO Connection

344−testConnect = connectPostgreSQL ""

610+withTestEnv :: ByteString -> (TestEnv -> IO a) -> IO a

611+withTestEnv connstr cb =

612+ withConn $ \conn -> do

613+ -- currently required for interval to work.

614+ -- we also test that this doesn't interfere with anything else

615+ execute_ conn "SET intervalstyle TO 'iso_8601'"

345616

346−withTestEnv :: (TestEnv -> IO a) -> IO a

347−withTestEnv cb =

348− withConn $ \conn ->

349617 cb TestEnv

350618 { conn = conn

351619 , withConn = withConn

352620 }

353621 where

354− withConn = bracket testConnect close

622+ withConn = bracket (connectPostgreSQL connstr) close

355623

356624main :: IO ()

357−main = do

358− mapM_ (`hSetBuffering` LineBuffering) [stdout, stderr]

359− Counts{cases, tried, errors, failures} <-

360− withTestEnv $ \env -> runTestTT $ TestList $ map ($ env) tests

361− when (cases /= tried || errors /= 0 || failures /= 0) $ exitFailure

625+main = withConnstring $ \connstring -> do

626+ withTestEnv connstring (defaultMain . tests)

627+

628+withConnstring :: (BS8.ByteString -> IO ()) -> IO ()

629+withConnstring kont = do

630+ env <- getEnvironment

631+ case lookup "DATABASE_CONNSTRING" env of

632+ Just s -> kont (BS8.pack (special s))

633+ Nothing -> case lookup "GITHUB_ACTIONS" env of

634+ Just "true" -> kont (BS8.pack gha)

635+ _ -> putStrLn "Set DATABASE_CONNSTRING environment variable"

636+ where

637+ -- https://www.appveyor.com/docs/services-databases/

638+ special "appveyor" = "dbname='TestDb' user='postgres' password='Password12!'"

639+ special "travis" = ""

640+ special s = s

641+

642+ gha = unwords

643+ [ "dbname='postgres'"

644+ , "user='postgres'"

645+ , "password='postgres'"

646+ , "host='postgres'"

647+ , "port=5432"

648+ ]

test/Notify.hs+1−2

@@ -14,9 +14,8 @@ import qualified Data.ByteString as B

1414-- TODO: Test with payload, but only for PostgreSQL >= 9.0

1515-- (when that feature was introduced).

1616

17−testNotify :: TestEnv -> Test

17+testNotify :: TestEnv -> Assertion

1818testNotify TestEnv{..} =

19− TestCase $

2019 withConn $ \conn2 -> do

2120 execute_ conn "LISTEN foo"

2221 execute_ conn "LISTEN bar"

test/Serializable.hs+1−2

@@ -23,9 +23,8 @@ putCounter conn n = do

2323 1 <- execute conn "UPDATE testSerializableCounter SET n=?" (Only n)

2424 return ()

2525

26−testSerializable :: TestEnv -> Test

26+testSerializable :: TestEnv -> Assertion

2727testSerializable TestEnv{..} =

28− TestCase $

2928 withConn $ \conn2 -> do

3029 initCounter conn

3130

test/Time.hs+18−10

@@ -36,26 +36,26 @@ module Time (testTime) where

3636

3737import Common

3838import Control.Monad(forM_, replicateM_)

39−import Data.Time

39+import Data.Time.Compat

4040import Data.ByteString(ByteString)

4141import Database.PostgreSQL.Simple.SqlQQ

4242

4343numTests :: Int

4444numTests = 200

4545

46−testTime :: TestEnv -> Test

47−testTime env@TestEnv{..} = TestCase $ do

46+testTime :: TestEnv -> Assertion

47+testTime env@TestEnv{..} = do

4848 initializeTable env

4949 execute_ conn "SET timezone TO 'UTC'"

50− checkRoundTrips env

50+ checkRoundTrips env "1860-01-01 00:00:00+00"

5151 execute_ conn "SET timezone TO 'America/Chicago'" -- -5:00

52− checkRoundTrips env

52+ checkRoundTrips env "1883-11-18 12:00:00-06"

5353 execute_ conn "SET timezone TO 'Asia/Tokyo'" -- +9:00

54− checkRoundTrips env

54+ checkRoundTrips env "1888-01-01 00:00:00+09"

5555 execute_ conn "SET timezone TO 'Asia/Kathmandu'" -- +5:45

56− checkRoundTrips env

56+ checkRoundTrips env "1919-12-31 23:48:44+05:30"

5757 execute_ conn "SET timezone TO 'America/St_Johns'" -- -3:30

58− checkRoundTrips env

58+ checkRoundTrips env "1935-03-30 00:00:52-03:30"

5959

6060initializeTable :: TestEnv -> IO ()

6161initializeTable TestEnv{..} = withTransaction conn $ do

@@ -102,10 +102,18 @@ initializeTable TestEnv{..} = withTransaction conn $ do

102102 pop "100 milliseconds" 6.3113904e10

103103 pop "1 second" 6.3113904e9

104104

105−checkRoundTrips :: TestEnv -> IO ()

106−checkRoundTrips TestEnv{..} = do

105+checkRoundTrips :: TestEnv -> ByteString -> IO ()

106+checkRoundTrips TestEnv{..} limit = do

107107 yxs :: [(UTCTime, Int)] <- query_ conn [sql| SELECT y, x FROM testtime |]

108108 forM_ yxs $ \yx -> do

109109 res <- query conn [sql| SELECT y=? FROM testtime WHERE x=? |] yx

110110 assertBool "UTCTime did not round-trip from SQL to Haskell and back" $

111111 res == [Only True]

112+

113+ yxs :: [(ZonedTime, Int)] <- query conn [sql|

114+ SELECT y, x FROM testtime WHERE y > ?

115+ |] (Only limit)

116+ forM_ yxs $ \yx -> do

117+ res <- query conn [sql| SELECT y=? FROM testtime WHERE x=? |] yx

118+ assertBool "ZonedTime did not round-trip from SQL to Haskell and back" $

119+ res == [Only True]

test/results/malformed-input.expectednew file+4

@@ -0,0 +1,4 @@

1+user error (Database.PostgreSQL.Simple.Copy.putCopyEnd: failed to parse command status

2+Connection error: ERROR: invalid input syntax for type integer: "z"

3+CONTEXT: COPY copy_unique_constraint_error_test, line 3, column x: "z"

4+)

test/results/unique-constraint-violation.expectednew file+5

@@ -0,0 +1,5 @@

1+user error (Database.PostgreSQL.Simple.Copy.putCopyEnd: failed to parse command status

2+Connection error: ERROR: duplicate key value violates unique constraint "copy_unique_constraint_error_test_pkey"

3+DETAIL: Key (x)=(1) already exists.

4+CONTEXT: COPY copy_unique_constraint_error_test, line 3

5+)

tools/GenBuiltinTypes.hsdeleted−183

@@ -1,183 +0,0 @@

1−------------------------------------------------------------------------------

2−-- |

3−-- Module: GenBuiltinTypes

5−-- License: BSD3

6−-- Maintainer: Leon P Smith <leon@melding-monads.com>

7−-- Stability: experimental

8−--

9−-- Queries a PostgreSQL for the Object IDs associated with built-in typenames,

10−-- and generates Haskell boilerplate to handle this mapping. The subset

11−-- of types handled this way is easily modifiable, but note that

12−-- user-defined types do not have stable oids, and can differ between

13−-- databases or dumps/reloads.

14−------------------------------------------------------------------------------

15−

16−{-# LANGUAGE OverloadedStrings, QuasiQuotes, ViewPatterns #-}

17−module GenBuiltinTypes where

18−

19−import Prelude hiding ((++))

20−

21−import StringsQQ

22−import Database.PostgreSQL.Simple

23−import qualified Data.ByteString.Char8 as B

24−import qualified Data.ByteString.Lazy as L

25−import qualified Blaze.ByteString.Builder as Blaze

26−import qualified Blaze.ByteString.Builder.ByteString as Blaze

27−import qualified Blaze.ByteString.Builder.Char8 as Blaze

28−import Data.String

29−import Data.List ( sort, intersperse )

30−import qualified Data.Map as Map

31−

32−import Data.Monoid

33−

34−(++) :: Monoid a => a -> a -> a

35−(++) = mappend

36−infixr 5 ++

37−

38−type Map = Map.Map B.ByteString Int

39−builtins :: [(B.ByteString, B.ByteString)]

40−builtins = [strings|

41−bool

42−bytea ByteA

43−char

44−name

45−int8

46−int2

47−int4

48−regproc RegProc

49−text

50−oid

51−tid

52−xid

53−cid

54−xml

55−point

56−lseg LSeg

57−path

58−box

59−polygon

60−line

61−cidr

62−float4

63−float8

64−abstime AbsTime

65−reltime RelTime

66−tinterval TInterval

67−unknown

68−circle

69−money

70−macaddr MacAddr

71−inet

72−bpchar BpChar

73−varchar VarChar

74−date

75−time

76−timestamp

77−timestamptz TimestampTZ

78−interval

79−timetz TimeTZ

80−bit

81−varbit VarBit

82−numeric

83−refcursor RefCursor

84−record

85−void

86−uuid UUID

87−json JSON

88−jsonb JSONB

89−|]

90−

91−instance IsString Blaze.Builder where

92− fromString = Blaze.fromByteString . fromString

93−

94−main = do

95− conn <- connectPostgreSQL ""

96− xs <- query conn "SELECT typname::text, oid::int\

97− \ FROM pg_type\

98− \ WHERE typname IN ?"

99− (Only (In (sort (map fst builtins))))

100− close conn

101− let oidmap = Map.fromList xs :: Map

102− L.writeFile "../src/Database/PostgreSQL/Simple/BuiltinTypes.hs"

103− (Blaze.toLazyByteString (renderFile oidmap builtins))

104−

105−padCons str = fromString (replicate (len - B.length str) ' ')

106− where

107− len = maximum (map (B.length . snd) builtins)

108−

109−renderOid oidmap x

110− = case Map.lookup x oidmap of

111− Nothing -> error (B.unpack x)

112− Just (show -> n) -> fromString (replicate (4 - length n) ' ')

113− ++ fromString n

114−

115−renderOid' oidmap x

116− = case Map.lookup x oidmap of

117− Nothing -> error (B.unpack x)

118− Just (show -> n) -> fromString n

119− ++ fromString (replicate (4 - length n) ' ')

120−

121−bs = Blaze.fromByteString

122−

123−renderFile :: Map -> [(B.ByteString,B.ByteString)] -> Blaze.Builder

124−renderFile oidmap builtins = ([longstring|

125−{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}

126−

127−------------------------------------------------------------------------------

128−-- |

129−-- Module: Database.PostgreSQL.Simple.BuiltinTypes

131−-- License: BSD3

132−-- Maintainer: Leon P Smith <leon@melding-monads.com>

133−-- Stability: experimental

134−--

135−------------------------------------------------------------------------------

136−

137−-- Note that this file is generated by tools/GenBuiltinTypes.hs, and should

138−-- not be edited directly

139−

140−module Database.PostgreSQL.Simple.BuiltinTypes

141− {-# DEPRECATED "Use TypeInfo instead" #-}

142− ( BuiltinType (..)

143− , builtin2oid

144− , oid2builtin

145− , builtin2typname

146− , oid2typname

147− ) where

148−

149−import Data.Typeable

150−import Data.ByteString (ByteString)

151−import qualified Database.PostgreSQL.LibPQ as PQ

152−

153−data BuiltinType

154− = |] ++ mconcat (intersperse "\n | " (map (Blaze.fromByteString . snd) builtins)) ++ [longstring|

155−

156− deriving (Eq, Ord, Enum, Bounded, Read, Show, Typeable)

157−

158−builtin2oid :: BuiltinType -> PQ.Oid

159−builtin2oid typ = PQ.Oid $ case typ of

160−|] ++ mconcat [mconcat [ " ", bs y, padCons y, " -> "

161− , renderOid oidmap x, "\n" ]

162− | (x,y) <- builtins ] ++ [longstring|

163−

164−oid2builtin :: PQ.Oid -> Maybe BuiltinType

165−oid2builtin (PQ.Oid x) = case x of

166−|] ++ mconcat [mconcat [ " ", renderOid' oidmap x, " -> Just ", bs y, "\n" ]

167− | (x,y) <- builtins ] ++ [longstring|

168− _ -> Nothing

169−

170−builtin2typname :: BuiltinType -> ByteString

171−builtin2typname typ = case typ of

172−|] ++ mconcat [mconcat [ " ", bs y, padCons y, " -> ", bs x, "\n"]

173− | (x,y) <- builtins] ++ [longstring|

174−

175−oid2typname :: PQ.Oid -> Maybe ByteString

176−oid2typname (PQ.Oid x) = case x of

177−|] ++ mconcat [mconcat [ " ", renderOid' oidmap x, " -> Just ", bs x, "\n" ]

178− | (x,y) <- builtins ]

179− ++ " _ -> Nothing\n"

180− ++ mconcat [mconcat [ "\n"

181− , bs x, " :: ByteString\n"

182− , bs x, " = \"", bs x, "\"\n"]

183− | (x,_y) <- builtins ])

tools/GenTypeInfo.hs+169−39

@@ -21,6 +21,9 @@

2121-- know about. It then constructs a TypeInfo record and stores it in

2222-- a per-connection cache for later use.

2323--

24+-- @

25+-- runghc -itools tools/GenTypeInfo.hs

26+-- @

2427------------------------------------------------------------------------------

2528

2629{-# LANGUAGE OverloadedStrings, QuasiQuotes, ViewPatterns, RecordWildCards #-}

@@ -38,12 +41,10 @@ import Database.PostgreSQL.Simple.FromRow

3841import Database.PostgreSQL.Simple.Ok

3942import Database.PostgreSQL.Simple.Types(Oid(..))

4043import Database.PostgreSQL.Simple.SqlQQ

41−import qualified Data.ByteString.Char8 as B

44+import qualified Data.ByteString.Char8 as B8

4245import Data.ByteString(ByteString)

4346import qualified Data.ByteString.Lazy as L

44−import qualified Blaze.ByteString.Builder as Blaze

45−import qualified Blaze.ByteString.Builder.ByteString as Blaze

46−import qualified Blaze.ByteString.Builder.Char8 as Blaze

47+import qualified Data.ByteString.Builder as Blaze

4748import Data.String

4849import Data.List ( sort, intersperse )

4950import qualified Data.Map as Map

@@ -63,16 +64,17 @@ data TypeInfo = TypeInfo

6364 , typdelim :: Char

6465 , typname :: ByteString

6566 , typelem :: Oid

67+ , rngsubtype :: Maybe Oid

6668 }

6769

68−instance FromRow TypeInfo where

69− fromRow = TypeInfo <$> field <*> field <*> field <*> field <*> field

70+instance FromRow TypeInfo where

71+ fromRow = TypeInfo <$> field <*> field <*> field <*> field <*> field <*> field

7072

71−type NameMap = Map.Map B.ByteString TypeInfo

73+type NameMap = Map.Map B8.ByteString TypeInfo

7274

7375type OidMap = Map.Map Oid TypeInfo

7476

75−type TypeName = (B.ByteString, B.ByteString)

77+type TypeName = (B8.ByteString, B8.ByteString)

7678

7779type TypeNames = [TypeName]

7880

@@ -103,9 +105,6 @@ line

103105cidr

104106float4

105107float8

106−abstime

107−reltime

108−tinterval

109108unknown

110109circle

111110money

@@ -125,49 +124,118 @@ numeric

125124refcursor

126125record

127126void

127+_record array_record

128+regprocedure

129+regoper

130+regoperator

131+regclass

132+regtype

128133uuid

129134json

130135jsonb

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

131199|]

132200

133−instance IsString Blaze.Builder where

134− fromString = Blaze.fromByteString . fromString

135−

136201connectionString = "dbname=postgres"

137202

138203withPostgreSQL = bracket (connectPostgreSQL connectionString) close

139204

140205getTypeInfos :: TypeNames -> IO (OidMap, NameMap)

141206getTypeInfos typnames = withPostgreSQL $ \conn -> do

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))))

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))))

148213 loop conn (oidMap infos) (nameMap infos) infos

149214 where

150215 oidMap = Map.fromList . map (typoid &&& id)

151216 nameMap = Map.fromList . map (typname &&& id)

152217 loop conn oids names infos = do

153− let unknowns = [ x | x <- map typelem infos,

218+ let unknowns = [ x | x <- map typelem infos ++

219+ [ x | Just x <- map rngsubtype infos ],

154220 x /= Oid 0,

155221 not (Map.member x oids) ]

156222 case unknowns of

157223 [] -> return (oids, names)

158224 (_:_) -> do

159225 infos' <- query conn [sql|

160− SELECT oid, typcategory, typdelim, typname, typelem

161− FROM pg_type

162− WHERE oid IN ?

163− |] (Only (In (sort unknowns)))

226+ WITH types AS

227+ (SELECT oid, typcategory, typdelim, typname, typelem

228+ FROM pg_type WHERE oid IN ?)

229+ SELECT types.*, rngsubtype

230+ FROM types LEFT JOIN pg_range ON oid = rngtypid

231+ |] (Only (In (sort unknowns)))

164232 let oids' = oids `Map.union` oidMap infos'

165233 names' = names `Map.union` nameMap infos'

166234 loop conn oids' names' infos'

167235

168236main = do

169237 (oidmap, namemap) <- getTypeInfos typeNames

170− L.writeFile "../src/Database/PostgreSQL/Simple/TypeInfo/Static.hs"

238+ L.writeFile "src/Database/PostgreSQL/Simple/TypeInfo/Static.hs"

171239 (Blaze.toLazyByteString (renderFile oidmap namemap typeNames))

172240

173241

@@ -176,7 +244,7 @@ showOid (Oid n) = show n

176244renderOid :: NameMap -> TypeName -> Blaze.Builder

177245renderOid byName name

178246 = case Map.lookup (pg name) byName of

179− Nothing -> error (B.unpack (pg name))

247+ Nothing -> error (B8.unpack (pg name))

180248 Just (showOid . typoid -> n) -> fromString n

181249 ++ fromString (replicate (4 - length n) ' ')

182250

@@ -187,13 +255,83 @@ renderElem byOid elemOid

187255 Nothing -> error ("oid not found: " ++ show elemOid)

188256 Just x -> "Just " ++ bs (typname x)

189257

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+

190328-- FIXME: add in any names that we need that we didn't specify, (i.e.

191329-- the "unknowns" in getTypeInfos

192330-- and munge them into a valid haskell identifier if needed.

193331getNames :: NameMap -> TypeNames -> TypeNames

194332getNames _ x = x

195333

196−bs = Blaze.fromByteString

334+bs = Blaze.byteString

197335

198336pg = fst

199337

@@ -222,6 +360,7 @@ module Database.PostgreSQL.Simple.TypeInfo.Static

222360 ( TypeInfo(..)

223361 , staticTypeInfo

224362|] ++ concat [ " , " ++ bs (hs name) ++ "\n"

363+ ++ " , " ++ bs (hs name) ++ "Oid\n"

225364 | name <- names ] ++ [longstring|

226365 ) where

227366

@@ -237,15 +376,6 @@ staticTypeInfo (Oid x) = case x of

237376 ++ [longstring|

238377 _ -> Nothing

239378|]

240− ++ concat [concat

241− [ "\n"

242− , bs (hs name), " :: TypeInfo\n"

243− , bs (hs name), " = Basic {\n"

244− , " typoid = ", fromString (show typoid), ",\n"

245− , " typcategory = '", Blaze.fromChar typcategory, "',\n"

246− , " typdelim = '", Blaze.fromChar typdelim, "',\n"

247− , " typname = \"", bs typname, "\"\n"

248− , " }\n"

249− ]

379+ ++ concat [ renderTypeInfo byOid typeInfo name

250380 | name <- getNames byName names

251− , let (Just (TypeInfo{..})) = Map.lookup (pg name) byName])

381+ , let (Just typeInfo) = Map.lookup (pg name) byName])