de11024..master · typeable/postgresql-simple

git.iko.soy/typeable/postgresql-simple

63 files changed+6148−2057

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

CHANGESdeleted−405

@@ -1,405 +0,0 @@

1−Version 0.4.6.0 (2014-10-07)

2− * Added an instance ToField NominalDiffTime.

3−

4−Version 0.4.5.0 (2014-09-26)

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

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

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

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

9− for reporting the issue.

10−

11−Version 0.4.4.1 (2014-09-07)

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

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

14− Dmitry Dzhus for reporting the issue.

15−

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

17−

18−Version 0.4.4.0 (2014-08-26)

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

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

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

22− patch.

23−

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

25− a documentation typo.

26−

27−Version 0.4.3.0 (2014-07-10)

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

29− This means we are using threadWaitRead and threadWaitWrite to

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

31− instead of using blocking C calls and having the OS kernel do the

32− scheduling. Among other things, this now means that System.Timeout

33− will work with connect and exec on unix platforms.

34−

35− * connect and exec now throw IOErrors instead of SQLErrors in

36− some cases. The intention is for SQLErrors to represent

37− an error returned by the server, and to use IOErrors for errors

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

39− isn't perfectly achieved as of yet.

40−

41−Version 0.4.2.3 (2014-06-04)

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

43−

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

45−

46− * Expanded the documentation of connectPostgreSQL, including a short

47− overview of common use cases and two new links to the official Postgres

48− documentation about the authentication process.

49−

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

51−

52−Version 0.4.2.2 (2014-05-15)

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

54−

55− * Improved documentation of the FromField module, as well as the fold,

56− foldWithOptions, executeMany, and returning operators.

57−

58−Version 0.4.2.1 (2014-03-27)

59− * Fixed bug in Values syntax generation

60−

61− * Improved documentation, including examples of multi-row update,

62− a better example for Values, documenting the inaccuracies in reading

63− floating point numbers from the database, and the IsString instance

64− for QualifiedIdentifier.

65−

66−Version 0.4.2.0 (2014-03-22)

67− * Added ToField and FromField instances for the scientific package

68−

69− * Changed the Identifier and QualifiedIdentifier to use Text in

70− order to avoid encoding errors. Technically this requires a

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

72−

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

74− and tweaked error messages.

75−

76−Version 0.4.1.0 (2014-03-22)

77− * Fixed the parsing of arrays containing null values, courtesy of

78− Francesco Mazzoli

79−

80− * Added support for properly escaped identifiers, courtesy of

81− Tobias Florek. See the new Identifier and QualifiedIdentifier

82− types inside Database.PostgreSQL.Simple.Types.

83−

84− * Added support for parameterized VALUES expressions. This is

85− more general than executeMany and returning. See the

86− Database.PostgreSQL.Simple.Types.Values data type.

87−

88−Version 0.4.0.2 (2014-01-12)

89− * Tweaked C preprocessor directive to be more portable

90−

91− * Tweaked testsuite for compatibility with aeson-0.7

92−

93−Version 0.4.0.1 (2013-12-21)

94− * Relaxed dependency on aeson to >= 0.6

95−

96− * Update the documentation of `fromField`

97−

98−Version 0.4.0.0 (2013-12-21)

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

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

101− performance bump for most people most of the time; however it

102− may slow down retrieval of large values not converted directly

103− to ByteString, such as large json, hstore, and array values.

104− See commit 8635f8 for more information.

105−

106− * Added the PGArray type. Thanks to Joey Adams for the suggestion

107−

108− * Fixed JSON decoding, which was almost entirely broken up until now,

109− due to bugs in the version of aeson currently available on Hackage.

110− Thanks to Amit Levy for the report.

111−

112− * Added FromField instances for IORef, MVar, and IOVector.

113−

114−Version 0.3.10.0 (2013-12-17)

115− * Added the queryWith function, courtesy of Leonid Onokhov

116−

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

118−

119−Version 0.3.9.1 (2013-10-28)

120− * Removed dependency on hashable

121−

122−Version 0.3.9.0 (2013-10-27)

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

124− courtesy of Bas van Dijk.

125−

126− * Added instance FromRow (Maybe a) for most pre-packaged FromRow

127− instances. See issue #64 for some discussion.

128−

129− * Added the fromBinary, fromHStoreMap, and fromHStoreList newtype

130− unwrapper functions, courtesy of Bas van Dijk.

131−

132−Version 0.3.8.0 (2013-10-11)

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

134−

135− * Added `Notification.getBackendPID`.

136−

137−Version 0.3.7.1 (2013-09-12)

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

139− courtesy of Michael Snoyman

140−

141−Version 0.3.7.0 (2013-09-11)

142− * Added `aeson` as a dependency.

143−

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

145− courtesy of Bas van Dijk.

146−

147− * Added toJSONField and fromJSONField helper functions for declaring

148− FromField/ToField JSON instances to other Haskell types, courtesy

149− of Bas van Dijk.

150−

151− * Added a FromField instance for (), corresponding to postgresql's void

152− type.

153−

154− * Added liftConversion and liftRowParser functions to the Internal

155− module, for lifting IO actions into the respective monads.

156−

157− * The SqlError predicates available in the Transaction module are now

158− also exported from the Errors module.

159−

160− * Various documentation fixes.

161−

162−Version 0.3.6.0 (2013-08-19)

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

164− Manuel Gómez.

165−

166− * Removed the remaining internal dependencies on BuiltinTypes from

167− FromField. Added the TypeInfo.Macro module as a result.

168−

169− * Deprecated the BuiltinTypes module, which will be removed several

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

171− this change.

172−

173−Version 0.3.5.0 (2013-08-09)

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

175− existing FromRow instance for [], courtesy of Doug Beardsley

176−

177− * Reworked the documentation for the Copy module, and tweaked the

178− documentation for the LargeObjects module.

179−

180−Version 0.3.4.0 (2013-07-23)

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

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

183− module.

184−

185− * Changed `getNotification` so that it throws a IOError (resource vanished)

186− exception instead of an ErrorCall exception when it fails to fetch

187− the connection's file descriptor from libpq.

188−

189−Version 0.3.3.2 (2013-06-18)

190− * Optimized the definition of `mconcat` in the Monoid instance for

191− the Query type, courtesy of Joey Adams.

192−

193−Version 0.3.3.1 (2013-06-06)

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

195− polling loop, courtesy of Joey Adams.

196−

197−Version 0.3.3.0 (2013-05-29)

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

199− exception, and gave the database cursor a static name preventing

200− folds from being nested. Thanks to Joey Adams for his

201− work on these issues.

202−

203−Version 0.3.2.0 (2013-05-20)

204− * Added a savepoint abstraction to the Transaction module, courtesy

205− of Joey Adams

206−

207−Version 0.3.1.2 (2013-04-29)

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

209−

210−Version 0.3.1.1 (2013-04-29)

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

212− Meier

213−

214−Version 0.3.1.0 (2013-04-26)

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

216−

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

218−

219− * Improved documentation of the FromField module.

220−

221−Version 0.3.0.1 (2013-03-26)

222− * A large chunk of the documentation inside the FromField module had

223− silently failed to render in Haddock.

224−

225−Version 0.3.0.0 (2013-03-25)

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

227− for his work on this feature.

228−

229− * Added a brand new TypeInfo system that gives FromField instances

230− convenient and efficient access to the pg_type metatable. This

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

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

233− work on this feature.

234−

235− * Changed the type of the `fromField` and `fromRow` methods to allow

236− a restricted set of IO actions, and stopped pre-calculating the type

237− name of every column. As a result, the type of the `typename`

238− operator changed from `Field -> ByteString` to

239− `Field -> Conversion ByteString`, where Conversion is the new monad

240− that conversion computations run inside.

241−

242− * Improved the documentation of the FromField module.

243−

244− * Added the Database.PostgreSQL.Simple.Errors module, which offers

245− some predicates and functions for interpreting SqlError values, courtesy

246− of Leonid Onokhov.

247−

248− * Added a the name of a column and the associated table's object identifier

249− to ResultError exceptions, courtesy of Jeff Chu.

250−

251− * Moved most of the more detailed transaction operators into the

252− Database.PostgreSQL.Simple.Transaction module.

253−

254− * Changed withTransactionModeRetry to accept a predicate of which

255− SqlErrors to retry, due to the fact that serialization errors can

256− sometimes manifest themselves as constraint violations. Thanks

257− to Oliver Charles for pointing this out and implementing the change.

258−

259− * Added simple tests of the fold operator, thanks to Joey Adams.

260−

261− * Added simple tests of the array conversion code.

262−

263− * Added recognition of -- comments in the quasiquoter, which are

264− now stripped out.

265−

266−

267−Version 0.2.4.1 (2012-08-29)

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

269− pointing this out.

270−

271−Version 0.2.4.0 (2012-08-23)

272− * Added the `withTransactionSerializable` and `withTransactionModeRetry`

273− operators, thanks to Joey Adams.

274−

275−Version 0.2.3.0 (2012-08-09)

276− * Added the `returning` operator, thanks to Jason Dusek

277−

278−Version 0.2.2.0 (2012-07-26)

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

280−

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

282−

283−Version 0.2.1.0 (2012-07-23)

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

285−

286− * Added a type synonym for FieldParser

287−

288−Version 0.2.0.1 (2012-06-21)

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

290− clients to set their own value for `standard_conforming_strings`. This

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

292−

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

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

295− broken even though it will still compile.

296−

297− * Renamed a number of data constructors, mostly in the BuiltinTypes module.

298−

299− * Exported ToRow/FromRow from Database.PostgreSQL.Simple

300−

301−

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

303− * Fix language extensions for compatibility with GHC 7.0

304−

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

306− * Fix a wayward dependency on Text.

307−

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

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

310−

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

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

313−

314− * Reworked support for the Time types.

315−

316− * The conversion from PostgreSQL's `timestamp` (without time zone) type

317− to Haskell's `UTCTime` type is deprecated and will be removed in 0.2.

318−

319− * `Data.Time.LocalTime` now has `FromField`/`ToField` instances. It is

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

321−

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

323− that accomodate PostgreSQL's infinities.

324−

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

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

327− time package included in GHC.

328−

329− * Planned breaking changes for 0.2:

330−

331− * Removing the conversion from `timestamp` to `UTCTime`.

332−

333− * Renaming some of the type names in `BuiltinTypes`.

334−

335−

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

337− * Made ZonedTime an instance of FromField and ToField

338−

339− * Added getNotificationNonBlocking

340−

341−

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

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

344− PostgreSQL 8 courtesy of Joey Adams.

345−

346− * postgresql-simple now sets standard_conforming_strings to "on". This

347− per-connection variable is initialized according to the server

348− configuration, which defaults to "off" for PostgreSQL < 9, and "on"

349− for PostgreSQL >= 9. You may need to adjust any string literals in

350− your SQL queries, or set the variable yourself.

351−

352− * Exported (:.) from Database.PostgreSQL.Simple

353−

354−

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

356− * Added some preliminary documentation for the Ok, Notification, and

357− LargeObjects modules

358−

359− * Implemented the `fail` method for the monad instance for `Ok`.

360−

361− * Fixed a bug relating to handling the transaction level

362−

363−

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

365− * Renamed several modules, typeclasses, and functions:

366−

367− QueryParams (renderParams) -> ToRow (toRow)

368− QueryResults (convertResults) -> FromRow (fromRow)

369− Param (render) -> ToField (toField)

370− Result (convert) -> FromField (fromField)

371−

372− * Added the `Database.PostgreSQL.Simple.Ok` module, a variation of

373− `Either SomeException` that has an instance for `Alternative` and also

374− uses a list of exceptions to track the ways it has failed.

375−

376− * Changed the return type of `fromField` and `fromRow` from

377− `Either SomeException` to `Ok`.

378−

379− * Thanks to suggestions from Ozgun Ataman, the `FromRow` typeclass has been

380− massively improved. The result is simpler definitions and better

381− compositionality. Also, user-defined instances need not be to be

382− concerned about forcing the converted results to WHNF. Here is an

383− example comparing the old to the new:

384−

385− instance (Result a, Result b) => QueryResults (a,b) where

386− convertResults [fa,fb] [va,vb] = do

387− !a <- convert fa va

388− !b <- convert fb vb

389− return (a,b)

390− convertResults fs vs = convertError fs vs 2

391−

392− instance (FromField a, FromField b) => FromRow (a,b) where

393− fromRow = (,) <$> field <*> field

394−

395− * Added `(:.)`, a pair that allows one to compose `FromRow` instances:

396−

397− instance (FromRow a, FromRow b) => FromRow (a :. b) where

398− fromRow = (:.) <$> fromRow <*> fromRow

399−

400− * Moved the contents `Field` module into the `FromField` module.

401−

402− * Removed the `RawResult` type.

403−

404− * Added `DefaultIsolationLevel` as a distinct `IsolationLevel` option

405− and `DefaultReadWriteMode` as a distinct `ReadWriteMode`.

CHANGES.mdnew file+746

@@ -0,0 +1,746 @@

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)

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

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

325+ contains seconds.

326+

327+ All timezones in the TZ database moved to a time standard offset an

328+ integer number of minutes from UTC before 1973, almost all locations

329+ moved before 1938, and a solid majority moved before 1921.

330+

331+ ZonedTime assumes offsets are a whole number of minutes, and thus the

332+ conversion to ZonedTime does not support these timestamps and will

333+ still throw a conversion error.

334+

335+ Note that PostgreSQL's "timestamp with time zone" (or "timestamptz")

336+ type is nearly universally misunderstood. For an explanation, see:

337+

338+ https://github.com/lpsmith/postgresql-simple/issues/69

339+

340+ Thanks to Michael Snoyman for his assistance with this issue.

341+

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

343+ * Added an instance ToField NominalDiffTime.

344+

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

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

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

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

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

350+ for reporting the issue.

351+

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

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

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

355+ Dmitry Dzhus for reporting the issue.

356+

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

358+

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

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

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

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

363+ patch.

364+

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

366+ a documentation typo.

367+

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

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

370+ This means we are using threadWaitRead and threadWaitWrite to

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

372+ instead of using blocking C calls and having the OS kernel do the

373+ scheduling. Among other things, this now means that System.Timeout

374+ will work with connect and exec on unix platforms.

375+

376+ * connect and exec now throw IOErrors instead of SQLErrors in

377+ some cases. The intention is for SQLErrors to represent

378+ an error returned by the server, and to use IOErrors for errors

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

380+ isn't perfectly achieved as of yet.

381+

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

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

384+

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

386+

387+ * Expanded the documentation of connectPostgreSQL, including a short

388+ overview of common use cases and two new links to the official Postgres

389+ documentation about the authentication process.

390+

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

392+

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

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

395+

396+ * Improved documentation of the FromField module, as well as the fold,

397+ foldWithOptions, executeMany, and returning operators.

398+

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

400+ * Fixed bug in Values syntax generation

401+

402+ * Improved documentation, including examples of multi-row update,

403+ a better example for Values, documenting the inaccuracies in reading

404+ floating point numbers from the database, and the IsString instance

405+ for QualifiedIdentifier.

406+

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

408+ * Added ToField and FromField instances for the scientific package

409+

410+ * Changed the Identifier and QualifiedIdentifier to use Text in

411+ order to avoid encoding errors. Technically this requires a

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

413+

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

415+ and tweaked error messages.

416+

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

418+ * Fixed the parsing of arrays containing null values, courtesy of

419+ Francesco Mazzoli

420+

421+ * Added support for properly escaped identifiers, courtesy of

422+ Tobias Florek. See the new Identifier and QualifiedIdentifier

423+ types inside Database.PostgreSQL.Simple.Types.

424+

425+ * Added support for parameterized VALUES expressions. This is

426+ more general than executeMany and returning. See the

427+ Database.PostgreSQL.Simple.Types.Values data type.

428+

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

430+ * Tweaked C preprocessor directive to be more portable

431+

432+ * Tweaked testsuite for compatibility with aeson-0.7

433+

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

435+ * Relaxed dependency on aeson to >= 0.6

436+

437+ * Update the documentation of `fromField`

438+

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

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

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

442+ performance bump for most people most of the time; however it

443+ may slow down retrieval of large values not converted directly

444+ to ByteString, such as large json, hstore, and array values.

445+ See commit 8635f8 for more information.

446+

447+ * Added the PGArray type. Thanks to Joey Adams for the suggestion

448+

449+ * Fixed JSON decoding, which was almost entirely broken up until now,

450+ due to bugs in the version of aeson currently available on Hackage.

451+ Thanks to Amit Levy for the report.

452+

453+ * Added FromField instances for IORef, MVar, and IOVector.

454+

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

456+ * Added the queryWith function, courtesy of Leonid Onokhov

457+

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

459+

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

461+ * Removed dependency on hashable

462+

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

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

465+ courtesy of Bas van Dijk.

466+

467+ * Added instance FromRow (Maybe a) for most pre-packaged FromRow

468+ instances. See issue #64 for some discussion.

469+

470+ * Added the fromBinary, fromHStoreMap, and fromHStoreList newtype

471+ unwrapper functions, courtesy of Bas van Dijk.

472+

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

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

475+

476+ * Added `Notification.getBackendPID`.

477+

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

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

480+ courtesy of Michael Snoyman

481+

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

483+ * Added `aeson` as a dependency.

484+

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

486+ courtesy of Bas van Dijk.

487+

488+ * Added toJSONField and fromJSONField helper functions for declaring

489+ FromField/ToField JSON instances to other Haskell types, courtesy

490+ of Bas van Dijk.

491+

492+ * Added a FromField instance for (), corresponding to postgresql's void

493+ type.

494+

495+ * Added liftConversion and liftRowParser functions to the Internal

496+ module, for lifting IO actions into the respective monads.

497+

498+ * The SqlError predicates available in the Transaction module are now

499+ also exported from the Errors module.

500+

501+ * Various documentation fixes.

502+

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

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

505+ Manuel Gómez.

506+

507+ * Removed the remaining internal dependencies on BuiltinTypes from

508+ FromField. Added the TypeInfo.Macro module as a result.

509+

510+ * Deprecated the BuiltinTypes module, which will be removed several

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

512+ this change.

513+

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

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

516+ existing FromRow instance for [], courtesy of Doug Beardsley

517+

518+ * Reworked the documentation for the Copy module, and tweaked the

519+ documentation for the LargeObjects module.

520+

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

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

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

524+ module.

525+

526+ * Changed `getNotification` so that it throws a IOError (resource vanished)

527+ exception instead of an ErrorCall exception when it fails to fetch

528+ the connection's file descriptor from libpq.

529+

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

531+ * Optimized the definition of `mconcat` in the Monoid instance for

532+ the Query type, courtesy of Joey Adams.

533+

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

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

536+ polling loop, courtesy of Joey Adams.

537+

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

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

540+ exception, and gave the database cursor a static name preventing

541+ folds from being nested. Thanks to Joey Adams for his

542+ work on these issues.

543+

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

545+ * Added a savepoint abstraction to the Transaction module, courtesy

546+ of Joey Adams

547+

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

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

550+

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

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

553+ Meier

554+

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

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

557+

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

559+

560+ * Improved documentation of the FromField module.

561+

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

563+ * A large chunk of the documentation inside the FromField module had

564+ silently failed to render in Haddock.

565+

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

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

568+ for his work on this feature.

569+

570+ * Added a brand new TypeInfo system that gives FromField instances

571+ convenient and efficient access to the pg_type metatable. This

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

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

574+ work on this feature.

575+

576+ * Changed the type of the `fromField` and `fromRow` methods to allow

577+ a restricted set of IO actions, and stopped pre-calculating the type

578+ name of every column. As a result, the type of the `typename`

579+ operator changed from `Field -> ByteString` to

580+ `Field -> Conversion ByteString`, where Conversion is the new monad

581+ that conversion computations run inside.

582+

583+ * Improved the documentation of the FromField module.

584+

585+ * Added the Database.PostgreSQL.Simple.Errors module, which offers

586+ some predicates and functions for interpreting SqlError values, courtesy

587+ of Leonid Onokhov.

588+

589+ * Added a the name of a column and the associated table's object identifier

590+ to ResultError exceptions, courtesy of Jeff Chu.

591+

592+ * Moved most of the more detailed transaction operators into the

593+ Database.PostgreSQL.Simple.Transaction module.

594+

595+ * Changed withTransactionModeRetry to accept a predicate of which

596+ SqlErrors to retry, due to the fact that serialization errors can

597+ sometimes manifest themselves as constraint violations. Thanks

598+ to Oliver Charles for pointing this out and implementing the change.

599+

600+ * Added simple tests of the fold operator, thanks to Joey Adams.

601+

602+ * Added simple tests of the array conversion code.

603+

604+ * Added recognition of -- comments in the quasiquoter, which are

605+ now stripped out.

606+

607+

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

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

610+ pointing this out.

611+

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

613+ * Added the `withTransactionSerializable` and `withTransactionModeRetry`

614+ operators, thanks to Joey Adams.

615+

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

617+ * Added the `returning` operator, thanks to Jason Dusek

618+

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

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

621+

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

623+

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

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

626+

627+ * Added a type synonym for FieldParser

628+

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

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

631+ clients to set their own value for `standard_conforming_strings`. This

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

633+

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

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

636+ broken even though it will still compile.

637+

638+ * Renamed a number of data constructors, mostly in the BuiltinTypes module.

639+

640+ * Exported ToRow/FromRow from Database.PostgreSQL.Simple

641+

642+

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

644+ * Fix language extensions for compatibility with GHC 7.0

645+

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

647+ * Fix a wayward dependency on Text.

648+

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

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

651+

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

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

654+

655+ * Reworked support for the Time types.

656+

657+ * The conversion from PostgreSQL's `timestamp` (without time zone) type

658+ to Haskell's `UTCTime` type is deprecated and will be removed in 0.2.

659+

660+ * `Data.Time.LocalTime` now has `FromField`/`ToField` instances. It is

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

662+

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

664+ that accommodate PostgreSQL's infinities.

665+

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

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

668+ time package included in GHC.

669+

670+ * Planned breaking changes for 0.2:

671+

672+ * Removing the conversion from `timestamp` to `UTCTime`.

673+

674+ * Renaming some of the type names in `BuiltinTypes`.

675+

676+

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

678+ * Made ZonedTime an instance of FromField and ToField

679+

680+ * Added getNotificationNonBlocking

681+

682+

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

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

685+ PostgreSQL 8 courtesy of Joey Adams.

686+

687+ * postgresql-simple now sets standard_conforming_strings to "on". This

688+ per-connection variable is initialized according to the server

689+ configuration, which defaults to "off" for PostgreSQL < 9, and "on"

690+ for PostgreSQL >= 9. You may need to adjust any string literals in

691+ your SQL queries, or set the variable yourself.

692+

693+ * Exported (:.) from Database.PostgreSQL.Simple

694+

695+

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

697+ * Added some preliminary documentation for the Ok, Notification, and

698+ LargeObjects modules

699+

700+ * Implemented the `fail` method for the monad instance for `Ok`.

701+

702+ * Fixed a bug relating to handling the transaction level

703+

704+

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

706+ * Renamed several modules, typeclasses, and functions:

707+

708+ QueryParams (renderParams) -> ToRow (toRow)

709+ QueryResults (convertResults) -> FromRow (fromRow)

710+ Param (render) -> ToField (toField)

711+ Result (convert) -> FromField (fromField)

712+

713+ * Added the `Database.PostgreSQL.Simple.Ok` module, a variation of

714+ `Either SomeException` that has an instance for `Alternative` and also

715+ uses a list of exceptions to track the ways it has failed.

716+

717+ * Changed the return type of `fromField` and `fromRow` from

718+ `Either SomeException` to `Ok`.

719+

720+ * Thanks to suggestions from Ozgun Ataman, the `FromRow` typeclass has been

721+ massively improved. The result is simpler definitions and better

722+ compositionality. Also, user-defined instances need not be to be

723+ concerned about forcing the converted results to WHNF. Here is an

724+ example comparing the old to the new:

725+

726+ instance (Result a, Result b) => QueryResults (a,b) where

727+ convertResults [fa,fb] [va,vb] = do

728+ !a <- convert fa va

729+ !b <- convert fb vb

730+ return (a,b)

731+ convertResults fs vs = convertError fs vs 2

732+

733+ instance (FromField a, FromField b) => FromRow (a,b) where

734+ fromRow = (,) <$> field <*> field

735+

736+ * Added `(:.)`, a pair that allows one to compose `FromRow` instances:

737+

738+ instance (FromRow a, FromRow b) => FromRow (a :. b) where

739+ fromRow = (:.) <$> fromRow <*> fromRow

740+

741+ * Moved the contents `Field` module into the `FromField` module.

742+

743+ * Removed the `RawResult` type.

744+

745+ * Added `DefaultIsolationLevel` as a distinct `IsolationLevel` option

746+ and `DefaultReadWriteMode` as a distinct `ReadWriteMode`.

CONTRIBUTING.mdnew file+13

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

1+Patches welcome!

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.6.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.6.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+50−167

@@ -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,130 +88,74 @@ getUnbounded getFinite

9288 <|> (Finite <$> getFinite)

9389

9490getDay :: A.Parser Day

95−getDay = do

96− yearStr <- A.takeWhile A.isDigit

97− when (B.length yearStr < 4) (fail "year must consist of at least 4 digits")

98−

99− let !year = toNum yearStr

100− _ <- A.char '-'

101− month <- digits "month"

102− _ <- A.char '-'

103− day <- digits "day"

104−

105− case fromGregorianValid year month day of

106− Nothing -> fail "invalid date"

107− Just x -> return $! x

91+getDay = TP.day

10892

10993getDate :: A.Parser Date

11094getDate = getUnbounded getDay

11195

112−decimal :: Fractional a => B.ByteString -> a

113−decimal str = toNum str / 10^(B.length str)

114−{-# INLINE decimal #-}

115−

11696getTimeOfDay :: A.Parser TimeOfDay

117−getTimeOfDay = do

118− hour <- digits "hours"

119− _ <- A.char ':'

120− minute <- digits "minutes"

121− _ <- A.char ':'

122− second <- digits "seconds"

123− subsec <- (A.char '.' *> (decimal <$> A.takeWhile1 A.isDigit)) <|> return 0

124−

125− let !picos' = second + subsec

126−

127− case makeTimeOfDayValid hour minute picos' of

128− Nothing -> fail "invalid time of day"

129− Just x -> return $! x

97+getTimeOfDay = TP.timeOfDay

13098

13199getLocalTime :: A.Parser LocalTime

132−getLocalTime = LocalTime <$> getDay <*> (A.char ' ' *> getTimeOfDay)

100+getLocalTime = TP.localTime

133101

134102getLocalTimestamp :: A.Parser LocalTimestamp

135103getLocalTimestamp = getUnbounded getLocalTime

136104

137105getTimeZone :: A.Parser TimeZone

138−getTimeZone = do

139− sign <- A.satisfy (\c -> c == '+' || c == '-')

140− hours <- digits "timezone"

141− mins <- (A.char ':' *> digits "timezone minutes") <|> pure 0

142− let !absset = 60 * hours + mins

143− !offset = if sign == '+' then absset else -absset

144− return $! minutesToTimeZone offset

106+getTimeZone = fromMaybe utc <$> TP.timeZone

107+

108+type TimeZoneHMS = (Int,Int,Int)

109+

110+getTimeZoneHMS :: A.Parser TimeZoneHMS

111+getTimeZoneHMS = munge <$> TP.timeZoneHMS

112+ where

113+ munge Nothing = (0,0,0)

114+ munge (Just (TP.UTCOffsetHMS h m s)) = (h,m,s)

115+

116+localToUTCTimeOfDayHMS :: TimeZoneHMS -> TimeOfDay -> (Integer, TimeOfDay)

117+localToUTCTimeOfDayHMS (dh, dm, ds) tod =

118+ TP.localToUTCTimeOfDayHMS (TP.UTCOffsetHMS dh dm ds) tod

145119

146120getZonedTime :: A.Parser ZonedTime

147−getZonedTime = ZonedTime <$> getLocalTime <*> getTimeZone

121+getZonedTime = TP.zonedTime

148122

149123getZonedTimestamp :: A.Parser ZonedTimestamp

150124getZonedTimestamp = getUnbounded getZonedTime

151125

152126getUTCTime :: A.Parser UTCTime

153−getUTCTime = do

154− day <- getDay

155− _ <- A.char ' '

156− time <- getTimeOfDay

157− zone <- getTimeZone

158− let (!dayDelta,!time') = localToUTCTimeOfDay zone time

159− let !day' = addDays dayDelta day

160− let !time'' = timeOfDayToTime time'

161− return (UTCTime day' time'')

127+getUTCTime = TP.utcTime

162128

163129getUTCTimestamp :: A.Parser UTCTimestamp

164130getUTCTimestamp = getUnbounded getUTCTime

165131

166−toNum :: Num n => B.ByteString -> n

167−toNum = B.foldl' (\a c -> 10*a + digit c) 0

168−{-# INLINE toNum #-}

169−

170−digit :: Num n => Word8 -> n

171−digit c = fromIntegral (c .&. 0x0f)

172−{-# INLINE digit #-}

173−

174−digits :: Num n => String -> A.Parser n

175−digits msg = do

176− x <- A.anyChar

177− y <- A.anyChar

178− if A.isDigit x && A.isDigit y

179− then return $! (10 * digit (c2w x) + digit (c2w y))

180− else fail (msg ++ " is not 2 digits")

181−{-# INLINE digits #-}

132+getCalendarDiffTime :: A.Parser CalendarDiffTime

133+getCalendarDiffTime = TP.calendarDiffTime

182134

183135dayToBuilder :: Day -> Builder

184−dayToBuilder (toGregorian -> (y,m,d)) = do

185− pad4 y ++ fromChar '-' ++ pad2 m ++ fromChar '-' ++ pad2 d

136+dayToBuilder = primBounded TPP.day

186137

187138timeOfDayToBuilder :: TimeOfDay -> Builder

188−timeOfDayToBuilder (TimeOfDay h m s) = do

189− pad2 h ++ fromChar ':' ++ pad2 m ++ fromChar ':' ++ showSeconds s

139+timeOfDayToBuilder = primBounded TPP.timeOfDay

190140

191141timeZoneToBuilder :: TimeZone -> Builder

192−timeZoneToBuilder tz

193− | m == 0 = sign h ++ pad2 (abs h)

194− | otherwise = sign h ++ pad2 (abs h) ++ fromChar ':' ++ pad2 (abs m)

195− where

196− (h,m) = timeZoneMinutes tz `quotRem` 60

197− sign h | h >= 0 = fromChar '+'

198− | otherwise = fromChar '-'

142+timeZoneToBuilder = primBounded TPP.timeZone

199143

200144utcTimeToBuilder :: UTCTime -> Builder

201−utcTimeToBuilder (UTCTime day time) =

202− dayToBuilder day ++ fromChar ' '

203− ++ timeOfDayToBuilder (timeToTimeOfDay time) ++ fromByteString "+00"

145+utcTimeToBuilder = primBounded TPP.utcTime

204146

205147zonedTimeToBuilder :: ZonedTime -> Builder

206−zonedTimeToBuilder (ZonedTime localTime tz) =

207− localTimeToBuilder localTime ++ timeZoneToBuilder tz

148+zonedTimeToBuilder = primBounded TPP.zonedTime

208149

209150localTimeToBuilder :: LocalTime -> Builder

210−localTimeToBuilder (LocalTime day tod) =

211− dayToBuilder day ++ fromChar ' ' ++ timeOfDayToBuilder tod

151+localTimeToBuilder = primBounded TPP.localTime

212152

213153unboundedToBuilder :: (a -> Builder) -> (Unbounded a -> Builder)

214154unboundedToBuilder finiteToBuilder unbounded

215155 = case unbounded of

216− NegInfinity -> fromByteString "-infinity"

156+ NegInfinity -> byteString "-infinity"

217157 Finite a -> finiteToBuilder a

218− PosInfinity -> fromByteString "infinity"

158+ PosInfinity -> byteString "infinity"

219159

220160utcTimestampToBuilder :: UTCTimestamp -> Builder

221161utcTimestampToBuilder = unboundedToBuilder utcTimeToBuilder

@@ -230,64 +170,7 @@ dateToBuilder :: Date -> Builder

230170dateToBuilder = unboundedToBuilder dayToBuilder

231171

232172nominalDiffTimeToBuilder :: NominalDiffTime -> Builder

233−nominalDiffTimeToBuilder xyz

234− | yz < 500000 = sign ++ integral x

235− | otherwise = sign ++ integral x ++ fromChar '.' ++ showD6 y

236− where

237− -- A kludge to work around the fact that Data.Fixed isn't very fast and

238− -- doesn't give me access to the MkFixed constructor.

239− sign = if xyz >= 0 then mempty else fromChar '-'

240− (x,yz) = ((unsafeCoerce (abs xyz) :: Integer) + 500000) `quotRem` 1000000000000

241− (fromIntegral -> y, _z) = yz `quotRem` 1000000

242−

243−showSeconds :: Pico -> Builder

244−showSeconds xyz

245− | yz == 0 = pad2 x

246− | z == 0 = pad2 x ++ fromChar '.' ++ showD6 y

247− | otherwise = pad2 x ++ fromChar '.' ++ pad6 y ++ showD6 z

248− where

249− -- A kludge to work around the fact that Data.Fixed isn't very fast and

250− -- doesn't give me access to the MkFixed constructor.

251− (x_,yz) = (unsafeCoerce xyz :: Integer) `quotRem` 1000000000000

252− x = fromIntegral x_ :: Int

253− (fromIntegral -> y, fromIntegral -> z) = yz `quotRem` 1000000

254−

255−pad6 :: Int -> Builder

256−pad6 xy = let (x,y) = xy `quotRem` 1000

257− in pad3 x ++ pad3 y

258−

259−showD6 :: Int -> Builder

260−showD6 xy = case xy `quotRem` 1000 of

261− (x,0) -> showD3 x

262− (x,y) -> pad3 x ++ showD3 y

263−

264−pad3 :: Int -> Builder

265−pad3 abc = let (ab,c) = abc `quotRem` 10

266− (a,b) = ab `quotRem` 10

267− in p a ++ p b ++ p c

268−

269−showD3 :: Int -> Builder

270−showD3 abc = case abc `quotRem` 100 of

271− (a, 0) -> p a

272− (a,bc) -> case bc `quotRem` 10 of

273− (b,0) -> p a ++ p b

274− (b,c) -> p a ++ p b ++ p c

275−

276−-- | p assumes its input is in the range [0..9]

277−p :: Integral n => n -> Builder

278−p n = fromChar (w2c (fromIntegral (n + 48)))

279−{-# INLINE p #-}

280−

281−-- | pad2 assumes its input is in the range [0..99]

282−pad2 :: Integral n => n -> Builder

283−pad2 n = let (a,b) = n `quotRem` 10 in p a ++ p b

284−{-# INLINE pad2 #-}

285−

286−-- | pad4 assumes its input is positive

287−pad4 :: (Integral n, Show n) => n -> Builder

288−pad4 abcd | abcd >= 10000 = integral abcd

289− | otherwise = p a ++ p b ++ p c ++ p d

290− where (ab,cd) = abcd `quotRem` 100

291− (a,b) = ab `quotRem` 10

292− (c,d) = cd `quotRem` 10

293−{-# INLINE pad4 #-}

173+nominalDiffTimeToBuilder = TPP.nominalDiffTime

174+

175+calendarDiffTimeToBuilder :: CalendarDiffTime -> Builder

176+calendarDiffTimeToBuilder = TPP.calendarDiffTime

src/Database/PostgreSQL/Simple/Time/Internal.hs+3

@@ -19,6 +19,9 @@ module Database.PostgreSQL.Simple.Time.Internal

1919 , getZonedTimestamp

2020 , getUTCTime

2121 , getUTCTimestamp

22+ , TimeZoneHMS

23+ , getTimeZoneHMS

24+ , localToUTCTimeOfDayHMS

2225 ) where

2326

2427import Database.PostgreSQL.Simple.Time.Implementation

src/Database/PostgreSQL/Simple/Time/Internal/Parser.hsnew file+204

@@ -0,0 +1,204 @@

1+{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}

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+63−15

@@ -17,42 +17,82 @@ correspond; for example, a conversion that consistently added hour

1717when printed to a string and subtracted an hour when parsed from string

1818would still pass these tests.

1919

20+

21+Right now, we are checking that 1400+ timestamps in the range of 1860 to

22+2060 round trip from postgresql to haskell and back in 5 different timezones.

23+In addition to UTC, the four timezones were selected so that 2 have a positive

24+offset, and 2 have a negative offset, and that 2 have an offset of a

25+whole number of hours, while the other two do not.

26+

27+It may be worth adding a few more timezones to ensure better test coverage.

28+

29+We are checking a handful of selected timestamps to ensure we hit

30+various corner-cases in the code, in addition to 1400 timestamps randomly

31+generated with granularity of seconds down to microseconds in powers of ten.

32+

2033-}

2134

2235module Time (testTime) where

2336

2437import Common

2538import Control.Monad(forM_, replicateM_)

26−import Data.Time

39+import Data.Time.Compat

2740import Data.ByteString(ByteString)

2841import Database.PostgreSQL.Simple.SqlQQ

2942

3043numTests :: Int

3144numTests = 200

3245

33−testTime :: TestEnv -> Test

34−testTime env@TestEnv{..} = TestCase $ do

46+testTime :: TestEnv -> Assertion

47+testTime env@TestEnv{..} = do

3548 initializeTable env

3649 execute_ conn "SET timezone TO 'UTC'"

37− checkRoundTrips env

38− execute_ conn "SET timezone TO 'America/Chicago'"

39− checkRoundTrips env

40− execute_ conn "SET timezone TO 'Asia/Tokyo'"

41− checkRoundTrips env

42− execute_ conn "SET timezone TO 'Asia/Kathmandu'"

43− checkRoundTrips env

44− execute_ conn "SET timezone TO 'America/St_Johns'"

45− checkRoundTrips env

50+ checkRoundTrips env "1860-01-01 00:00:00+00"

51+ execute_ conn "SET timezone TO 'America/Chicago'" -- -5:00

52+ checkRoundTrips env "1883-11-18 12:00:00-06"

53+ execute_ conn "SET timezone TO 'Asia/Tokyo'" -- +9:00

54+ checkRoundTrips env "1888-01-01 00:00:00+09"

55+ execute_ conn "SET timezone TO 'Asia/Kathmandu'" -- +5:45

56+ checkRoundTrips env "1919-12-31 23:48:44+05:30"

57+ execute_ conn "SET timezone TO 'America/St_Johns'" -- -3:30

58+ checkRoundTrips env "1935-03-30 00:00:52-03:30"

4659

4760initializeTable :: TestEnv -> IO ()

4861initializeTable TestEnv{..} = withTransaction conn $ do

4962 execute_ conn

5063 [sql| CREATE TEMPORARY TABLE testtime

5164 ( x serial, y timestamptz, PRIMARY KEY(x) ) |]

65+

66+ let test :: ByteString -> IO () = \x -> do

67+ execute conn [sql|

68+ INSERT INTO testtime (y) VALUES (?)

69+ |] (Only x)

70+ return ()

71+ -- America/Chicago

72+ test "1883-11-18 11:59:59-05:50:36"

73+ test "1883-11-18 12:09:23-05:50:36"

74+ test "1883-11-18 12:00:00-06"

75+ -- Asia/Tokyo

76+ test "1887-12-31 23:59:59+09:18:59"

77+ test "1888-01-01 00:18:58+09:18:59"

78+ test "1888-01-01 00:00:00+09"

79+ -- Asia/Kathmandu

80+ test "1919-12-31 23:59:59+05:41:16"

81+ test "1919-12-31 23:48:44+05:30"

82+ test "1985-12-31 23:59:59+05:30"

83+ test "1986-01-01 00:15:00+05:45"

84+ -- America/St_Johns

85+ test "1935-03-29 23:59:59-03:30:52"

86+ test "1935-03-30 00:00:52-03:30"

87+

88+ -- While the above special cases are probably a decent start, there

89+ -- are probably more that are well worth adding to ensure better

90+ -- coverage.

91+

5292 let pop :: ByteString -> Double -> IO () = \x y ->

5393 replicateM_ numTests $ execute conn

5494 [sql| INSERT INTO testtime (y) VALUES

55− ('1936-01-01 00:00:00+00'::timestamptz

95+ ('1860-01-01 00:00:00+00'::timestamptz

5696 + ?::interval * ROUND(RANDOM() * ?)) |] (x,y)

5797 pop "1 microsecond" 6.3113904e15

5898 pop "10 microseconds" 6.3113904e14

@@ -62,10 +102,18 @@ initializeTable TestEnv{..} = withTransaction conn $ do

62102 pop "100 milliseconds" 6.3113904e10

63103 pop "1 second" 6.3113904e9

64104

65−checkRoundTrips :: TestEnv -> IO ()

66−checkRoundTrips TestEnv{..} = do

105+checkRoundTrips :: TestEnv -> ByteString -> IO ()

106+checkRoundTrips TestEnv{..} limit = do

67107 yxs :: [(UTCTime, Int)] <- query_ conn [sql| SELECT y, x FROM testtime |]

68108 forM_ yxs $ \yx -> do

69109 res <- query conn [sql| SELECT y=? FROM testtime WHERE x=? |] yx

70110 assertBool "UTCTime did not round-trip from SQL to Haskell and back" $

71111 res == [Only True]

112+

113+ yxs :: [(ZonedTime, Int)] <- query conn [sql|

114+ SELECT y, x FROM testtime WHERE y > ?

115+ |] (Only limit)

116+ forM_ yxs $ \yx -> do

117+ res <- query conn [sql| SELECT y=? FROM testtime WHERE x=? |] yx

118+ assertBool "ZonedTime did not round-trip from SQL to Haskell and back" $

119+ res == [Only True]

test/results/malformed-input.expectednew file+4

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

1+user error (Database.PostgreSQL.Simple.Copy.putCopyEnd: failed to parse command status

2+Connection error: ERROR: invalid input syntax for type integer: "z"

3+CONTEXT: COPY copy_unique_constraint_error_test, line 3, column x: "z"

4+)

test/results/unique-constraint-violation.expectednew file+5

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

1+user error (Database.PostgreSQL.Simple.Copy.putCopyEnd: failed to parse command status

2+Connection error: ERROR: duplicate key value violates unique constraint "copy_unique_constraint_error_test_pkey"

3+DETAIL: Key (x)=(1) already exists.

4+CONTEXT: COPY copy_unique_constraint_error_test, line 3

5+)

tools/GenBuiltinTypes.hsdeleted−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])